summaryrefslogtreecommitdiffstats
path: root/tcllib/modules/yaml
diff options
context:
space:
mode:
authorWilliam Joye <wjoye@cfa.harvard.edu>2016-10-27 19:39:39 (GMT)
committerWilliam Joye <wjoye@cfa.harvard.edu>2016-10-27 19:39:39 (GMT)
commitea28451286d3ea4a772fa174483f9a7a66bb1ab3 (patch)
tree6ee9d8a7848333a7ceeee3b13d492e40225f8b86 /tcllib/modules/yaml
parentb5ca09bae0d6a1edce939eea03594dd56383f2c8 (diff)
parent7c621da28f07e449ad90c387344f07a453927569 (diff)
downloadblt-ea28451286d3ea4a772fa174483f9a7a66bb1ab3.zip
blt-ea28451286d3ea4a772fa174483f9a7a66bb1ab3.tar.gz
blt-ea28451286d3ea4a772fa174483f9a7a66bb1ab3.tar.bz2
Merge commit '7c621da28f07e449ad90c387344f07a453927569' as 'tcllib'
Diffstat (limited to 'tcllib/modules/yaml')
-rw-r--r--tcllib/modules/yaml/06eef112da.data7
-rw-r--r--tcllib/modules/yaml/CHANGES62
-rw-r--r--tcllib/modules/yaml/ChangeLog52
-rwxr-xr-xtcllib/modules/yaml/huddle.man558
-rwxr-xr-xtcllib/modules/yaml/huddle.tcl646
-rwxr-xr-xtcllib/modules/yaml/huddle.test363
-rw-r--r--tcllib/modules/yaml/huddle_types.tcl296
-rw-r--r--tcllib/modules/yaml/json2huddle.tcl389
-rw-r--r--tcllib/modules/yaml/json2huddle.test181
-rwxr-xr-xtcllib/modules/yaml/layers.txt224
-rw-r--r--tcllib/modules/yaml/pkgIndex.tcl6
-rw-r--r--tcllib/modules/yaml/rb.test654
-rwxr-xr-xtcllib/modules/yaml/yaml.bench87
-rw-r--r--tcllib/modules/yaml/yaml.man189
-rw-r--r--tcllib/modules/yaml/yaml.tcl1283
-rw-r--r--tcllib/modules/yaml/yaml.test775
16 files changed, 5772 insertions, 0 deletions
diff --git a/tcllib/modules/yaml/06eef112da.data b/tcllib/modules/yaml/06eef112da.data
new file mode 100644
index 0000000..a2bc91e
--- /dev/null
+++ b/tcllib/modules/yaml/06eef112da.data
@@ -0,0 +1,7 @@
+---
+- &foo
+- &bar
+- alpha: 43
+ beta:
+ houston: [*foo]
+ newyork: [[*bar,[aaa]]]
diff --git a/tcllib/modules/yaml/CHANGES b/tcllib/modules/yaml/CHANGES
new file mode 100644
index 0000000..7052846
--- /dev/null
+++ b/tcllib/modules/yaml/CHANGES
@@ -0,0 +1,62 @@
+#
+# YAML parser for Tcl.
+#
+# Load this file!
+# >> yaml::load "CHANGES"
+#
+---
+title: YAML parser for Tcl.
+version: 0.3.6
+authors:
+ - KATO Kanryu: kanryu6@users.sourceforge.net
+license: tcllib's BSD-style license
+copyright: (c) 2008 KATO Kanryu
+
+changes:
+
+ 0.3.6:
+ - 2011-08-23
+ - fixed for empty block/floating sub node. to see
+ - https://sourceforge.net/tracker/?func=detail&atid=112883&aid=3396656&group_id=12883
+ - https://core.tcl.tk/tcllib/tktview?name=3396661fff
+ 0.3.5:
+ - 2009-05-24
+ - To read uninitialized yaml::data(current), when there is not empty line
+ or "---" at the beginning of yaml.
+ - Thanks al_chou!
+ - https://core.tcl.tk/tcllib/tktview?name=2795699fff
+ - supported for YAML termination(...)
+ 0.3.4:
+ - 2008-09-27
+ - fixed for some incorrect use of "string first/last"
+ 0.3.3:
+ - 2008-06-05
+ - add benchmark
+ - validate check fors scripts
+ 0.3.2:
+ - 2008-06-03
+ - add command huddle2yaml
+ - validate check fors scripts
+ 0.3.1:
+ - 2008-06-02
+ - change comanndname from load to yaml2dict
+ - add command huddle2yaml
+ 0.3.0:
+ - 2008-06-01
+ - testsuites for Tcl8.4
+ - using huddle-lib
+ - not to auto-convert for mapping keys
+ 0.2.2:
+ - 2008-05-17
+ - begin to implement tag treatment
+ - add !!float / !!binary(base64) parsing.
+ - merge mapping "<<"
+ 0.2.1:
+ - 2008-05-14
+ - add timestamp / integer parsing.
+ - improved a manual.
+ 0.2.0:
+ - parser reimplimented from scratch.
+ - write a manual.
+ 0.1.0:
+ - Changed the library name, from yapt-0.1.2 to yaml-0.1.0
diff --git a/tcllib/modules/yaml/ChangeLog b/tcllib/modules/yaml/ChangeLog
new file mode 100644
index 0000000..85d7246
--- /dev/null
+++ b/tcllib/modules/yaml/ChangeLog
@@ -0,0 +1,52 @@
+2013-02-01 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ *
+ * Released and tagged Tcllib 1.15 ========================
+ *
+
+2011-12-13 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ *
+ * Released and tagged Tcllib 1.14 ========================
+ *
+
+2011-01-24 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ *
+ * Released and tagged Tcllib 1.13 ========================
+ *
+
+2011-01-12 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ * huddle.tcl: Fixed package setup (version), and included files.
+ * huddle.man:
+ * pkgIndex.tcl:
+
+2009-12-07 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ *
+ * Released and tagged Tcllib 1.12 ========================
+ *
+
+2008-12-12 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ *
+ * Released and tagged Tcllib 1.11.1 ========================
+ *
+
+2008-10-16 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ *
+ * Released and tagged Tcllib 1.11 ========================
+ *
+
+2008-09-03 Andreas Kupries <andreas_kupries@users.sourceforge.net>
+
+ * huddle.test: Tweaked the testsuites a bit for better
+ * rb.test: handling of a missing dict support package.
+ * yaml.test:
+
+2008-05-22 Andreas Kupries <andreask@activestate.com>
+
+ * New module for parsing YAML files, by kanryu6.
+
diff --git a/tcllib/modules/yaml/huddle.man b/tcllib/modules/yaml/huddle.man
new file mode 100755
index 0000000..9ce2bfb
--- /dev/null
+++ b/tcllib/modules/yaml/huddle.man
@@ -0,0 +1,558 @@
+[vset VERSION 0.2]
+[comment {-*- tcl -*- doctools manpage}]
+[manpage_begin huddle n [vset VERSION]]
+[see_also yaml]
+[keywords {data exchange}]
+[keywords {exchange format}]
+[keywords huddle]
+[keywords json]
+[keywords parsing]
+[keywords {text processing}]
+[keywords yaml]
+[copyright {2008-2011 KATO Kanryu <kanryu6@users.sourceforge.net>}]
+[copyright {2015 Miguel Martínez López <aplicacionamedida@gmail.com>}]
+[moddesc {HUDDLE}]
+[titledesc {Create and manipulate huddle object}]
+[require Tcl 8.4]
+[require huddle [opt [vset VERSION]]]
+[description]
+[para]
+Huddle provides a generic Tcl-based serialization/intermediary format.
+Currently, each node is wrapped in a tag with simple type information.
+[para]
+
+When converting huddle-notation to other serialization formats like
+JSON or YAML this type information is used to select the proper notation.
+And when going from JSON/YAML/... to huddle their notation can be used
+to select the proper huddle type.
+[para]
+In that manner huddle can serve as a common intermediary format.
+
+[example {
+huddle-format: >
+ {HUDDLE {huddle-node}}
+huddle-node: >
+ {tag content}
+each content of tag means:
+ s: (content is a) string
+ L: list, each sub node is a huddle-node
+ D: dict, each sub node is a huddle-node
+confirmed:
+ - JSON
+ - YAML(generally, but cannot discribe YAML-tags)
+limitation:
+ - cannot discribe aliases from a node to other node.
+}]
+
+[para]
+The [package huddle] package returns
+data as a Tcl [cmd dict]. Either the [package dict] package or Tcl 8.5 is
+required for use.
+
+[section COMMANDS]
+
+[list_begin definitions]
+
+[call [cmd "huddle create"] [arg key] [arg value] [opt [arg "key value ..."]]]
+
+Create a huddle object as a dict. It can contain other huddle objects.
+
+[call [cmd "huddle list"] [opt [arg "value value ..."]]]
+Create a huddle object as a list. It can contain other huddle objects.
+
+[call [cmd "huddle number"] [arg "number"]]
+Create a huddle object as a number.
+
+[call [cmd "huddle string"] [arg "string"]]
+Create a huddle object as a string.
+
+[call [cmd "huddle boolean"] [arg "expression to evaluate as true or false"]]
+Create a huddle object as a boolean evaluating an expression as true or false-
+
+[call [cmd "huddle true"]]
+Create a huddle object as a boolean true.
+
+[call [cmd "huddle false"]]
+Create a huddle object as a boolean false.
+
+[call [cmd "huddle null"]]
+Create a huddle object as a null.
+
+[call [cmd "huddle get"] [arg object] [arg key] [opt [arg "key ..."]]]
+Almost the same as [cmd "dict get"].
+Get a sub-object from the huddle object.
+[arg key] can be used to huddle-list's index.
+
+[call [cmd "huddle gets"] [arg object] [arg key] [opt [arg "key ..."]]]
+Get a sub-object from the huddle object, stripped.
+
+[call [cmd "huddle set"] [arg objectVar] [arg key] [opt [arg "key ..."]] [arg value]]
+Almost the same as [cmd "dict set"].
+Set a sub-object from the huddle object.
+[arg key] can be used to huddle-list's index.
+
+[call [cmd "huddle remove"] [arg object] [arg key] [opt [arg "key ..."]]]
+Almost the same as [cmd "dict remove"].
+Remove a sub-object from the huddle object.
+[arg key] can be used to huddle-list's index.
+
+[call [cmd "huddle combine"] [arg object1] [arg object2] [opt [arg "object3 ..."]]]
+Merging huddle objects given.
+
+[example {
+% set aa [huddle create a b c d]
+HUDDLE {D {a {s b} c {s d}}}
+% set bb [huddle create a k l m]
+HUDDLE {D {a {s k} l {s m}}}
+% huddle combine $aa $bb
+HUDDLE {D {a {s k} c {s d} l {s m}}}
+}]
+
+[call [cmd "huddle equal"] [arg object1] [arg object2]]
+Comparing two huddle objects recursively.
+When to equal, returns 1, otherwise 0.
+
+[example {
+% set aa [huddle create a b c d]
+HUDDLE {D {a {s b} c {s d}}}
+% set bb [huddle create c d a b]
+HUDDLE {D {c {s d} a {s b}}}
+% huddle equal $aa $bb
+1
+}]
+
+[call [cmd "huddle append"] [arg objectVar] [arg key] [arg value] [opt [arg "key value ..."]]]
+[call [cmd "huddle append"] [arg objectVar] [arg value] [opt [arg "value ..."]]]
+Appending child elements. When for dicts, giving key/value. When for lists, giving values.
+
+[example {
+% set aa [huddle create a b c d]
+HUDDLE {D {a {s b} c {s d}}}
+% huddle append aa a k l m
+HUDDLE {D {a {s k} c {s d} l {s m}}}
+% set bb [huddle list i j k l]
+HUDDLE {L {{s i} {s j} {s k} {s l}}}
+% huddle append bb g h i
+HUDDLE {L {{s i} {s j} {s k} {s l} {s g} {s h} {s i}}}
+}]
+
+[call [cmd "huddle keys"] [arg object]]
+The same as [cmd "dict keys"].
+
+[call [cmd "huddle llength"] [arg object]]
+The same as [cmd llength].
+
+[call [cmd "huddle type"] [arg object] [opt [arg "key key..."]]]
+Return the element type of specified by keys.
+if [opt key] is not given, returns the type of root node.
+[para]
+
+[list_begin options]
+[opt_def [const string]]
+
+the node is a tcl's string.
+
+[opt_def [const dict]]
+
+the node is a dict.
+
+[opt_def [const list]]
+
+the node is a list.
+
+[opt_def [const number]]
+
+the node is a number.
+
+[opt_def [const boolean]]
+
+the node is a boolean.
+
+[opt_def [const null]]
+
+the node is a null.
+
+[list_end]
+
+[example {
+% huddle type {HUDDLE {s str}}
+string
+% huddle type {HUDDLE {L {{s a} {s b} {s c}}}}
+list
+% huddle type {HUDDLE {D {aa {s b} cc {s d}}}} cc
+string
+}]
+
+[call [cmd "huddle strip"] [arg object]]
+Stripped all tags. Converted to normal Tcl's list/dict.
+
+[call [cmd "huddle jsondump"] [arg object] [opt [arg offset]] [opt [arg newline]] [opt [arg begin_offset]]]
+
+dump a json-stream from the huddle-object.
+
+[para]
+[list_begin options]
+[opt_def "[const offset] \"\""]
+
+begin offset as spaces " ".
+
+[list_end]
+
+[example {# normal output has some indents. some strings are escaped.
+% huddle jsondump {HUDDLE {L {{L {{s i} {s baa} {s \\k} {L {{s 1.0} {s true} {s /g} {s h}}} {L {{s g}}}}} {s t}}}}
+[
+ [
+ "i",
+ "baa",
+ "\\k",
+ [
+ 1.0,
+ true,
+ "\/g",
+ "h"
+ ],
+ ["g"]
+ ],
+ "t"
+]
+# stripped output
+% huddle jsondump {HUDDLE {D {dd {D {bb {D {a {s baa} c {s {d
+a}}}} cc {D {g {s h}}}}} ee {D {i {s j} k {s 1} j {s { m\a}}}}}}} "" ""
+{"dd": {"bb": {"a": "baa","c": "d\na"},"cc": {"g": "h"}},"ee": {"i": "j","k": 1,"j": " m\\a"}}
+}]
+
+[call [cmd "huddle compile"] [arg spec] [arg data]]
+
+construct a huddle object from plain old tcl values.
+
+[arg spec] is defined as follows:
+[list_begin definitions]
+[def [const string]]
+data is simply a string
+
+[def [const list]]
+data is a tcl list of strings
+
+[def [const dict]]
+data is a tcl dict of strings
+
+[def "list list"]
+data is a tcl list of lists
+
+[def "list dict"]
+data is a tcl list of dicts
+
+[def "dict xx list"]
+data is a tcl dict where the value of key xx is a tcl list
+
+[def "dict * list"]
+data is a tcl dict of lists
+
+[arg data] is plain old tcl values
+[list_end]
+
+[example {% huddle compile {dict * list} {a {1 2 3} b {4 5}}
+HUDDLE {D {a {L {{s 1} {s 2} {s 3}}} b {L {{s 4} {s 5}}}}}
+% huddle compile {dict * {list {dict d list}}} {a {{c 1} {d {2 2 2} e 3}} b {{f 4 g 5}}}
+HUDDLE {D {a {L {{D {c {s 1}}} {D {d {L {{s 2} {s 2} {s 2}}} e {s 3}}}}} b {L {{D {f {s 4} g {s 5}}}}}}}
+}]
+
+[call [cmd "huddle isHuddle"] [arg object]]
+if [arg object] is a huddle, returns 1. the other, returns 0.
+
+[call [cmd "huddle checkHuddle"] [arg object]]
+if [arg object] is not a huddle, rises an error.
+
+[call [cmd "huddle to_node"] [arg object] [opt [arg tag]]]
+for type-callbacks.
+[para]
+if [arg object] is a huddle, returns root-node. the other, returns [cmd {[list s $object]}].
+
+[example {
+% huddle to_node str
+s str
+% huddle to_node str !!str
+!!str str
+% huddle to_node {HUDDLE {s str}}
+s str
+% huddle to_node {HUDDLE {l {a b c}}}
+l {a b c}
+}]
+
+[call [cmd "huddle wrap"] [arg tag] [arg src]]
+for type-callbacks.
+[para]
+Create a huddle object from [arg src] with specified [arg tag].
+
+[example {
+% huddle wrap "" str
+HUDDLE str
+% huddle wrap s str
+HUDDLE {s str}
+}]
+
+[call [cmd "huddle call"] [arg tag] [arg command] [arg args]]
+for type-callbacks.
+[para]
+devolving [arg command] to default [arg tag]-callback
+
+[call [cmd "huddle addType"] [arg callback]]
+add a user-specified-type/tag to the huddle library.
+To see "Additional Type".
+
+[para]
+
+[list_begin options]
+[opt_def callback]
+
+callback function name for additional type.
+
+[list_end]
+[list_end]
+
+[section {TYPE CALLBACK}]
+[para]
+
+The definition of callback for user-type.
+
+[list_begin definitions]
+[call [cmd callback] [arg command] [opt [arg args]]]
+[list_begin options]
+[opt_def command]
+huddle subcomand which is needed to reply by the callback.
+[opt_def args]
+arguments of subcommand. The number of list of arguments is different for each subcommand.
+
+[list_end]
+[list_end]
+
+[para]
+
+The callback procedure shuould reply the following subcommands.
+[list_begin definitions]
+[call [cmd setting]]
+only returns a fixed dict of the type infomation for setting the user-tag.
+[list_begin definitions]
+[def "[const type] typename"]
+typename of the type
+
+[def "[const method] {method1 method2 method3 ...}"]
+method list as huddle subcommand. Then, you can call [cmd {[huddle method1 ...]}]
+
+[def "[const tag] {tag1 child/parent tag2 child/parent ...}"]
+tag list for huddle-node as a dict. if the type has child-nodes, use "parent", otherwise use "child".
+
+[list_end]
+
+[call [cmd get_sub] [arg src] [arg key]]
+returns a sub node specified by [arg key].
+[list_begin options]
+[opt_def src]
+a node content in huddle object.
+[list_end]
+
+[call [cmd strip] [arg src]]
+returns stripped node contents. if the type has child nodes, every node must be stripped.
+
+[call [cmd set] [arg src] [arg key] [arg value]]
+sets a sub-node from the tagged-content, and returns self.
+
+[call [cmd remove] [arg src] [arg key] [arg value]]
+removes a sub-node from the tagged-content, and returns self.
+
+[list_end]
+
+[para]
+
+[cmd strip] must be defined at all types.
+[cmd get_sub] must be defined at container types.
+[cmd set/remove] shuould be defined, if you call them.
+
+[example {
+# callback sample for my-dict
+proc my_dict_setting {command args} {
+ switch -- $command {
+ setting { ; # type definition
+ return {
+ type dict
+ method {create keys}
+ tag {d child D parent}
+ constructor create
+ str s
+ }
+ # type: the type-name
+ # method: add methods to huddle's subcommand.
+ # "get_sub/strip/set/remove/equal/append" called by huddle module.
+ # "strip" must be defined at all types.
+ # "get_sub" must be defined at container types.
+ # "set/remove/equal/append" shuould be defined, if you call them.
+ # tag: tag definition("child/parent" word is maybe obsoleted)
+ }
+ get_sub { ; # get a sub-node specified by "key" from the tagged-content
+ foreach {src key} $args break
+ return [dict get $src $key]
+ }
+ strip { ; # strip from the tagged-content
+ foreach {src nop} $args break
+ foreach {key val} $src {
+ lappend result $key [huddle strip $val]
+ }
+ return $result
+ }
+ set { ; # set a sub-node from the tagged-content
+ foreach {src key value} $args break
+ dict set src $key $value
+ return $src
+ }
+ remove { ; # remove a sub-node from the tagged-content
+ foreach {src key value} $args break
+ return [dict remove $src $key]
+ }
+ equal { ; # check equal for each node
+ foreach {src1 src2} $args break
+ if {[llength $src1] != [llength $src2]} {return 0}
+ foreach {key1 val1} $src1 {
+ if {![dict exists $src2 $key1]} {return 0}
+ if {![huddle _equal_subs $val1 [dict get $src2 $key1]]} {return 0}
+ }
+ return 1
+ }
+ append { ; # append nodes
+ foreach {str src list} $args break
+ if {[llength $list] % 2} {error {wrong # args: should be "huddle append objvar ?key value ...?"}}
+ set resultL $src
+ foreach {key value} $list {
+ if {$str ne ""} {
+ lappend resultL $key [huddle to_node $value $str]
+ } else {
+ lappend resultL $key $value
+ }
+ }
+ return [eval dict create $resultL]
+ }
+ create { ; # $args: all arguments after "huddle create"
+ if {[llength $args] % 2} {error {wrong # args: should be "huddle create ?key value ...?"}}
+ set resultL {}
+ foreach {key value} $args {
+ lappend resultL $key [huddle to_node $value]
+ }
+ return [huddle wrap D $resultL]
+ }
+ keys {
+ foreach {src nop} $args break
+ return [dict keys [lindex [lindex $src 1] 1]]
+ }
+ default {
+ error "$command is not callback for dict"
+ }
+ }
+}
+}]
+[example {
+# inheritance sample from default dict-callback
+proc ::yaml::_huddle_mapping {command args} {
+ switch -- $command {
+ setting { ; # type definition
+ return {
+ type dict
+ method {mapping}
+ tag {!!map parent}
+ constructor mapping
+ str !!str
+ }
+ }
+ mapping { ; # $args: all arguments after "huddle mapping"
+ if {[llength $args] % 2} {error {wrong # args: should be "huddle mapping ?key value ...?"}}
+ set resultL {}
+ foreach {key value} $args {
+ lappend resultL $key [huddle to_node $value !!str]
+ }
+ return [huddle wrap !!map $resultL]
+ }
+ default { ; # devolving to default dict-callback
+ return [huddle call D $command $args]
+ }
+ }
+}
+}]
+
+[section "How to add type"]
+
+[para]
+You can add huddle-node types e.g. ::struct::tree.
+
+To do so, first, define a callback-procedure for additional tagged-type.
+The proc get argments as [arg command] and [opt [arg args]]. It has some switch-sections.
+
+[para]
+And, addType subcommand will called.
+[example {
+huddle addType my_dict_setting
+}]
+
+[section "WORKING SAMPLE"]
+[example {
+# create as a dict
+% set bb [huddle create a b c d]
+HUDDLE {D {a {s b} c {s d}}}
+
+# create as a list
+% set cc [huddle list e f g h]
+HUDDLE {L {{s e} {s f} {s g} {s h}}}
+% set bbcc [huddle create bb $bb cc $cc]
+HUDDLE {D {bb {D {a {s b} c {s d}}} cc {L {{s e} {s f} {s g} {s h}}}}}
+% set folding [huddle list $bbcc p [huddle list q r] s]
+HUDDLE {L {{D {bb {D {a {s b} c {s d}}} cc {L {{s e} {s f} {s g} {s h}}}}} {s p} {L {{s q} {s r}}} {s s}}}
+
+# normal Tcl's notation
+% huddle strip $folding
+{bb {a b c d} cc {e f g h}} p {q r} s
+
+# get a sub node
+% huddle get $folding 0 bb
+HUDDLE {D {a {s b} c {s d}}}
+% huddle gets $folding 0 bb
+a b c d
+
+# overwrite a node
+% huddle set folding 0 bb c kkk
+HUDDLE {L {{D {bb {D {a {s b} c {s kkk}}} cc {L {{s e} {s f} {s g} {s h}}}}} {s p} {L {{s q} {s r}}} {s s}}}
+
+# remove a node
+% huddle remove $folding 2 1
+HUDDLE {L {{D {bb {D {a {s b} c {s kkk}}} cc {L {{s e} {s f} {s g} {s h}}}}} {s p} {L {{s q}}} {s s}}}
+% huddle strip $folding
+{bb {a b c kkk} cc {e f g h}} p {q r} s
+
+# dump as a JSON stream
+% huddle jsondump $folding
+[
+ {
+ "bb": {
+ "a": "b",
+ "c": "kkk"
+ },
+ "cc": [
+ "e",
+ "f",
+ "g",
+ "h"
+ ]
+ },
+ "p",
+ [
+ "q",
+ "r"
+ ],
+ "s"
+]
+}]
+
+[section LIMITATIONS]
+
+[para]
+now printing.
+
+[vset CATEGORY huddle]
+[include ../doctools2base/include/feedback.inc]
+[manpage_end]
diff --git a/tcllib/modules/yaml/huddle.tcl b/tcllib/modules/yaml/huddle.tcl
new file mode 100755
index 0000000..8d289bb
--- /dev/null
+++ b/tcllib/modules/yaml/huddle.tcl
@@ -0,0 +1,646 @@
+# huddle.tcl (working title)
+#
+# huddle.tcl 0.1.5 2011-08-23 14:46:47 KATO Kanryu(kanryu6@users.sourceforge.net)
+#
+# It is published with the terms of tcllib's BSD-style license.
+# See the file named license.terms.
+#
+# This library provide functions to differentinate string/list/dict in multi-ranks.
+#
+# Copyright (c) 2008-2011 KATO Kanryu <kanryu6@users.sourceforge.net>
+# Copyright (c) 2015 Miguel Martínez López <aplicacionamedida@gmail.com>
+
+package require Tcl 8.5
+package provide huddle 0.2
+
+namespace eval ::huddle {
+ namespace export huddle wrap unwrap isHuddle strip_node are_equal_nodes argument_to_node get_src
+
+ variable types
+
+ # Some subcommands conflict with Tcl builtin commands. So, we make
+ # the convention of using the first letter in uppercase for
+ # private procs (e.g. from "set" to "Set")
+
+ namespace ensemble create -map {
+ set ::huddle::Set
+ append ::huddle::Append
+ get ::huddle::Get
+ get_stripped ::huddle::get_stripped
+ unset ::huddle::Unset
+ combine ::huddle::combine
+ combine_relaxed ::huddle::combine_relaxed
+ type ::huddle::type
+ remove ::huddle::remove
+ equal ::huddle::equal
+ exists ::huddle::exists
+ clone ::huddle::clone
+ isHuddle ::huddle::isHuddle
+ wrap ::huddle::wrap
+ unwrap ::huddle::unwrap
+ addType ::huddle::addType
+ jsondump ::huddle::jsondump
+ compile ::huddle::compile
+ }
+}
+
+proc ::huddle::addType {typeNamespace} {
+ variable types
+
+ set typeName [namespace tail $typeNamespace]
+ set typeCommand ::huddle::Type_$typeName
+
+ namespace upvar $typeNamespace settings settings
+
+ if {[dict exists $settings map]} {
+ set ensemble_map_of_type [dict get $settings map]
+ set renamed_subcommands [dict values $ensemble_map_of_type]
+ } else {
+ set renamed_subcommands [list]
+ }
+
+ dict set ensemble_map_of_type settings ${typeNamespace}::settings
+
+ foreach path_to_subcommand [info procs ${typeNamespace}::*] {
+ set subcommand [namespace tail $path_to_subcommand]
+
+ if {$subcommand ni $renamed_subcommands} {
+ dict set ensemble_map_of_type $subcommand ${typeNamespace}::$subcommand
+ }
+ }
+
+ namespace eval $typeNamespace "
+ namespace import ::huddle::wrap ::huddle::unwrap ::huddle::isHuddle ::huddle::strip_node ::huddle::are_equal_nodes ::huddle::argument_to_node ::huddle::get_src
+
+ namespace ensemble create -unknown ::huddle::unknown_subcommand -command $typeCommand -prefixes false -map {$ensemble_map_of_type}
+
+ proc settings {} {
+ variable settings
+ return \$settings
+ }
+ "
+
+ set huddle_map [namespace ensemble configure ::huddle -map]
+
+ dict with settings {
+ foreach subcommand $publicMethods {
+ dict set huddle_map $subcommand [list $typeCommand $subcommand]
+ }
+
+ if {[info exists superclass]} {
+ set types(superclass:$tag) $superclass
+ }
+
+ set types(type:$tag) $typeName
+ set types(callback:$tag) $typeCommand
+ set types(isContainer:$tag) $isContainer
+ set types(tagOfType:$typeName) $tag
+ }
+
+ namespace ensemble configure ::huddle -map $huddle_map
+ return
+}
+
+proc ::huddle::is_superclass_of {tag1 tag2} {
+ variable types
+
+ if {![info exists types(list_of_superclasses:$tag1)]} {
+ set types(list_of_superclasses:$tag1) [list]
+
+ set superclass_tag $tag1
+
+ while {true} {
+ if {[info exists types(superclass:$superclass_tag)]} {
+ set superclass $types(superclass:$superclass_tag)
+ set superclass_tag $types(tagOfType:$superclass)
+
+ lappend types(list_of_superclasses:$tag1) $superclass_tag
+ } else {
+ break
+ }
+ }
+ }
+
+ if {$tag2 in $types(list_of_superclasses:$tag1) } {
+ return 1
+ } else {
+ return 0
+ }
+}
+
+proc ::huddle::unknown_subcommand {ensembleCmd subcommand args} {
+ set settings [$ensembleCmd settings]
+
+ if {[dict exists $settings superclass]} {
+ set superclass [dict get $settings superclass]
+
+ set map [namespace ensemble configure $ensembleCmd -map]
+ dict set map $subcommand [list ::huddle::Type_$superclass $subcommand]
+
+ namespace ensemble configure $ensembleCmd -map $map
+ return ""
+ } else {
+ error "Invalid subcommand '$subcommand' for type '$ensembleCmd'"
+ }
+}
+
+proc ::huddle::isHuddle {obj} {
+ if {[lindex $obj 0] ne "HUDDLE" || [llength $obj] != 2} {
+ return 0
+ }
+
+ variable types
+ set node [lindex $obj 1]
+ set tag [lindex $node 0]
+
+ if { [array get types "type:$tag"] == ""} {
+ return 0
+ }
+
+ return 1
+}
+
+proc ::huddle::strip_node {node} {
+ variable types
+ foreach {head src} $node break
+ if {[info exists types(type:$head)]} {
+ if {$types(isContainer:$head)} {
+ return [$types(callback:$head) strip $src]
+ } else {
+ return $src
+ }
+ } else {
+ error "This head '$head' doesn't exists."
+ }
+}
+
+proc ::huddle::call {tag cmd arguments} {
+ variable types
+ return [$types(callback:$tag) $cmd {*}$arguments]
+}
+
+proc ::huddle::combine {args} {
+ variable types
+
+ foreach {obj} $args {
+ checkHuddle $obj
+ }
+
+ set first_object [lindex $args 0]
+ set tag_of_group [lindex [unwrap $first_object] 0]
+
+ foreach {obj} $args {
+ set node [unwrap $obj]
+
+ foreach {tag src} $node break
+
+ if {$tag_of_group ne $tag} {
+ if {[is_superclass_of $tag $tag_of_group]} {
+ set tag_of_group $tag
+ } else {
+ if {![is_superclass_of $tag_of_group $tag]} {
+ error "unmatched types are given or one type is not a superclass of the other."
+ }
+ }
+ }
+
+ lappend result {*}$src
+ }
+
+ set src [$types(callback:$tag_of_group) append_subnodes "" {} $result]
+ return [wrap [list $tag $src]]
+}
+
+proc ::huddle::checkHuddle {huddle_object} {
+ if {![isHuddle $huddle_object]} {
+ error "\{$huddle_object\} is not a huddle."
+ }
+}
+
+proc ::huddle::argument_to_node {src {default_tag s}} {
+ if {[isHuddle $src]} {
+ return [unwrap $src]
+ } else {
+ return [list $default_tag $src]
+ }
+}
+
+proc ::huddle::wrap { node } {
+ return [list HUDDLE $node]
+}
+
+proc ::huddle::unwrap { huddle_object } {
+ return [lindex $huddle_object 1]
+}
+
+proc ::huddle::get_src { huddle_object } {
+ return [lindex [unwrap $huddle_object] 1]
+}
+
+proc ::huddle::Get {huddle_object args} {
+ return [retrieve_huddle $huddle_object $args 0]
+}
+
+proc ::huddle::get_stripped {huddle_object args} {
+ return [retrieve_huddle $huddle_object $args 1]
+}
+
+proc ::huddle::retrieve_huddle {huddle_object path stripped} {
+ checkHuddle $huddle_object
+
+ set target_node [Find_node [unwrap $huddle_object] $path]
+
+ if {$stripped} {
+ return [strip_node $target_node]
+ } else {
+ return [wrap $target_node]
+ }
+}
+
+proc ::huddle::type {huddle_object args} {
+ variable types
+
+ checkHuddle $huddle_object
+
+ set target_node [Find_node [unwrap $huddle_object] $args]
+
+ foreach {tag src} $target_node break
+
+ return $types(type:$tag)
+}
+
+proc ::huddle::Find_node {node path} {
+ variable types
+
+ set subnode $node
+
+ foreach subpath $path {
+ foreach {tag src} $subnode break
+ set subnode [$types(callback:$tag) get_subnode $src $subpath]
+ }
+
+ return $subnode
+}
+
+proc ::huddle::exists {huddle_object args} {
+ variable types
+
+ checkHuddle $huddle_object
+
+ set subnode [unwrap $huddle_object]
+
+ foreach key $args {
+ foreach {tag src} $subnode break
+ if {$types(isContainer:$tag) && [$types(callback:$tag) exists $src $key] } {
+ set subnode [$types(callback:$tag) get_subnode $src $key]
+ } else {
+ return 0
+ }
+ }
+
+ return 1
+}
+
+proc ::huddle::equal {obj1 obj2} {
+ checkHuddle $obj1
+ checkHuddle $obj2
+ return [::huddle::are_equal_nodes [unwrap $obj1] [unwrap $obj2]]
+}
+
+proc ::huddle::are_equal_nodes {node1 node2} {
+ variable types
+
+ foreach {tag1 src1} $node1 break
+ foreach {tag2 src2} $node2 break
+ if {$tag1 ne $tag2} {return 0}
+ return [$types(callback:$tag1) equal $src1 $src2]
+}
+
+proc ::huddle::Append {objvar args} {
+ variable types
+ upvar 1 $objvar obj
+
+ checkHuddle $obj
+
+ foreach {tag src} [unwrap $obj] break
+ set src [$types(callback:$tag) append_subnodes $tag $src $args]
+ set obj [wrap [list $tag $src]]
+ return $obj
+}
+
+proc ::huddle::Set {objvar args} {
+ upvar 1 $objvar obj
+
+ checkHuddle $obj
+ set path [lrange $args 0 end-1]
+
+ set new_subnode [argument_to_node [lindex $args end]]
+
+ set root_node [unwrap $obj]
+
+ # We delete the internal reference of $obj to $root_node
+ # Now refcount of $root_node is 1
+ unset obj
+
+ Apply_to_subnode set root_node [llength $path] $path $new_subnode
+ set obj [wrap $root_node]
+}
+
+proc ::huddle::remove {obj args} {
+ checkHuddle $obj
+
+ set modified_node [remove_node [unwrap $obj] [llength $args] $args]
+
+ set obj [wrap $modified_node]
+}
+
+proc ::huddle::remove_node {node len path} {
+ variable types
+
+ foreach {tag src} $node break
+
+ set first_key_to_removed_subnode [lindex $path 0]
+
+ if {$len > 1} {
+ if { $types(isContainer:$tag) } {
+
+ set subpath_to_removed_subnode [lrange $path 1 end]
+
+ incr len -1
+
+ set new_src ""
+
+ foreach item [$types(callback:$tag) items $src] {
+ foreach {key subnode} $item break
+ if {$key eq $first_key_to_removed_subnode} {
+ set modified_subnode [::huddle::remove_node $subnode $len $subpath_to_removed_subnode]
+ $types(callback:$tag) set new_src $key $modified_subnode
+ } else {
+ set cloned_subnode [Clone_node $subnode]
+ $types(callback:$tag) set new_src $key $cloned_subnode
+ }
+ }
+
+ return [list $tag $new_src]
+ } else {
+ error "\{$src\} don't have any child node."
+ }
+ } else {
+ $types(callback:$tag) remove src $first_key_to_removed_subnode
+ return [list $tag $src]
+ }
+}
+
+proc ::huddle::Unset {objvar args} {
+ upvar 1 $objvar obj
+ checkHuddle $obj
+
+ set root_node [unwrap $obj]
+
+ # We delete the internal reference of $obj to $root_node
+ # Now refcount of $root_node is 1
+ unset obj
+
+ Apply_to_subnode remove root_node [llength $args] $args
+
+ set obj [wrap $root_node]
+}
+
+proc ::huddle::clone {obj} {
+ set cloned_node [Clone_node [unwrap $obj]]
+
+ return [wrap $cloned_node]
+}
+
+proc ::huddle::Clone_node {node} {
+ variable types
+
+ foreach {tag src} $node break
+
+ if { $types(isContainer:$tag) } {
+ set cloned_src ""
+
+ foreach item [$types(callback:$tag) items $src] {
+ foreach {key subnode} $item break
+ set cloned_subnode [Clone_node $subnode]
+ $types(callback:$tag) set cloned_src $key $cloned_subnode
+ }
+ return [list $tag $cloned_src]
+ } else {
+ return $node
+ }
+}
+
+proc ::huddle::Apply_to_subnode {subcommand node_var len path {subcommand_arguments ""}} {
+ variable types
+ upvar 1 $node_var node
+
+ foreach {tag src} $node break
+
+ # We delete $src from $node.
+ # In that position there is only an empty string.
+ # This way, the refcount of $src is 1
+ lset node 1 ""
+
+ # We get the fist key. This information is used in the recursive case ($len>1) and in the base case ($len==1).
+ set key [lindex $path 0]
+
+ if {$len > 1} {
+
+ set subpath [lrange $path 1 end]
+
+ incr len -1
+
+ if { $types(isContainer:$tag) } {
+
+ set subnode [$types(callback:$tag) get_subnode $src $key]
+
+ # We delete the internal reference of $src to $subnode.
+ # Now refcount of $subnode is 1
+ $types(callback:$tag) delete_subnode_but_not_key src $key
+
+ ::huddle::Apply_to_subnode $subcommand subnode $len $subpath $subcommand_arguments
+
+ # We add again the new $subnode to the original $src
+ $types(callback:$tag) set src $key $subnode
+
+ # We add again the new $src to the parent node
+ lset node 1 $src
+
+ } else {
+ error "\{$src\} don't have any child node."
+ }
+ } else {
+ if {![info exists types(type:$tag)]} {error "\{$src\} is not a huddle node."}
+
+ $types(callback:$tag) $subcommand src $key $subcommand_arguments
+ lset node 1 $src
+ }
+}
+
+proc ::huddle::jsondump {huddle_object {offset " "} {newline "\n"} {begin ""}} {
+ variable types
+ set nextoff "$begin$offset"
+ set nlof "$newline$nextoff"
+ set sp " "
+ if {[string equal $offset ""]} {set sp ""}
+
+ set type [huddle type $huddle_object]
+
+ switch -- $type {
+ boolean -
+ number -
+ null {
+ return [huddle get_stripped $huddle_object]
+ }
+
+ string {
+ set data [huddle get_stripped $huddle_object]
+
+ # JSON permits only oneline string
+ set data [string map {
+ \n \\n
+ \t \\t
+ \r \\r
+ \b \\b
+ \f \\f
+ \\ \\\\
+ \" \\\"
+ / \\/
+ } $data
+ ]
+ return "\"$data\""
+ }
+
+ list {
+ set inner {}
+ set len [huddle llength $huddle_object]
+ for {set i 0} {$i < $len} {incr i} {
+ set subobject [huddle get $huddle_object $i]
+ lappend inner [jsondump $subobject $offset $newline $nextoff]
+ }
+ if {[llength $inner] == 1} {
+ return "\[[lindex $inner 0]\]"
+ }
+
+ return "\[$nlof[join $inner ,$nlof]$newline$begin\]"
+ }
+
+ dict {
+ set inner {}
+ foreach {key} [huddle keys $huddle_object] {
+ lappend inner [subst {"$key":$sp[jsondump [huddle get $huddle_object $key] $offset $newline $nextoff]}]
+ }
+ if {[llength $inner] == 1} {
+ return $inner
+ }
+ return "\{$nlof[join $inner ,$nlof]$newline$begin\}"
+ }
+
+ default {
+ return [$types(callback:$type) jsondump $data $offset $newline $nextoff]
+ }
+ }
+}
+
+# data is plain old tcl values
+# spec is defined as follows:
+# {string} - data is simply a string, "quote" it if it's not a number
+# {list} - data is a tcl list of strings, convert to JSON arrays
+# {list list} - data is a tcl list of lists
+# {list dict} - data is a tcl list of dicts
+# {dict} - data is a tcl dict of strings
+# {dict xx list} - data is a tcl dict where the value of key xx is a tcl list
+# {dict * list} - data is a tcl dict of lists
+# etc..
+
+proc ::huddle::compile {spec data} {
+ while {[llength $spec]} {
+ set type [lindex $spec 0]
+ set spec [lrange $spec 1 end]
+
+ switch -- $type {
+ dict {
+ if {![llength $spec]} {
+ lappend spec * string
+ }
+
+ set result [huddle create]
+ foreach {key value} $data {
+ foreach {matching_key subspec} $spec {
+ if {[string match $matching_key $key]} {
+ Append result $key [compile $subspec $value]
+ break
+ }
+ }
+ }
+
+ return $result
+ }
+
+ list {
+ if {![llength $spec]} {
+ set spec string
+ } else {
+ set spec [lindex $spec 0]
+ }
+
+ set result [huddle list]
+ foreach list_item $data {
+ Append result [compile $spec $list_item]
+ }
+
+ return $result
+ }
+
+ string {
+ return [wrap [list s $data]]
+ }
+
+ number {
+ if {[string is double -strict $data]} {
+ return [wrap [list num $data]]
+ } else {
+ error "Bad number: $data"
+ }
+ }
+
+ bool {
+ if {$data} {
+ return [wrap [list bool true]]
+ } else {
+ return [wrap [list bool false]]
+ }
+ }
+
+ null {
+ if {$data eq ""} {
+ return [wrap [list null]]
+ } else {
+ error "Data must be an empty string: '$data'"
+ }
+ }
+
+ huddle {
+ if {[isHuddle $data]} {
+ return $data
+ } else {
+ error "Data is not a huddle object: $data"
+ }
+ }
+
+ default {error "Invalid type: '$type'"}
+ }
+ }
+}
+
+apply {{selfdir} {
+ source [file join $selfdir huddle_types.tcl]
+
+ foreach typeNamespace [namespace children ::huddle::types] {
+ addType $typeNamespace
+ }
+
+ return
+} ::huddle} [file dirname [file normalize [info script]]]
+return
diff --git a/tcllib/modules/yaml/huddle.test b/tcllib/modules/yaml/huddle.test
new file mode 100755
index 0000000..d5ef135
--- /dev/null
+++ b/tcllib/modules/yaml/huddle.test
@@ -0,0 +1,363 @@
+# -*- tcl -*-
+# huddle.test: tests for the huddle library.
+#
+# Copyright (c) 2008 by KATO Kanryu <kanryu6@users.sourceforge.net>
+# All rights reserved.
+#
+
+if {[lsearch [namespace children] ::tcltest] == -1} {
+ # single test
+ set selfrun 1
+ lappend auto_path [pwd]
+ package require tcltest
+ namespace import ::tcltest::*
+
+ source huddle.tcl
+ package require json
+
+ proc dictsort {dict} {
+ array set a $dict
+ set out [list]
+ foreach key [lsort [array names a]] {
+ lappend out $key $a($key)
+ }
+ return $out
+ }
+} else {
+ # all.tcl
+ source [file join \
+ [file dirname [file dirname [file join [pwd] [info script]]]] \
+ devtools testutilities.tcl]
+
+ testsNeedTcl 8.5
+ testsNeedTcltest 2
+ #testsNeed dict 1
+
+ support {
+ use json/json.tcl json
+ }
+ testing {
+ useLocal huddle.tcl huddle
+ }
+}
+
+test huddle-1.1 "test of huddle create" -body {
+ set upper [huddle create a b c d]
+} -result {HUDDLE {D {a {s b} c {s d}}}}
+
+test huddle-1.2 "test of huddle create" -body {
+ set upper2 [huddle create e f g h]
+ set upper3 [huddle create i j k l]
+ set folding [huddle create bb $upper cc $upper2]
+} -result {HUDDLE {D {bb {D {a {s b} c {s d}}} cc {D {e {s f} g {s h}}}}}}
+
+test huddle-1.3 "test of huddle create" -body {
+ set folding [huddle create dd $folding ee $upper3]
+ set data_dict $folding
+} -result {HUDDLE {D {dd {D {bb {D {a {s b} c {s d}}} cc {D {e {s f} g {s h}}}}} ee {D {i {s j} k {s l}}}}}}
+
+test huddle-1.4 "test of huddle create" -body {
+ huddle get $folding dd
+} -result {HUDDLE {D {bb {D {a {s b} c {s d}}} cc {D {e {s f} g {s h}}}}}}
+
+test huddle-1.5 "test of huddle create" -body {
+ huddle get $folding dd cc
+} -result {HUDDLE {D {e {s f} g {s h}}}}
+
+test huddle-1.6 "test of huddle create" -body {
+ huddle get_stripped $folding dd
+} -result {bb {a b c d} cc {e f g h}}
+
+test huddle-1.7 "test of huddle create" -body {
+ huddle get_stripped $folding dd cc
+} -result {e f g h}
+
+test huddle-1.8 "test of huddle create" -body {
+ huddle type $folding dd
+} -result {dict}
+
+test huddle-1.9 "test of huddle create" -body {
+ huddle type $folding dd cc
+} -result {dict}
+
+test huddle-1.10 "test of huddle create" -body {
+ huddle type $folding dd cc g
+} -result {string}
+
+test huddle-2.1 "test of huddle list" -body {
+ set upper [huddle list a b c d]
+} -result {HUDDLE {L {{s a} {s b} {s c} {s d}}}}
+
+test huddle-2.2 "test of huddle list" -body {
+ set upper2 [huddle list e f g h]
+ set folding [huddle list i $upper j k $upper2]
+} -result {HUDDLE {L {{s i} {L {{s a} {s b} {s c} {s d}}} {s j} {s k} {L {{s e} {s f} {s g} {s h}}}}}}
+
+test huddle-2.3 "test of huddle list" -body {
+ set folding [huddle list $folding t u]
+ set data_list $folding
+} -result {HUDDLE {L {{L {{s i} {L {{s a} {s b} {s c} {s d}}} {s j} {s k} {L {{s e} {s f} {s g} {s h}}}}} {s t} {s u}}}}
+
+test huddle-2.4 "test of huddle list" -body {
+ huddle get $folding 0
+} -result {HUDDLE {L {{s i} {L {{s a} {s b} {s c} {s d}}} {s j} {s k} {L {{s e} {s f} {s g} {s h}}}}}}
+
+test huddle-2.5 "test of huddle list" -body {
+ huddle get $folding 0 1
+} -result {HUDDLE {L {{s a} {s b} {s c} {s d}}}}
+
+test huddle-2.6 "test of huddle list" -body {
+ huddle get_stripped $folding 0
+} -result {i {a b c d} j k {e f g h}}
+
+test huddle-2.7 "test of huddle list" -body {
+ huddle get_stripped $folding 0 1
+} -result {a b c d}
+
+test huddle-2.8 "test of huddle list" -body {
+ huddle type $folding 0
+} -result {list}
+
+test huddle-2.9 "test of huddle list" -body {
+ huddle type $folding 0 1
+} -result {list}
+
+test huddle-2.10 "test of huddle list" -body {
+ huddle type $folding 0 1 3
+} -result {string}
+
+test huddle-2.11 "test of huddle list" -body {
+ huddle get_stripped {HUDDLE {L {{s a} {L {}} {s c}}}}
+} -result {a {} c}
+
+#test huddle-3.1 "test of huddle jsondump" {[info tclversion] >= 8.5} {
+# # build a huddle container from normal tcl's container(multi rank dict/list)
+# proc huddle_build {data} {
+# foreach {key val} $data {
+# if {$key eq "layers"} {
+# foreach {l} [dict get $data layers] {
+# lappend subs [huddle_build $l]
+# }
+# set val [eval huddle list $subs]
+# }
+# lappend result $key $val
+# }
+# return [eval huddle create $result]
+# }
+# set fd [open [file join [file dirname [info script]] layers.txt] r]
+# set json1 [read $fd]
+# close $fd
+#
+# set data [json::json2dict $json1]
+## set data [huddle_build $data]
+##
+## set json2 [huddle jsondump $data]
+## expr $json1 eq $json2
+## set json2
+#} {1}
+
+test huddle-3.2 "test of huddle jsondump" -body {
+ huddle jsondump {HUDDLE {L {{L {{s i} {s baa} {s k} {L {{num 1.0} {b true} {s g} {s h}}}}} {s t}}}}
+} -result {[
+ [
+ "i",
+ "baa",
+ "k",
+ [
+ 1.0,
+ true,
+ "g",
+ "h"
+ ]
+ ],
+ "t"
+]}
+
+
+test huddle-3.3 "test of huddle jsondump" -body {
+ set huddle1 {HUDDLE {D {dd {D {bb {D {a {s baa} c {s {d a}}}} cc {D {g {s h}}}}} ee {D {i {s j} k {num 1} j {s { m\a}}}}}}}
+ set json1 [huddle jsondump $huddle1]
+ set json2 {{
+ "dd": {
+ "bb": {
+ "a": "baa",
+ "c": "d a"
+ },
+ "cc": {"g": "h"}
+ },
+ "ee": {
+ "i": "j",
+ "k": 1,
+ "j": " m\\a"
+ }
+}}
+
+ if {$json1 == $json2} {
+ return 1
+ } else {
+ return 0
+ }
+} -result {1}
+
+
+test huddle-3.4 "test of huddle compile" -body {
+ set huddle1 {HUDDLE {D {dd {D {bb {D {a {s baa} c {s {d a}}}} cc {D {g {s h}}}}} ee {D {i {s j} k {num 1} j {s { m\a}}}}}}}
+ set json1 {{
+ "dd": {
+ "bb": {
+ "a": "baa",
+ "c": "d a"
+ },
+ "cc": {"g": "h"}
+ },
+ "ee": {
+ "i": "j",
+ "k": 1,
+ "j": " m\\a"
+ }
+}}
+
+ set data [json::json2dict $json1]
+ set data [huddle compile {dict dd {dict * dict} ee {dict k number * string}} $data]
+ huddle equal $huddle1 $data
+} -result {1}
+
+# ... Tests of addStrings ...
+# (Requires introspection of parser state)
+
+test huddle-4.1 "test of huddle set" -body {
+ huddle set data_dict dd bb a baa
+} -result {HUDDLE {D {dd {D {bb {D {a {s baa} c {s d}}} cc {D {e {s f} g {s h}}}}} ee {D {i {s j} k {s l}}}}}}
+
+test huddle-4.2 "test of huddle remove" -body {
+ set data_dict [huddle remove $data_dict dd cc e]
+} -result {HUDDLE {D {dd {D {bb {D {a {s baa} c {s d}}} cc {D {g {s h}}}}} ee {D {i {s j} k {s l}}}}}}
+
+test huddle-4.3 "test of huddle set" -body {
+ huddle set data_list 0 1 baa
+} -result {HUDDLE {L {{L {{s i} {s baa} {s j} {s k} {L {{s e} {s f} {s g} {s h}}}}} {s t} {s u}}}}
+
+test huddle-4.4 "test of huddle remove" -body {
+ set data_list [huddle remove $data_list 0 2]
+} -result {HUDDLE {L {{L {{s i} {s baa} {s k} {L {{s e} {s f} {s g} {s h}}}}} {s t} {s u}}}}
+
+test huddle-4.5 "test of huddle equal" -body {
+ huddle equal $data_dict {HUDDLE {D {dd {D {bb {D {a {s baa} c {s d}}} cc {D {g {s h}}}}} ee {D {i {s j} k {s l}}}}}}
+} -result 1
+
+test huddle-4.6 "test of huddle equal" -body {
+ huddle equal $data_dict {HUDDLE {D {dd {D {bb {D {a {s lll} c {s d}}} cc {D {g {s h}}}}} ee {D {i {s j} k {s l}}}}}}
+} -result 0
+
+test huddle-4.7 "test of huddle equal" -body {
+ huddle equal $data_dict {HUDDLE {D {dd {D {bb {D {a {s baa} c {s d}}} cc {D {g {s h}}}}} ee {D {i {s j} k {s l} j {s m}}}}}}
+} -result 0
+
+test huddle-4.8 "test of huddle equal" -body {
+ huddle equal $data_list {HUDDLE {L {{L {{s i} {s baa} {s k} {L {{s e} {s f} {s g} {s h}}}}} {s t} {s u}}}}
+} -result 1
+
+test huddle-4.9 "test of huddle equal" -body {
+ huddle equal $data_list {HUDDLE {L {{L {{s i} {s kkk} {s k} {L {{s e} {s f} {s g} {s h}}}}} {s t} {s u}}}}
+} -result 0
+
+test huddle-4.10 "test of huddle equal" -body {
+ huddle equal $data_list {HUDDLE {L {{L {{s i} {s baa} {s k} {L {{s e} {s f} {s g} {s h}}}}} {s t}}}}
+} -result 0
+
+test huddle-5.1 "test of huddle boolean" -body {
+ huddle true
+} -result {HUDDLE {b true}}
+
+test huddle-5.2 "test of huddle boolean" -body {
+ huddle false
+} -result {HUDDLE {b false}}
+
+test huddle-6.1 "test of huddle null" -body {
+ huddle null
+} -result {HUDDLE null}
+
+test huddle-7.1 "test of huddle number" -body {
+ huddle number -4.5E-6
+} -result {HUDDLE {num -4.5E-6}}
+
+
+test huddle-8.1 "test of complex data structure using the new types: number, boolean and null" -body {
+ huddle create key1 var1 key2 [huddle number 4] key3 [huddle list [huddle null] sadf [huddle true]]
+} -result {HUDDLE {D {key1 {s var1} key2 {num 4} key3 {L {null {s sadf} {b true}}}}}}
+
+
+test huddle-9.1 "test of huddle exists" -body {
+ set obj [huddle list [huddle create key1 2 key3 4] 1 2 [huddle list 1 2 [huddle list 1 2]] ]
+ huddle exists $obj 0 key1
+} -result {1}
+
+test huddle-9.2 "test of huddle exists" -body {
+ set obj [huddle list [huddle create key1 2 key3 4] 1 2 [huddle list 1 2 [huddle list 1 2]] ]
+ huddle exists $obj 3 2 1
+} -result {1}
+
+test huddle-9.1 "test of huddle exists" -body {
+ set obj [huddle list [huddle create key1 2 key3 4] 1 2 [huddle list 1 2 [huddle list 1 2]] ]
+ huddle exists $obj 0 key1
+} -result {1}
+
+test huddle-9.3 "test of huddle exists" -body {
+ set obj [huddle list [huddle create key1 2 key3 4] 1 2 [huddle list 1 2 [huddle list 1 2]] ]
+ huddle exists $obj 3 3 1
+} -result {0}
+
+test huddle-10.1 "test of huddle clone" -body {
+ set obj [huddle list item0 item1 [huddle create key0 value0 key1 value1]]
+ huddle clone $obj
+} -result {HUDDLE {L {{s item0} {s item1} {D {key0 {s value0} key1 {s value1}}}}}}
+
+
+test huddle-11.1 "test of huddle superclass" -body {
+
+ namespace eval ::new_types::mapping {
+
+ variable settings
+ set settings {
+ superclass dict
+ publicMethods {mapping}
+ tag !!map
+ isContainer yes }
+
+ proc mapping {args} {
+ if {[llength $args] % 2} {error {wrong # args: should be "huddle mapping ?key value ...?"}}
+ set resultL {}
+ foreach {key value} $args {
+ lappend resultL $key [argument_to_node $value !!str]
+ }
+
+ return [wrap [list !!map $resultL]]
+ }
+
+ }
+
+ namespace eval ::new_types::str {
+
+ variable settings
+ set settings {
+ superclass string
+ publicMethods {}
+ isContainer no
+ tag !!str
+ }
+ }
+
+ huddle addType ::new_types::mapping
+ huddle addType ::new_types::str
+
+ set a [huddle mapping key1 var1]
+ huddle append a key2 [huddle mapping key3 var3]
+} -result {HUDDLE {!!map {key1 {!!str var1} key2 {!!map {key3 {!!str var3}}}}}}
+
+
+
+if {[info exists selfrun]} {
+ tcltest::cleanupTests
+} else {
+ testsuiteCleanup
+}
diff --git a/tcllib/modules/yaml/huddle_types.tcl b/tcllib/modules/yaml/huddle_types.tcl
new file mode 100644
index 0000000..3fd23a3
--- /dev/null
+++ b/tcllib/modules/yaml/huddle_types.tcl
@@ -0,0 +1,296 @@
+namespace eval ::huddle::types {
+ namespace export *
+
+ namespace eval dict {
+ variable settings
+
+ # type definition
+ set settings {
+ publicMethods {create keys}
+ tag D
+ isContainer yes
+ map {set Set} }
+
+
+ proc get_subnode {src key} {
+ # get a sub-node specified by "key" from the tagged-content
+ return [dict get $src $key]
+ }
+
+ # strip from the tagged-content
+ proc strip {src} {
+ foreach {key subnode} $src {
+ lappend result $key [strip_node $subnode]
+ }
+ return $result
+ }
+
+ # set a sub-node from the tagged-content
+ proc Set {src_var key value} {
+ upvar 1 $src_var src
+
+ ::dict set src $key $value
+ }
+
+ proc items {src} {
+ set result {}
+ dict for {key subnode} $src {
+ lappend result [list $key $subnode]
+ }
+ return $result
+ }
+
+
+ # remove a sub-node from the tagged-content
+ proc remove {src_var key} {
+ upvar 1 $src_var src
+ dict unset src $key
+ }
+
+
+ proc delete_subnode_but_not_key {src_var key} {
+ upvar 1 $src_var src
+ return [dict set src $key ""]
+ }
+
+ # check equal for each node
+ proc equal {src1 src2} {
+ if {[llength $src1] != [llength $src2]} {return 0}
+ foreach {key1 subnode1} $src1 {
+ if {![dict exists $src2 $key1]} {return 0}
+ if {![are_equal_nodes $subnode1 [dict get $src2 $key1]]} {return 0}
+ }
+ return 1
+ }
+
+ proc append_subnodes {tag src list} {
+ if {[llength $list] % 2} {error {wrong # args: should be "huddle append objvar ?key value ...?"}}
+ set resultL $src
+ foreach {key value} $list {
+ if {$tag ne ""} {
+ lappend resultL $key [argument_to_node $value $tag]
+ } else {
+ lappend resultL $key $value
+ }
+ }
+ return [dict create {*}$resultL]
+ }
+
+ # $args: all arguments after "huddle create"
+ proc create {args} {
+ if {[llength $args] % 2} {error {wrong # args: should be "huddle create ?key value ...?"}}
+ set resultL [dict create]
+
+ foreach {key value} $args {
+ if {[isHuddle $key]} {
+ foreach {tag src} [unwrap $key] break
+ if {$tag ne "string"} {error "The key '$key' must a string literal or huddle string" }
+ set key $src
+ }
+ dict set resultL $key [argument_to_node $value]
+ }
+ return [wrap [list D $resultL]]
+ }
+
+ proc keys {huddle_object} {
+ return [dict keys [get_src $huddle_object]]
+ }
+
+ proc exists {src key} {
+ return [dict exists $src $key]
+ }
+ }
+
+
+ namespace eval list {
+ variable settings
+
+ # type definition
+ set settings {
+ publicMethods {list llength}
+ tag L
+ isContainer yes
+ map {list List set Set llength Llength} }
+
+ proc get_subnode {src index} {
+ return [lindex $src $index]
+ }
+
+ proc items {src} {
+ set result {}
+ for {set i 0} {$i < [llength $src]} {incr i} {
+ lappend result [list $i [lindex $src $i]]
+ }
+ return $result
+ }
+
+ proc strip {src} {
+ set result {}
+ foreach {subnode} $src {
+ lappend result [strip_node $subnode]
+ }
+ return $result
+ }
+
+ if {[package vcompare [package present Tcl] 8.6] > 0} {
+ proc Set {src_var index value} {
+ upvar 1 $src_var src
+ lset src $index $value
+ }
+ } else {
+ proc Set {src_var index value} {
+ upvar 1 $src_var src
+ # Manual handling of lset at end of list.
+ if {$index == [llength $src]} {
+ lappend src $value
+ } else {
+ lset src $index $value
+ }
+ }
+ }
+
+ proc remove {src_var index} {
+ upvar 1 $src_var src
+ set src [lreplace $src $index $index]
+ }
+
+
+ proc delete_subnode_but_not_key {src_var index} {
+ upvar 1 $src_var src
+ return [lset src $index ""]
+ }
+
+ proc equal {src1 src2} {
+ if {[llength $src1] != [llength $src2]} {return 0}
+
+ for {set i 0} {$i < [llength $src1]} {incr i} {
+ if {![are_equal_nodes [lindex $src1 $i] [lindex $src2 $i]]} {
+ return 0
+ }
+ }
+
+ return 1
+ }
+
+ proc append_subnodes {tag src list} {
+ set resultL $src
+ foreach {value} $list {
+ if {$tag ne ""} {
+ lappend resultL [argument_to_node $value $tag]
+ } else {
+ lappend resultL $value
+ }
+ }
+ return $resultL
+ }
+
+ proc List {args} {
+
+ set resultL {}
+ foreach {value} $args {
+ lappend resultL [argument_to_node $value]
+ }
+ return [wrap [list L $resultL]]
+ }
+
+ proc Llength {huddle_object} {
+ return [llength [get_src $huddle_object] ]
+ }
+
+ proc exists {src key} {
+ return [expr {$key >=0 && $key < [llength $src]}]
+ }
+ }
+
+ namespace eval string {
+ variable settings
+
+ # type definition
+ set settings {
+ publicMethods {string}
+ tag s
+ isContainer no
+ map {string String} }
+
+ proc String {src} {
+ return [wrap [list s $src]]
+ }
+
+ proc equal {string1 string2} {
+ return [expr {$string1 eq $string2}]
+ }
+ }
+
+
+ namespace eval number {
+ variable settings
+
+ # type definition
+ set settings {
+ publicMethods {number}
+ tag num
+ isContainer no }
+
+ proc number {src} {
+ if {[string is double -strict $src]} {
+ return [wrap [list num $src]]
+ } else {
+ error "Argument '$src' is not a number"
+ }
+ }
+
+ proc equal {number1 number2} {
+ return [expr {$number1 == $number2}]
+ }
+ }
+
+ namespace eval boolean {
+ variable settings
+
+ # type definition
+ set settings {
+ publicMethods {boolean true false}
+ tag b
+ isContainer no }
+
+ proc boolean {boolean_expresion} {
+
+ if {$boolean_expresion} {
+ return [wrap [list b true]]
+ } else {
+ return [wrap [list b false]]
+ }
+ }
+
+ proc true {} {
+ return [::huddle::wrap [list b true]]
+ }
+
+ proc false {} {
+ return [wrap [list b false]]
+ }
+
+
+ proc equal {bool1 bool2} {
+ return [expr {$bool1 eq $bool2}]
+ }
+ }
+
+ namespace eval null {
+ variable settings
+
+ # type definition
+ set settings {
+ publicMethods {null}
+ tag null
+ isContainer no }
+
+ proc null {} {
+ return [wrap [list null]]
+ }
+
+ proc equal {null1 null2} {
+ return 1
+ }
+ }
+}
diff --git a/tcllib/modules/yaml/json2huddle.tcl b/tcllib/modules/yaml/json2huddle.tcl
new file mode 100644
index 0000000..111c36d
--- /dev/null
+++ b/tcllib/modules/yaml/json2huddle.tcl
@@ -0,0 +1,389 @@
+# -*- tcl -*-
+# (c) 2015 Miguel Martínez López
+
+package require Tcl 8.5
+package require TclOO ; # For 8.5. Integrated with 8.6
+package require try ; # For 8.5. Integrated with 8.6. Tcllib.
+package require huddle 0.1.7
+
+package provide huddle::json 0.1
+
+
+namespace eval ::huddle {
+ namespace export json2huddle
+
+ proc json2huddle {jsonText} {
+ set huddle_object [::huddle::json::json2huddle parse $jsonText]
+ return $huddle_object
+ }
+}
+
+
+namespace eval ::huddle::json {
+
+ oo::class create Json2huddle {
+
+ variable cursor jsonText EndOfTextException numberRE
+
+ constructor {} {
+
+ if {[package vcompare [package present Tcl] 8.6] == 0} {
+ proc throw {code msg} {
+ return -code error -errorcode $code $msg
+ }
+ }
+
+ set positiveRE {[1-9][[:digit:]]*}
+ set cardinalRE "-?(?:$positiveRE|0)"
+ set fractionRE {[.][[:digit:]]+}
+ set exponentialRE {[eE][+-]?[[:digit:]]+}
+ set numberRE "${cardinalRE}(?:$fractionRE)?(?:$exponentialRE)?"
+
+ # Exception code for "End of Text" signal
+ set EndOfTextException 5
+ }
+
+ method parse {json_to_parse} {
+ set cursor -1
+ set jsonText $json_to_parse
+
+ my parse_next_json_data
+ }
+
+ method peekChar { {increment 1} } {
+ return [string index $jsonText [expr {$cursor+$increment}]]
+ }
+
+ method advanceCursor { {increment 1} } {
+ incr cursor $increment
+ }
+
+ method nextChar {} {
+ if {$cursor + 1 < [string length $jsonText] } {
+ incr cursor
+ return [string index $jsonText $cursor]
+ } else {
+ return -code $EndOfTextException
+ }
+ }
+
+ method assertNext {ch {target ""}} {
+ incr cursor
+
+ if {[string index $jsonText $cursor] != $ch} {
+ if {$target == ""} {
+ set target $ch
+ }
+ throw {HUDDLE JSONparser} "Trying to read the string $target at index $cursor."
+ }
+ }
+
+
+ method parse_next_json_data {} {
+
+ my eatWhitespace
+
+ set ch [my peekChar]
+
+ if {$ch eq ""} {
+ throw {HUDDLE JSONparser} {Nothing to read}
+ }
+
+
+ switch -exact -- $ch {
+ "\{" {
+ return [my readObject]
+ }
+ "\[" {
+ return [my readArray]
+ }
+ "\"" {
+ return [my readString]
+ }
+
+ "t" {
+ return [my readTrue]
+ }
+ "f" {
+ return [my readFalse]
+ }
+ "n" {
+ return [my readNull]
+ }
+ "/" {
+ my readComment
+ return [my parse_next_json_data]
+ }
+ "-" -
+ "0" -
+ "1" -
+ "2" -
+ "3" -
+ "4" -
+ "5" -
+ "6" -
+ "7" -
+ "8" -
+ "9" {
+ return [my readNumber]
+ }
+ default {
+ throw {HUDDLE JSONparser} "Input is not valid JSON: '$jsonText'"
+ }
+ }
+ }
+
+ method eatWhitespace {} {
+
+ while {true} {
+ set ch [my peekChar]
+
+ if {[string is space -strict $ch]} {
+ my advanceCursor
+ } elseif {$ch eq "/"} {
+ my readComment
+ } else {
+ break
+ }
+ }
+ }
+
+
+ method readTrue {} {
+ my assertNext t true
+ my assertNext r true
+ my assertNext u true
+ my assertNext e true
+ return [::huddle true]
+ }
+
+
+ method readFalse {} {
+ my assertNext f false
+ my assertNext a false
+ my assertNext l false
+ my assertNext s false
+ my assertNext e false
+ return [::huddle false]
+ }
+
+
+ method readNull {} {
+ my assertNext n null
+ my assertNext u null
+ my assertNext l null
+ my assertNext l null
+ return [::huddle null]
+ }
+
+ method readComment {} {
+
+ switch -exact -- [my peekChar 1][my peekChar 2] {
+ "//" {
+ my readDoubleSolidusComment
+ }
+ "/*" {
+ my readCStyleComment
+ }
+ default {
+ throw {HUDDLE JSONparser} "Not a valid JSON comment: $jsonText"
+ }
+ }
+ }
+
+ method readCStyleComment {} {
+ my assertNext "/" "/*"
+ my assertNext "*" "/*"
+
+ try {
+
+ while {true} {
+ set ch [my nextChar]
+
+ switch -exact -- $ch {
+ "*" {
+ if { [my peekChar] eq "/"} {
+ my advanceCursor
+ break
+ }
+ }
+ "/" {
+ if { [my peekChar] eq "*"} {
+ throw {HUDDLE JSONparser} "Not a valid JSON comment: $jsonText, '/*' cannot be embedded in the comment at index $cursor."
+ }
+ }
+
+ }
+ }
+
+ } on $EndOfTextException {} {
+ throw {HUDDLE JSONparser} "not a valid JSON comment: $jsonText, expected */"
+ }
+ }
+
+
+ method readDoubleSolidusComment {} {
+ my assertNext "/" "//"
+ my assertNext "/" "//"
+
+ try {
+ set ch [my nextChar]
+ while { $ch ne "\r" && $ch ne "\n"} {
+ set ch [my nextChar]
+ }
+ } on $EndOfTextException {} {}
+ }
+
+ method readArray {} {
+ my assertNext "\["
+ my eatWhitespace
+
+ if { [my peekChar] eq "\]"} {
+ my advanceCursor
+ return [huddle list]
+ }
+
+ try {
+ while {true} {
+
+ lappend result [my parse_next_json_data]
+
+ my eatWhitespace
+
+ set ch [my nextChar]
+
+ if {$ch eq "\]"} {
+ break
+ } else {
+ if {$ch ne ","} {
+ throw {HUDDLE JSONparser} "Not a valid JSON array: '$jsonText' due to: '$ch' at index $cursor."
+ }
+
+ my eatWhitespace
+ }
+ }
+ } on $EndOfTextException {} {
+ throw {HUDDLE JSONparser} "Not a valid JSON string: '$jsonText'"
+ }
+
+ return [huddle list {*}$result]
+ }
+
+
+
+ method readObject {} {
+
+ my assertNext "\{"
+ my eatWhitespace
+
+ if { [my peekChar] eq "\}"} {
+ my advanceCursor
+ return [huddle create]
+ }
+
+ try {
+ while {true} {
+ set key [my readStringLiteral]
+
+ my eatWhitespace
+
+ set ch [my nextChar]
+
+ if { $ch ne ":"} {
+ throw {HUDDLE JSONparser} "Not a valid JSON object: '$jsonText' due to: '$ch' at index $cursor."
+ }
+
+ my eatWhitespace
+
+ lappend result $key [my parse_next_json_data]
+
+ my eatWhitespace
+
+ set ch [my nextChar]
+
+ if {$ch eq "\}"} {
+ break
+ } else {
+ if {$ch ne ","} {
+ throw {HUDDLE JSONparser} "Not a valid JSON array: '$jsonText' due to: '$ch' at index $cursor."
+ }
+
+ my eatWhitespace
+ }
+ }
+ } on $EndOfTextException {} {
+ throw {HUDDLE JSONparser} "Not a valid JSON string: '$jsonText'"
+ }
+
+ return [huddle create {*}$result]
+ }
+
+
+ method readNumber {} {
+ regexp -start $cursor -- $numberRE $jsonText number
+ my advanceCursor [string length $number]
+
+ return [huddle number $number]
+ }
+
+ method readString {} {
+ set string [my readStringLiteral]
+ return [huddle string $string]
+ }
+
+
+ method readStringLiteral {} {
+
+ my assertNext "\""
+
+ set result ""
+ try {
+ while {true} {
+ set ch [my nextChar]
+
+ if {$ch eq "\""} break
+
+ if {$ch eq "\\"} {
+ set ch [my nextChar]
+ switch -exact -- $ch {
+ "b" {
+ set ch "\b"
+ }
+ "r" {
+ set ch "\r"
+ }
+ "n" {
+ set ch "\n"
+ }
+ "f" {
+ set ch "\f"
+ }
+ "t" {
+ set ch "\t"
+ }
+ "u" {
+ set ch [format "%c" 0x[my nextChar][my nextChar][my nextChar][my nextChar]]
+ }
+ "\"" {}
+ "/" {}
+ "\\" {}
+ default {
+ throw {HUDDLE JSONparser} "Not a valid escaped JSON character: '$ch' in $jsonText"
+ }
+ }
+ }
+ append result $ch
+ }
+ } on $EndOfTextException {} {
+ throw {HUDDLE JSONparser} "Not a valid JSON string: '$jsonText'"
+ }
+
+ return $result
+ }
+
+ }
+
+ Json2huddle create json2huddle
+}
+
+
diff --git a/tcllib/modules/yaml/json2huddle.test b/tcllib/modules/yaml/json2huddle.test
new file mode 100644
index 0000000..dc95a3d
--- /dev/null
+++ b/tcllib/modules/yaml/json2huddle.test
@@ -0,0 +1,181 @@
+# -*- tcl -*-
+# json2huddle.test: tests for the huddle library.
+
+if {[lsearch [namespace children] ::tcltest] == -1} {
+ # single test
+ set selfrun 1
+ set auto_path [linsert $auto_path 0 [pwd]]
+ package require tcltest
+ namespace import ::tcltest::*
+ puts [package require huddle::json]
+} else {
+ # all.tcl
+ source [file join \
+ [file dirname [file dirname [file join [pwd] [info script]]]] \
+ devtools testutilities.tcl]
+
+ testsNeedTcl 8.5
+ testsNeedTcltest 2
+ testsNeed TclOO 1
+
+ support {
+ use try/try.tcl try
+ use try/throw.tcl throw
+ use json/json.tcl json
+ useLocal huddle.tcl huddle
+ }
+ testing {
+ useLocal json2huddle.tcl huddle::json
+ }
+}
+
+namespace import ::huddle::json2huddle
+
+
+test json2huddle-1.1 "test of parsing json string" -body {
+ json2huddle { "hello world" }
+} -result {HUDDLE {s {hello world}}}
+
+
+test json2huddle-1.2 "test of parsing json string" -body {
+ json2huddle { "Unicode characters: \u00e0\u00e8\u00ec\u00f2\u00f9\u00e1\u00e9\u00ed\u00f3\u00fa\u00e4\u00eb\u00ef\u00f6\u00fc" }
+} -result {HUDDLE {s {Unicode characters: àèìòùáéíóúäëïöü}}}
+
+
+test json2huddle-1.3 "test of parsing json string" -body {
+ json2huddle { "escaped tab:\tescaped quote \"" }
+} -result {HUDDLE {s {escaped tab: escaped quote "}}}
+
+
+test json2huddle-2.1 "test of parsing json number" -body {
+ json2huddle { 4 }
+} -result {HUDDLE {num 4}}
+
+
+test json2huddle-2.2 "test of parsing json number" -body {
+ json2huddle { 2.7 }
+} -result {HUDDLE {num 2.7}}
+
+test json2huddle-2.3 "test of parsing json number" -body {
+ json2huddle { -2.7e6 }
+} -result {HUDDLE {num -2.7e6}}
+
+test json2huddle-2.3 "test of parsing json number" -body {
+ json2huddle { 2345E-4 }
+} -result {HUDDLE {num 2345E-4}}
+
+test json2huddle-3.1 "test of parsing json boolean" -body {
+ json2huddle { true }
+} -result {HUDDLE {b true}}
+
+test json2huddle-3.1 "test of parsing json boolean" -body {
+ json2huddle { false }
+} -result {HUDDLE {b false}}
+
+test json2huddle-4.1 "test of parsing json null" -body {
+ json2huddle { null }
+} -result {HUDDLE null}
+
+
+test json2huddle-5.1 "test of parsing json array" -body {
+ json2huddle { [1,2, "3", 4, null, false] }
+} -result {HUDDLE {L {{num 1} {num 2} {s 3} {num 4} null {b false}}}}
+
+
+test json2huddle-5.2 "test of parsing json array" -body {
+ json2huddle { [ ] }
+} -result {HUDDLE {L {}}}
+
+
+test json2huddle-6.1 "test of parsing json dict" -body {
+ json2huddle { {"key1":"value1", "key2": 0, "key3": true,"key4":null} }
+} -result {HUDDLE {D {key1 {s value1} key2 {num 0} key3 {b true} key4 null}}}
+
+
+test json2huddle-6.2 "test of parsing json dict" -body {
+ json2huddle { { } }
+} -result {HUDDLE {D {}}}
+
+
+test json2huddle-7.1 "test of parsing json comments" -body {
+ json2huddle {
+ // this is a solidus double comment
+ "this is a string"
+ }
+} -result {HUDDLE {s {this is a string}}}
+
+
+test json2huddle-7.2 "test of parsing json comments" -body {
+ json2huddle {
+ /* c style
+ comment
+ */
+ "this is a string"
+ }
+} -result {HUDDLE {s {this is a string}}}
+
+
+test json2huddle-7.2 "test of parsing json comments" -body {
+ json2huddle {
+ /* c style
+ comment
+ */
+ // this is a solidus double comment
+ "this is a string"
+ /* c style comment */
+ // this is a solidus double comment
+ }
+} -result {HUDDLE {s {this is a string}}}
+
+
+
+
+test json2huddle-7.4 "test of parsing json comments" -body {
+ json2huddle {
+ // this is a solidus double comment
+ [
+ //another comment here
+ [],
+ {},
+ /* c style
+ comment
+ */
+
+ null, false, true,
+ -5.0e-4]
+ }
+} -result {HUDDLE {L {{L {}} {D {}} null {b false} {b true} {num -5.0e-4}}}}
+
+
+test json2huddle-8.1 "test of parsing complex data structures in json" -body {
+ json2huddle {
+
+ {"menu1": {
+ "id": 234,
+ "value": "File:",
+ "unival": "\u6021:",
+ "popup": {
+ "menuitem": [
+ {"value": "Open", "onclick": "OpenDoc()"},
+ {"value": "Close", "onclick": "CloseDoc()"}
+ ]
+ }
+ },
+ "menu2": {
+ "selected": true,
+ "texts": ["open", "close", "save as.."]
+
+ }
+
+ }
+ }
+} -result {HUDDLE {D {menu1 {D {id {num 234} value {s File:} unival {s 怡:} popup {D {menuitem {L {{D {value {s Open} onclick {s OpenDoc()}}} {D {value {s Close} onclick {s CloseDoc()}}}}}}}}} menu2 {D {selected {b true} texts {L {{s open} {s close} {s {save as..}}}}}}}}}
+
+
+test json2huddle-9.1 "test of no json" -body {
+ json2huddle { }
+} -returnCodes {error} -result "Nothing to read"
+
+
+
+tcltest::cleanupTests
diff --git a/tcllib/modules/yaml/layers.txt b/tcllib/modules/yaml/layers.txt
new file mode 100755
index 0000000..555c037
--- /dev/null
+++ b/tcllib/modules/yaml/layers.txt
@@ -0,0 +1,224 @@
+{
+ "filename": "022_05small.psd",
+ "layers": [
+ {
+ "layer": "トンボ（必ず表示させる",
+ "visible": false,
+ "haschild": false
+ },
+ {
+ "layer": "アタリ線（最終的に消す",
+ "visible": false,
+ "haschild": false
+ },
+ {
+ "layer": "title",
+ "visible": false,
+ "haschild": true,
+ "layers": [
+ {
+ "layer": "title 5.4",
+ "visible": false,
+ "haschild": false
+ }
+ ]
+ },
+ {
+ "layer": "logos",
+ "visible": false,
+ "haschild": true,
+ "layers": [
+ {
+ "layer": "niji_logo",
+ "visible": false,
+ "haschild": false
+ },
+ {
+ "layer": "+imoto+",
+ "visible": false,
+ "haschild": false
+ },
+ {
+ "layer": "レイヤー 2",
+ "visible": false,
+ "haschild": false
+ },
+ {
+ "layer": "nijiura 3",
+ "visible": false,
+ "haschild": false
+ },
+ {
+ "layer": "Here",
+ "visible": false,
+ "haschild": false
+ }
+ ]
+ },
+ {
+ "layer": "nijiura 2.3",
+ "visible": false,
+ "haschild": true,
+ "layers": [
+ {
+ "layer": "レイヤー 1",
+ "visible": false,
+ "haschild": false
+ },
+ {
+ "layer": "nijiura cap",
+ "visible": false,
+ "haschild": false
+ },
+ {
+ "layer": "nijiura 2.2",
+ "visible": false,
+ "haschild": false
+ }
+ ]
+ },
+ {
+ "layer": "name",
+ "visible": false,
+ "haschild": true,
+ "layers": [
+ {
+ "layer": "jal L",
+ "visible": false,
+ "haschild": false
+ },
+ {
+ "layer": "ana L_3",
+ "visible": false,
+ "haschild": false
+ },
+ {
+ "layer": "a380 L",
+ "visible": false,
+ "haschild": false
+ }
+ ]
+ },
+ {
+ "layer": "rainbow flash",
+ "visible": false,
+ "haschild": true,
+ "layers": [
+ {
+ "layer": "rainbow 7",
+ "visible": false,
+ "haschild": false
+ },
+ {
+ "layer": "rainbow 6",
+ "visible": false,
+ "haschild": false
+ },
+ {
+ "layer": "rainbow 5",
+ "visible": false,
+ "haschild": false
+ }
+ ]
+ },
+ {
+ "layer": "hikari",
+ "visible": false,
+ "haschild": true,
+ "layers": [
+ {
+ "layer": "kousen 6",
+ "visible": false,
+ "haschild": false
+ },
+ {
+ "layer": "kousen 5",
+ "visible": false,
+ "haschild": false
+ },
+ {
+ "layer": "kousen 4",
+ "visible": false,
+ "haschild": false
+ },
+ {
+ "layer": "kousen 3",
+ "visible": false,
+ "haschild": false
+ },
+ {
+ "layer": "kousen 2",
+ "visible": false,
+ "haschild": false
+ },
+ {
+ "layer": "kousen 1",
+ "visible": false,
+ "haschild": false
+ }
+ ]
+ },
+ {
+ "layer": "チャンネルミキサー",
+ "visible": true,
+ "haschild": false
+ },
+ {
+ "layer": "original",
+ "visible": true,
+ "haschild": false
+ },
+ {
+ "layer": "チャンネルミキサー 1",
+ "visible": true,
+ "haschild": false
+ },
+ {
+ "layer": "original 2",
+ "visible": true,
+ "haschild": false
+ },
+ {
+ "layer": "white light",
+ "visible": false,
+ "haschild": false
+ },
+ {
+ "layer": "ushiro",
+ "visible": false,
+ "haschild": true,
+ "layers": [
+ {
+ "layer": "色相・彩度1",
+ "visible": false,
+ "haschild": false
+ },
+ {
+ "layer": "sora 1",
+ "visible": false,
+ "haschild": false
+ },
+ {
+ "layer": "gurade",
+ "visible": false,
+ "haschild": false
+ }
+ ]
+ },
+ {
+ "layer": "背景 のコピー 2",
+ "visible": true,
+ "haschild": false
+ },
+ {
+ "layer": "用紙ゲージ",
+ "visible": false,
+ "haschild": false
+ },
+ {
+ "layer": "背景",
+ "visible": true,
+ "haschild": false
+ }
+ ]
+} \ No newline at end of file
diff --git a/tcllib/modules/yaml/pkgIndex.tcl b/tcllib/modules/yaml/pkgIndex.tcl
new file mode 100644
index 0000000..4931d15
--- /dev/null
+++ b/tcllib/modules/yaml/pkgIndex.tcl
@@ -0,0 +1,6 @@
+
+if {![package vsatisfies [package provide Tcl] 8.5]} {return}
+
+package ifneeded yaml 0.3.9 [list source [file join $dir yaml.tcl]]
+package ifneeded huddle 0.2 [list source [file join $dir huddle.tcl]]
+package ifneeded huddle::json 0.1 [list source [file join $dir json2huddle.tcl]]
diff --git a/tcllib/modules/yaml/rb.test b/tcllib/modules/yaml/rb.test
new file mode 100644
index 0000000..092841f
--- /dev/null
+++ b/tcllib/modules/yaml/rb.test
@@ -0,0 +1,654 @@
+# -*- tcl -*-
+# rb.test: test samples for the yaml library.
+# http://yaml4r.sourceforge.net/cookbook/
+#
+
+if {[lsearch [namespace children] ::tcltest] == -1} {
+ # single test
+ set selfrun 1
+ lappend auto_path [pwd]
+ package require tcltest
+ namespace import ::tcltest::*
+ puts [source huddle.tcl]
+ puts [source yaml.tcl]
+} else {
+ # all.tcl
+ source [file join \
+ [file dirname [file dirname [file join [pwd] [info script]]]] \
+ devtools testutilities.tcl]
+
+ testsNeedTcl 8.3
+ testsNeedTcltest 1.0
+
+ if {$::tcl_version < 8.5} {
+ if {[catch {package require dict}]} {
+ puts " Aborting the tests found in \"[file tail [info script]]\""
+ puts " Requiring dict package, not found."
+ return
+ }
+ }
+
+ testing {
+ useLocal yaml.tcl yaml
+ }
+}
+
+proc dictsort {dict} {
+ array set a $dict
+ set out [list]
+ foreach key [lsort [array names a]] {
+ lappend out $key $a($key)
+ }
+ return $out
+}
+
+proc dictsort2 {dict {pattern d}} {
+ set cur [lindex $pattern 0]
+ set subs [lrange $pattern 1 end]
+ foreach {tag sw} $cur break
+ set out {}
+ if {$sw ne ""} {array set msubs $sw}
+ if {$tag eq "l"} { ; # list
+ set i 0
+ foreach {node} $dict {
+ set subs1 $subs
+ if {$sw ne "" && [info exists msubs($i)]} {
+ set subs1 $msubs($i)
+ }
+ if {$subs1 ne ""} {
+ set node [dictsort2 $node $subs1]
+ }
+ lappend out $node
+ incr i
+ }
+ return $out
+ }
+ if {$tag eq "d"} { ; # dict
+ array set map $dict
+ foreach key [lsort [array names map]] {
+ set node $map($key)
+ set subs1 $subs
+ if {$sw ne "" && [info exists msubs($key)]} {
+ set subs1 $msubs($key)
+ }
+ if {$subs1 ne ""} {
+ set node [dictsort2 $node $subs1]
+ }
+ lappend out $key $node
+ }
+ return $out
+ }
+ error
+}
+
+test yaml.rb-1 "Simple Sequence" -body {
+ set data {
+---
+- apple
+- banana
+- carrot
+}
+ yaml::yaml2dict $data
+} -result {apple banana carrot}
+
+test yaml.rb-2 "Nested Sequences" -body {
+ set data {
+---
+-
+ - foo
+ - bar
+ - baz
+}
+ yaml::yaml2dict $data
+} -result {{foo bar baz}}
+
+test yaml.rb-3 "Mixed Sequences" -body {
+ set data {
+---
+-
+ - fo o
+-
+ - x1 23
+- bana na
+- carr ot
+}
+ yaml::yaml2dict $data
+} -result {{{fo o}} {{x1 23}} {bana na} {carr ot}}
+
+test yaml.rb-4 "Deeply Nested Sequences" -body {
+ set data {
+---
+-
+ -
+ - uno
+ - dos
+}
+ yaml::yaml2dict $data
+} -result {{{uno dos}}}
+
+test yaml.rb-5 "Simple Mapping" -body {
+ set data {
+---
+foo: whatever
+bar: stuff
+}
+ yaml::yaml2dict $data
+} -result {foo whatever bar stuff}
+
+test yaml.rb-6 "Sequence in a Mapping" -body {
+ set data {
+---
+foo: whatever
+bar:
+ - uno
+ - dos
+}
+ yaml::yaml2dict $data
+} -result {foo whatever bar {uno dos}}
+
+test yaml.rb-7 "Nested Mappings" -body {
+ set data {
+---
+foo: whatever
+bar:
+ fruit: apple
+ name: steve
+ sport: baseball
+}
+ yaml::yaml2dict $data
+} -result [dict create foo whatever bar [dict create fruit apple name steve sport baseball]]
+
+test yaml.rb-8 "Mixed Mapping" -body {
+ set data {
+---
+foo: whatever
+bar:
+ -
+ fruit: apple
+ name: steve
+ sport: baseball
+ - more
+ -
+ python: rocks
+ perl: papers
+ ruby: scissorses
+}
+ yaml::yaml2dict $data
+} -result [dict create foo whatever bar [list [dict create fruit apple name steve sport baseball] more [dict create python rocks perl papers ruby scissorses]]]
+
+test yaml.rb-9 "Mapping-in-Sequence Shortcut" -body {
+ set data {
+---
+- work on YAML.py:
+ - work on Store
+}
+ yaml::yaml2dict $data
+} -result {{{work on YAML.py} {{work on Store}}}}
+
+test yaml.rb-10 "Sequence-in-Mapping Shortcut" -body {
+ set data {
+---
+allow:
+- 'localhost'
+- '%.sourceforge.net'
+- '%.freepan.org'
+}
+ yaml::yaml2dict $data
+} -result {allow {localhost %.sourceforge.net %.freepan.org}}
+
+test yaml.rb-11 "Merge key" -body {
+ set data {
+---
+mapping:
+ name: Joe
+ job: Accountant
+ <<:
+ age: 38
+}
+ dictsort2 [yaml::yaml2dict $data] {d d}
+} -result [dictsort2 {mapping {name Joe job Accountant age 38}} {d d}]
+
+test yaml.rb-12 "Simple Inline Array" -body {
+ set data {
+---
+seq: [ a, b, c ]
+}
+ yaml::yaml2dict $data
+} -result {seq {a b c}}
+
+test yaml.rb-13 "Simple Inline Hash" -body {
+ set data {
+---
+hash: { name: Steve, foo: bar }
+}
+ dictsort2 [yaml::yaml2dict $data] {d d}
+} -result [dictsort2 {hash {name Steve foo bar}} {d d}]
+
+test yaml.rb-14 "Multi-line Inline Collections" -body {
+ set data {
+---
+languages: [ Ruby,
+ Perl,
+ Python ]
+websites: { YAML: yaml.org,
+ Ruby: ruby-lang.org,
+ Python: python.org,
+ Perl: use.perl.org }
+}
+ dictsort2 [yaml::yaml2dict $data] {{d {websites d}}}
+} -result [dictsort2 {languages {Ruby Perl Python} websites {YAML yaml.org Ruby ruby-lang.org Python python.org Perl use.perl.org}} \
+{{d {websites d}}} ]
+
+test yaml.rb-15 "Commas in Values" -body {
+ set data {
+---
+attendances: [ 45,123, 70,000, 17,222 ]
+}
+ yaml::yaml2dict $data
+} -result {attendances {45 123 70 000 17 222}}
+
+test yaml.rb-16 "Strings" -body {
+ set data {
+--- String
+}
+ yaml::yaml2dict $data
+} -result {String}
+
+test yaml.rb-17 "String characters" -body {
+ set data {
+---
+- What's Yaml?
+- It's for writing data structures in plain text.
+- And?
+- And what? That's not good enough for you?
+- No, I mean, "And what about Yaml?"
+- Oh, oh yeah. Uh.. Yaml for Ruby.
+}
+ yaml::yaml2dict $data
+} -result {{What's Yaml?} {It's for writing data structures in plain text.} And? {And what? That's not good enough for you?} {No, I mean, "And what about Yaml?"} {Oh, oh yeah. Uh.. Yaml for Ruby.}}
+
+test yaml.rb-18 "Indicators in Strings" -body {
+ set data {
+---
+the colon followed by space is an indicator: but is a string:right here
+same for the pound sign: here we have it#in a string
+the comma can, honestly, be used in most cases: [ but not in, inline collections ]
+}
+ yaml::yaml2dict $data
+} -result [dict create {the colon followed by space is an indicator} {but is a string:right here} {same for the pound sign} {here we have it#in a string} {the comma can, honestly, be used in most cases} {{but not in} {inline collections}}]
+
+test yaml.rb-19 "Forcing Strings" -body {
+ set data {
+---
+date string: !!str 2001-08-01
+number string: !!str 192
+}
+ yaml::yaml2dict $data
+} -result [dict create {date string} 2001-08-01 {number string} 192]
+
+test yaml.rb-20 "Single-quoted Strings" -body {
+ set data {
+---
+all my favorite symbols: '#:!/%.)'
+a few i hate: '&(*'
+why do i hate them?: 'it''s very hard to explain'
+}
+ yaml::yaml2dict $data
+} -result {{all my favorite symbols} #:!/%.) {a few i hate} &(* {why do i hate them?} {it's very hard to explain}}
+
+test yaml.rb-21 "Double-quoted Strings" -body {
+ set data {
+---
+i know where i want my line breaks: "one here\nand another here\n"
+}
+ yaml::yaml2dict $data
+} -result {{i know where i want my line breaks} {one here
+and another here
+}}
+
+test yaml.rb-22 "Multi-line Quoted Strings" -body {
+ set data {
+---
+i want a long string: "so i'm going to
+ let it go on and on to other lines
+ until i end it with a quote."
+}
+ yaml::yaml2dict $data
+} -result {{i want a long string} {so i'm going to let it go on and on to other lines until i end it with a quote.}}
+
+test yaml.rb-23 "Plain scalars" -body {
+ set data {
+---
+- My little toe is broken in two places;
+- I'm crazy to have skied this way;
+- I'm not the craziest he's seen, since there was always the German guy
+ who skied for 3 hours on a broken shin bone (just below the kneecap);
+- Nevertheless, second place is respectable, and he doesn't
+ recommend going for the record;
+- He's going to put my foot in plaster for a month;
+- This would impair my skiing ability somewhat for the
+ duration, as can be imagined.
+}
+ yaml::yaml2dict $data
+} -result {{My little toe is broken in two places;} {I'm crazy to have skied this way;} {I'm not the craziest he's seen, since there was always the German guy who skied for 3 hours on a broken shin bone (just below the kneecap);} {Nevertheless, second place is respectable, and he doesn't recommend going for the record;} {He's going to put my foot in plaster for a month;} {This would impair my skiing ability somewhat for the duration, as can be imagined.}}
+
+test yaml.rb-24 "Null" -body {
+ set data {
+---
+name: Mr. Show
+hosted by: Bob and David
+date of next season: ~
+}
+ yaml::yaml2dict $data
+} -result {name {Mr. Show} {hosted by} {Bob and David} {date of next season} {}}
+
+test yaml.rb-25 "Boolean" -body {
+ set data {
+---
+Is Gus a Liar?: true
+Do I rely on Gus for Sustenance?: false
+}
+ yaml::yaml2dict $data
+} -result [dict create {Is Gus a Liar?} 1 {Do I rely on Gus for Sustenance?} 0]
+
+test yaml.rb-26 "Integers" -body {
+ set data {
+---
+zero: 0
+simple: 12
+one-thousand: 1,000
+negative one-thousand: -1,000
+}
+ yaml::yaml2dict $data
+} -result [dict create zero 0 simple 12 one-thousand 1000 {negative one-thousand} -1000]
+
+test yaml.rb-27 "Integers as Map Keys" -body {
+ set data {
+---
+1: one
+2: two
+3: three
+}
+ yaml::yaml2dict $data
+} -result {1 one 2 two 3 three}
+
+test yaml.rb-28 "Floats" -body {
+ set data {
+---
+a simple float: 2.00
+larger float: 1,000.09
+scientific notation: 1.00009e+3
+}
+ yaml::yaml2dict $data
+} -result [dict create {a simple float} 2.00 {larger float} 1000.09 {scientific notation} 1.00009e+3]
+
+
+if {$::tcl_version < 8.5} {
+ test yaml.rb-29 "Time" -body {
+ set data {
+---
+iso8601: 2001-12-14t21:59:43.10-05:00
+space seperated: 2001-12-14 21:59:43.10 -05:00
+}
+ yaml::yaml2dict $data
+ } -result [eval dict create [string map \
+ [list TIMESTAMP1 [clock scan "+5 hours" -base [clock scan "2001-12-14 21:59:43" -gmt 1]] \
+ TIMESTAMP2 [clock scan "+5 hours" -base [clock scan "2001-12-14 21:59:43" -gmt 1]]] \
+ {iso8601 TIMESTAMP1 {space seperated} TIMESTAMP2}]]
+} else {
+ test yaml.rb-29 "Time" -body {
+ set data {
+---
+iso8601: 2001-12-14t21:59:43.10-05:00
+space seperated: 2001-12-14 21:59:43.10 -05:00
+}
+ yaml::yaml2dict $data
+ } -result [string map [list TIMESTAMP1 [clock scan "2001-12-14 21:59:43 -05:00" -format {%Y-%m-%d %k:%M:%S %Z}] \
+ TIMESTAMP2 [clock scan "2001-12-14 21:59:43 -05:00" -format {%Y-%m-%d %k:%M:%S %Z}]] \
+ {iso8601 TIMESTAMP1 {space seperated} TIMESTAMP2}]
+}
+
+test yaml.rb-30 "Date" -body {
+ set data {
+--- 1976-07-31
+}
+ yaml::yaml2dict $data
+} -result [clock scan "1976-07-31"]
+
+test yaml.rb-31 "Blocks" -body {
+ set data {
+---
+this: |
+ Foo
+ Bar
+}
+ yaml::yaml2dict $data
+} -result {this {Foo
+Bar
+}}
+
+test yaml.rb-32 "The '+' indicator" -body {
+ set data {
+---
+normal: |
+ extra new lines not kept
+
+preserving: |+
+ extra new lines are kept
+
+
+dummy: value
+}
+ dictsort [yaml::yaml2dict $data]
+} -result [dictsort {normal {extra new lines not kept
+} preserving {extra new lines are kept
+
+
+} dummy value}]
+
+test yaml.rb-33 "Three trailing newlines in literals" -body {
+ set data {
+---
+clipped: |
+ This has one newline.
+
+
+
+same as "clipped" above: "This has one newline.\n"
+
+stripped: |-
+ This has no newline.
+
+
+
+same as "stripped" above: "This has no newline."
+
+kept: |+
+ This has four newlines.
+
+
+
+same as "kept" above: "This has four newlines.\n\n\n\n"
+}
+ dictsort [yaml::yaml2dict $data]
+} -result [dictsort {clipped {This has one newline.
+} {same as "clipped" above} {This has one newline.
+} stripped {This has no newline.} {same as "stripped" above} {This has no newline.} kept {This has four newlines.
+
+
+
+} {same as "kept" above} {This has four newlines.
+
+
+
+}}]
+
+test yaml.rb-34 "Extra trailing newlines with spaces" -body {
+ set data {
+---
+this: |
+ Foo
+
+
+kept: |+
+ Foo
+}
+ yaml::yaml2dict $data
+} -result [dict create this {Foo
+} kept {Foo
+}]
+
+test yaml.rb-35 "Folded Block in a Sequence" -body {
+ set data {
+---
+- apple
+- banana
+- >
+ can't you see
+ the beauty of yaml?
+ hmm
+- dog
+}
+ yaml::yaml2dict $data
+} -result {apple banana {can't you see the beauty of yaml? hmm
+} dog}
+
+test yaml.rb-36 "Folded Block as a Mapping Value" -body {
+ set data {
+---
+quote: >
+ Mark McGwire's
+ year was crippled
+ by a knee injury.
+source: espn
+}
+ yaml::yaml2dict $data
+} -result [dict create quote {Mark McGwire's year was crippled by a knee injury.
+} source espn]
+
+test yaml.rb-37 "Three trailing newlines in folded blocks" -body {
+ set data {
+---
+clipped: >
+ This has one newline.
+
+
+
+same as "clipped" above: "This has one newline.\n"
+
+stripped: >-
+ This has no newline.
+
+
+
+same as "stripped" above: "This has no newline."
+
+kept: >+
+ This has four newlines.
+
+
+
+same as "kept" above: "This has four newlines.\n\n\n\n"
+}
+ dictsort [yaml::yaml2dict $data]
+} -result [dictsort {clipped {This has one newline.
+} {same as "clipped" above} {This has one newline.
+} stripped {This has no newline.} {same as "stripped" above} {This has no newline.} kept {This has four newlines.
+
+
+} {same as "kept" above} {This has four newlines.
+
+
+
+}}]
+
+test yaml.rb-38 "Extra trailing newlines with spaces" -body {
+ set data {
+---
+- &showell Steve
+- Clark
+- Brian
+- Oren
+- *showell
+}
+ yaml::yaml2dict $data
+} -result {Steve Clark Brian Oren Steve}
+
+test yaml.rb-39 "Alias of a Mapping" -body {
+ set data {
+---
+- &hello
+ Meat: pork
+ Starch: potato
+- banana
+- *hello
+}
+ yaml::yaml2dict $data
+} -result [list [dict create Meat pork Starch potato] banana [dict create Meat pork Starch potato]]
+
+#test yaml.rb-40 "Trailing Document Separator" -body {
+# set data {
+#- foo: 1
+# bar: 2
+#---
+#more: stuff
+#}
+# yaml::yaml2dict $data
+#} -result {Steve Clark Brian Oren Steve}
+
+test yaml.rb-41 "Alias of a Mapping" -body {
+ set data {
+--- %YAML:1.0
+foo: 1
+bar: 2
+}
+ yaml::yaml2dict $data
+} -result {foo 1 bar 2}
+
+test yaml.rb-42 "Red Herring Document Separator" -body {
+ set data {
+---
+foo: |
+ ---
+}
+ yaml::yaml2dict $data
+} -result {foo {---
+}}
+
+test yaml.rb-43 "Multiple Document Separators in Block" -body {
+ set data {
+---
+foo: |
+ ---
+ foo: bar
+ ---
+ yo: baz
+bar: |
+ fooness
+}
+ yaml::yaml2dict $data
+} -result {foo {---
+foo: bar
+---
+yo: baz
+} bar {fooness
+}}
+
+# YAML For Ruby
+# (ignored)
+
+
+
+
+
+# ... Tests of addStrings ...
+# (Requires introspection of parser state)
+
+
+if [info exists selfrun] {
+ tcltest::cleanupTests
+} else {
+ testsuiteCleanup
+}
+
+
diff --git a/tcllib/modules/yaml/yaml.bench b/tcllib/modules/yaml/yaml.bench
new file mode 100755
index 0000000..4b41350
--- /dev/null
+++ b/tcllib/modules/yaml/yaml.bench
@@ -0,0 +1,87 @@
+# -*- tcl -*-
+# Tcl Benchmark File
+#
+# This file contains a number of benchmarks for the 'yaml' module.
+# This allow developers to monitor/gauge/track package performance.
+#
+# Copyright (c) 2008 by KATO Kanryu <kanryu6@users.sourceforge.net>
+
+# We need at least version 8.4 for the package and thus the
+# benchmarks.
+
+if {![package vsatisfies [package provide Tcl] 8.4]} {
+ return
+}
+
+# ### ### ### ######### ######### ######### ###########################
+## Setting up the environment ...
+## Here we are testing version 2.
+
+if {[lsearch [namespace children] ::bench] == -1} {
+ # single test
+ set selfrun 1
+ lappend auto_path [pwd]
+ package require bench
+ puts [package require yaml]
+} else {
+ # all.tcl
+ set moddir [file dirname [file dirname [info script]]]
+ lappend auto_path $moddir
+
+ source [file join [file dirname [info script]] yaml.tcl]
+}
+
+set Invoice {
+--- # !<tag:clarkevans.com,2002:invoice>
+invoice: 34843
+date : 2001-01-23
+bill-to: &id001
+ given : Chris
+ family : Dumars
+ address:
+ lines: |
+ 458 Walkman Dr.
+ Suite #292
+ city : Royal Oak
+ state : MI
+ postal : 48046
+ship-to: *id001
+product:
+ - sku : BL394D
+ quantity : 4
+ description : Basketball
+ price : 450.00
+ - sku : BL4438H
+ quantity : 1
+ description : Super Hoop
+ price : 2392.00
+tax : 251.42
+total: 4443.52
+comments:
+ Late afternoon is best.
+ Backup contact is Nancy
+ Billsmer @ 338-4338.
+}
+
+set huddle {HUDDLE {!!map {invoice {!!int 34843} date {!!timestamp 980175600} bill-to {!!map {given {!!str Chris} family {!!str Dumars} address {!!map {lines {!!str {458 Walkman Dr.
+Suite #292
+}} city {!!str {Royal Oak}} state {!!str MI} postal {!!int 48046}}}}} ship-to {!!map {given {!!str Chris} family {!!str Dumars} address {!!map {lines {!!str {458 Walkman Dr.
+Suite #292
+}} city {!!str {Royal Oak}} state {!!str MI} postal {!!int 48046}}}}} product {!!seq {{!!map {sku {!!str BL394D} quantity {!!int 4} description {!!str Basketball} price {!!float 450.00}}} {!!map {sku
+ {!!str BL4438H} quantity {!!int 1} description {!!str {Super Hoop}} price {!!float 2392.00}}}}} tax {!!float 251.42} total {!!float 4443.52} comments {!!str {Late afternoon is best. Backup contact is Nancy Billsmer @ 338-4338.}}}}}
+
+# ### ### ### ######### ######### ######### ###########################
+## Benchmarks.
+
+foreach n {1 10 100 1000} {
+ bench -desc "yaml yaml2dict $n" -body {
+ yaml::yaml2dict $Invoice
+ }
+
+ bench -desc "yaml huddle2yaml $n" -body {
+ yaml::huddle2yaml $huddle
+ }
+}
+
+# ### ### ### ######### ######### ######### ###########################
+## Complete
diff --git a/tcllib/modules/yaml/yaml.man b/tcllib/modules/yaml/yaml.man
new file mode 100644
index 0000000..c9fb9f4
--- /dev/null
+++ b/tcllib/modules/yaml/yaml.man
@@ -0,0 +1,189 @@
+[comment {-*- tcl -*- doctools manpage}]
+[vset YAML_VERSION 0.3.9]
+[manpage_begin yaml n [vset YAML_VERSION]]
+[see_also base64]
+[see_also huddle]
+[see_also json]
+[keywords {data exchange}]
+[keywords huddle]
+[keywords parsing]
+[keywords {text processing}]
+[keywords yaml]
+[copyright {2008 KATO Kanryu <kanryu6@users.sourceforge.net>}]
+[moddesc {YAML processing}]
+[titledesc {YAML Format Encoder/Decoder}]
+[require Tcl 8.4]
+[require yaml [opt [vset YAML_VERSION]]]
+[description]
+[para]
+
+The [package yaml] package provides a simple Tcl-only library for parsing the
+YAML [uri http://www.yaml.org/] data exchange format as specified in
+[uri http://www.yaml.org/spec/1.1/].
+
+[para]
+The [package yaml] package returns
+data as a Tcl [cmd dict]. Either the [package dict] package or Tcl 8.5 is
+required for use.
+
+[section COMMANDS]
+
+[list_begin definitions]
+
+[call [cmd ::yaml::yaml2dict] [opt [arg options]] [arg txt]]
+[call [cmd ::yaml::yaml2huddle] [opt [arg options]] [arg txt]]
+
+Parse yaml formatted text [arg txt] into a Tcl dict/huddle and return the value.
+
+[list_begin options]
+[opt_def [const -file]]
+
+[arg txt] is a filename of YAML-stream.
+
+[opt_def [const -stream]]
+
+[arg txt] is just a YAML-stream.
+
+[opt_def "[const -types] [arg list]"]
+
+The [arg list] is a type list for the yaml-scalar types.(e.g. !!str !!timestamp !!integer !!true ...)
+
+[example { -types {timestamp integer null true false}}
+]
+In this case, if a string matched "timestamp", converted to the TCL internal timestamp.(e.g. "2001-12-15T02:59:43.1Z" => 1008385183)
+
+[opt_def "[const -m:true] [arg param]"]
+
+The [arg param] is two elements of list for the value of true, and considered strings.
+
+[example { -m:true {1 {true on + yes y}}}
+]
+In this case, the string "yes" found in YAML Stream, automatically converted 1.
+
+[opt_def "[const -m:false] [arg param]"]
+
+The [arg param] is two elements of list for the value of false, and considered strings.
+
+[example { -m:false {0 {false off - no n}}}
+]
+
+[opt_def "[const -m:null] [arg param]"]
+
+The [arg param] is two elements of list for the value of null, and considered strings.
+
+[example { -m:null {"" {null nil "" ~}}}
+]
+
+[opt_def [const -validate]]
+
+Experiment,old: Output stream contains YAML's-tag, each node.
+
+[example {% puts [::yaml::load -validate {[aaa, bbb]}]
+=>
+!!seq {{!!str aaa} {!!str bbb}}
+}]
+[list_end]
+
+[call [cmd ::yaml::setOption] [opt [arg options]]]
+Change implicit options for the library.
+Now, the params are the same as [cmd ::yaml::yaml2dict].
+Arguments of[cmd ::yaml::yaml2dict] is more priority than this setting.
+
+[call [cmd ::yaml::dict2yaml] [arg dict] [opt [arg indent]] [opt [arg wordwrap]]]
+[call [cmd ::yaml::list2yaml] [arg list] [opt [arg indent]] [opt [arg wordwrap]]]
+[call [cmd ::yaml::huddle2yaml] [arg huddle] [opt [arg indent]] [opt [arg wordwrap]]]
+Convert a dict/list/huddle object into YAML stream.
+
+[list_begin definitions]
+[def indent]
+spaces indent of each block node.
+currently default is 2.
+
+[def wordwrap]
+word wrap for YAML stream.
+currently default is 40.
+[list_end]
+
+[list_end]
+[para]
+
+[section EXAMPLES]
+[para]
+
+An example of a yaml stream converted to Tcl. A yaml stream is returned as a
+single item with multiple elements.
+
+[para]
+[example {{
+--- !<tag:clarkevans.com,2002:invoice>
+invoice: 34843
+date : 2001-01-23
+bill-to: &id001
+ given : Chris
+ family : Dumars
+ address:
+ lines: |
+ 458 Walkman Dr.
+ Suite #292
+ city : Royal Oak
+ state : MI
+ postal : 48046
+ship-to: *id001
+product:
+ - sku : BL394D
+ quantity : 4
+ description : Basketball
+ price : 450.00
+ - sku : BL4438H
+ quantity : 1
+ description : Super Hoop
+ price : 2392.00
+tax : 251.42
+total: 4443.52
+comments:
+ Late afternoon is best.
+ Backup contact is Nancy
+ Billsmer @ 338-4338.
+}
+=>
+invoice 34843 date 2001-01-23 bill-to {given Chris family Dumars address {lines {458 Walkman Dr.
+Suite #292
+} city {Royal Oak} state MI postal 48046}} ship-to {given Chris family Dumars address {lines {458 Walkman Dr.
+Suite #292
+} city {Royal Oak} state MI postal 48046}} product {{sku BL394D quantity 4 description Basketball price 450.00} {sku BL4438H quantity 1 description {Super Hoop} price 2392.00}} tax 251.42 total 4443.52 comments {Late afternoon is best. Backup contact is Nancy Billsmer @ 338-4338.}}]
+[para]
+
+An example of a yaml object converted to Tcl. A yaml object is returned as a
+multi-element list (a dict).
+
+[para]
+[example {{
+---
+- [name , hr, avg ]
+- [Mark McGwire, 65, 0.278]
+- [Sammy Sosa , 63, 0.288]
+-
+ Mark McGwire: {hr: 65, avg: 0.278}
+ Sammy Sosa: { hr: 63, avg: 0.288}
+}
+=>
+{name hr avg} {{Mark McGwire} 65 0.278} {{Sammy Sosa} 63 0.288} {{Mark McGwire} {hr 65 avg 0.278} {Sammy Sosa} {hr 63 avg 0.288}}
+}]
+
+[section LIMITATIONS]
+
+[para]
+tag parser not implemented. currentry, tags are merely ignored.
+
+[para]
+Only Anchor => Aliases ordering. back alias-referring is not supported.
+
+[para]
+Too many braces, or too few braces.
+
+[para]
+Not enough character set of line feeds. Please use only "\n" as line breaks.
+
+[vset CATEGORY yaml]
+[include ../doctools2base/include/feedback.inc]
+[manpage_end]
diff --git a/tcllib/modules/yaml/yaml.tcl b/tcllib/modules/yaml/yaml.tcl
new file mode 100644
index 0000000..389f079
--- /dev/null
+++ b/tcllib/modules/yaml/yaml.tcl
@@ -0,0 +1,1283 @@
+#
+# YAML parser for Tcl.
+#
+# See http://www.yaml.org/spec/1.1/
+#
+# yaml.tcl,v 0.3.6 2011-08-23 15:06:25 KATO Kanryu(kanryu6@users.sourceforge.net)
+#
+# It is published with the terms of tcllib's BSD-style license.
+# See the file named license.terms.
+#
+# It currently supports a very limited subsection of the YAML spec.
+#
+#
+
+package require Tcl 8.5
+package provide yaml 0.3.9
+package require cmdline
+package require huddle 0.1.7
+
+namespace eval ::yaml {
+ namespace export load setOptions dict2dump list2dump
+ variable data
+ array set data {}
+
+ # fixed value groups for some yaml-types.
+ variable fixed
+
+ # a plane scalar is worked for matching and converting to the specific type.
+ # proc some_command {value} {
+ # return [list !!type $treatmented-value]
+ # or
+ # return ""
+ # }
+ variable parsers
+
+ # scalar/collection treatment for matched specific yaml-tag
+ # proc some_composer {type value} {
+ # return [list 1 $result-type $treatmented-value]
+ # or
+ # return ""
+ # }
+ variable composer
+
+ variable defaults
+ array set defaults {
+ isfile 0
+ validate 0
+ types {timestamp int float null true false}
+ composer {
+ !!binary ::yaml::_composeBinary
+ }
+ parsers {
+ timestamp ::yaml::_parseTimestamp
+ }
+ shorthands {
+ !! {tag:yaml.org,2002:}
+ }
+ fixed {
+ null:Value ""
+ null:Group {null "" ~}
+ true:Value 1
+ true:Group {true on + yes y}
+ false:Value 0
+ false:Group {false off - no n}
+ }
+ }
+
+ variable _dumpIndent 2
+ variable _dumpWordWrap 40
+
+ variable opts [lrange [::cmdline::GetOptionDefaults {
+ {file {input is filename}}
+ {stream {input is stream}}
+ {m.arg "" {fixed-modifiers bulk settings(null/true/false)}}
+ {m:null.arg "" {null modifier settings(default {"" {null "" ~}})}}
+ {m:true.arg "" {true modifier settings(default {1 {true on + yes y}})}}
+ {m:false.arg "" {false modifier settings(default {0 {false off - no n}})}}
+ {types.arg "" {modifier list settings(default {nop timestamp integer null true false})}}
+ {validate {to validate the input(not dumped tcl content)}}
+ } result] 2 end] ;# Remove ? and help.
+
+ variable errors
+ array set errors {
+ TAB_IN_PLAIN {Tabs can be used only in comments, and in quoted "..." '...'.}
+ AT_IN_PLAIN {Reserved indicators {@} can't start a plain scalar.}
+ BT_IN_PLAIN {Reserved indicators {`} can't start a plain scalar.}
+ SEQEND_NOT_IN_SEQ {There is a flow-sequence end '\]' not in flow-sequence [v, ...].}
+ MAPEND_NOT_IN_MAP {There is a flow-mapping end '\}' not in flow-mapping {k: v, ...}.}
+ ANCHOR_NOT_FOUND {Could not find the anchor-name(current-version, "after refering" is not supported)}
+ MALFORM_D_QUOTE {Double quote "..." parsing error. end of quote is missing?}
+ MALFORM_S_QUOTE {Single quote '...' parsing error. end of quote is missing?}
+ TAG_NOT_FOUND {The "$p1" handle wasn't declared.}
+ INVALID_MERGE_KEY {merge-key "<<" is not impremented in not mapping scope(e.g. in sequence).}
+ MALFORMED_MERGE_KEY {malformed merge-key "<<" using.}
+ }
+}
+
+####################
+# Public APIs
+####################
+
+proc ::yaml::yaml2dict {args} {
+ _getOption $args
+
+ set result [_parseBlockNode]
+
+ set a [huddle get_stripped $result]
+
+ if {$yaml::data(validate)} {
+ set result [string map "{\n} {\\n}" $result]
+ }
+
+ return [huddle get_stripped $result]
+}
+
+proc ::yaml::yaml2huddle {args} {
+ _getOption $args
+
+ set result [_parseBlockNode]
+ if {$yaml::data(validate)} {
+ set result [string map "{\n} {\\n}" $result]
+ }
+ return $result
+}
+
+proc ::yaml::setOptions {argv} {
+ variable defaults
+ array set options [_imp_getOptions argv]
+ array set defaults [array get options]
+}
+
+# Dump TCL List to YAML
+#
+
+proc ::yaml::list2yaml {list {indent 2} {wordwrap 40}} {
+ return [huddle2yaml [huddle list {*}$list] $indent $wordwrap]
+}
+
+proc ::yaml::dict2yaml {dict {indent 2} {wordwrap 40}} {
+ return [huddle2yaml [huddle create {*}$dict] $indent $wordwrap]
+}
+
+proc ::yaml::huddle2yaml {huddle {indent 2} {wordwrap 40}} {
+ set yaml::_dumpIndent $indent
+ set yaml::_dumpWordWrap $wordwrap
+
+ # Start at the base of the array and move through it.
+ set out [join [list "---\n" [_imp_huddle2yaml $huddle] "\n"] ""]
+ return $out
+}
+
+
+####################
+# Option settings
+####################
+
+proc ::yaml::_getOption {argv} {
+ variable data
+ variable parsers
+ variable fixed
+ variable composer
+
+ # default settings
+ array set options [_imp_getOptions argv]
+
+ array set fixed $options(fixed)
+ array set parsers $options(parsers)
+ array set composer $options(composer)
+ array set data [list validate $options(validate) types $options(types)]
+ set isfile $options(isfile)
+
+ foreach {buffer} $argv break
+ if {$isfile} {
+ set fd [open $buffer r]
+ set buffer [read $fd]
+ close $fd
+ }
+ set data(buffer) $buffer
+ set data(start) 0
+ set data(length) [string length $buffer]
+ set data(current) 0
+ set data(finished) 0
+}
+
+proc ::yaml::_imp_getOptions {{argvvar argv}} {
+ upvar 1 $argvvar argv
+
+ variable defaults
+ variable opts
+ array set options [array get defaults]
+
+ # default settings
+ array set fixed $options(fixed)
+
+ # parse argv
+ set argc [llength $argv]
+ while {[set err [::cmdline::getopt argv $opts opt arg]]} {
+ if {$err eq -1} break
+ switch -- $opt {
+ "file" {
+ set options(isfile) 1
+ }
+ "stream" {
+ set options(isfile) 0
+ }
+ "m" {
+ array set options(fixed) $arg
+ }
+ "validate" {
+ set options(validate) 1
+ }
+ "types" {
+ set options(types) $arg
+ }
+ default {
+ if {[regexp {m:(\w+)} $opt nop type]} {
+ if {$arg eq ""} {
+ set fixed(${type}:Group) ""
+ } else {
+ foreach {value group} $arg {
+ set fixed(${type}:Value) $value
+ set fixed(${type}:Group) $group
+ }
+ }
+ }
+ }
+ }
+ }
+ set options(fixed) [array get fixed]
+ return [array get options]
+}
+
+#########################
+# Scalar/Block Composers
+#########################
+proc ::yaml::_composeTags {tag value} {
+ if {$tag eq ""} {return $value}
+ set value [huddle get_stripped $value]
+ if {$tag eq "!!str"} {
+ set pair [list $tag $value]
+ } elseif {[info exists yaml::composer($tag)]} {
+ set pair [$yaml::composer($tag) $value]
+ } else {
+ error [_getErrorMessage TAG_NOT_FOUND $tag]
+ }
+ return [huddle wrap $pair]
+}
+
+proc ::yaml::_composeBinary {value} {
+ package require base64
+ return [list !!binary [::base64::decode $value]]
+}
+
+proc ::yaml::_composePlain {value} {
+ if {$value ne ""} {
+ if {[huddle type $value] ne "plain"} {return $value}
+ set value [huddle get_stripped $value]
+ }
+ set pair [_toType $value]
+ return [huddle wrap $pair]
+}
+
+proc ::yaml::_toType {value} {
+ if {$value eq ""} {return [list !!str ""]}
+
+ set lowerval [string tolower $value]
+ foreach {type} $yaml::data(types) {
+ if {[info exists yaml::parsers($type)]} {
+ set pair [$yaml::parsers($type) $value]
+ if {$pair ne ""} {return $pair}
+ continue
+ }
+ switch -- $type {
+ int {
+ # YAML 1.1
+ if {[regexp {^-?\d[\d,]*\d$|^\d$} $value]} {
+ regsub -all "," $value "" integer
+ return [list !!int $integer]
+ }
+ }
+ float {
+ # don't run before "integer"
+ regsub -all "," $value "" val
+ if {[string is double $val]} {
+ return [list !!float $val]
+ }
+ }
+ default {
+ # !!null !!true !!false
+ if {[info exists yaml::fixed($type:Group)] \
+ && [lsearch $yaml::fixed($type:Group) $lowerval] >= 0} {
+ set value $yaml::fixed($type:Value)
+ return [list !!$type $value]
+ }
+ }
+ }
+ }
+
+ # the others
+ return [list !!str $value]
+}
+
+####################
+# Block Node parser
+####################
+proc ::yaml::_parseBlockNode {{status ""} {indent -1}} {
+ variable data
+ set prev {}
+ set result {}
+ set scalar 0
+ set pos 0
+ set tag ""
+ while {1} {
+ if {$data(finished) == 1} {
+ break
+ }
+ _skipSpaces 1
+ set type [_getc]
+ set current [_getCurrent]
+ if {$type eq "-"} {
+ set cc "[_getc][_getc]"
+ if {"$type$cc" eq "---" && $current == 0} {
+ set result {}
+ continue
+ } else {
+ _ungetc 2
+
+ # [Spec]
+ # Since people perceive theg-hindicator as indentation,
+ # nested block sequences may be indented by one less space
+ # to compensate, except, of course,
+ # if nested inside another block sequence.
+ incr current
+ }
+ }
+ if {$type eq "."} {
+ set cc "[_getc][_getc]"
+ if {"$type$cc" eq "..." && $current == 0} {
+ set data(finished) 1
+ break
+ } else {
+ _ungetc 2
+
+# # [Spec]
+# # Since people perceive theg-hindicator as indentation,
+# # nested block sequences may be indented by one less space
+# # to compensate, except, of course,
+# # if nested inside another block sequence.
+# incr current
+ }
+ }
+ if {$type eq "" || $current <= $indent} { ; # end document
+ _ungetc
+ break
+ }
+ switch -- $type {
+ "-" { ; # block sequence entry
+ set pos $current
+ # [196] l-block-seq-entry(n,c)
+ foreach {scalar value} [_parseSubBlock $pos "SEQUENCE"] break
+ }
+ "?" { ; # mapping key
+ foreach {scalar nop} [_parseSubBlock $pos ""] break
+ }
+ ":" { ; # mapping value
+ if {$current < $pos} {set pos [expr {$current+1}]}
+ foreach {scalar value} [_parseSubBlock $pos "MAPPING"] break
+ }
+ "|" { ; # literal block scalar
+ set value [_parseBlockScalar $indent "\n"]
+ }
+ ">" { ; # folded block scalar
+ set value [_parseBlockScalar $indent " "]
+ }
+ "<" { ; # mergeing
+ set c [_getc]
+ if {"$type$c" eq "<<"} {
+ set pos [_getCurrent]
+ _skipSpaces 1
+ set c [_getc]
+ if {$c ne ":"} {error [_getErrorMessage INVALID_MERGE_KEY]}
+ if {$status ne "" && $status ne "MAPPING"} {error [_getErrorMessage INVALID_MERGE_KEY]}
+ set status "MAPPING"
+ foreach {result prev} [_mergeExpandedAliases $result $pos $prev] break
+ } else {
+ _ungetc
+ set scalar 1
+ }
+ }
+ "&" { ; # node's anchor property
+ set anchor [_getToken]
+ }
+ "*" { ; # alias node
+ set alias [_getToken]
+ if {$yaml::data(validate)} {
+ set status "ALIAS"
+ set value *$alias
+ } else {
+ set value [_getAnchor $alias]
+ }
+ }
+ "!" { ; # node's tag
+ _ungetc
+ set tag [_getToken]
+ }
+ "%" { ; # directive line
+ _getLine
+ }
+ default {
+ if {[regexp {^[\[\]\{\}\"']$} $type]} {
+ set pos [expr {1 + $current}]
+ _ungetc
+ set value [_parseFlowNode]
+ } else {
+ set scalar 1
+ }
+ }
+ }
+ if {$scalar} {
+ set pos [_getCurrent]
+ _ungetc
+ set value [_parseScalarNode $type "BLOCK" $pos]
+ set value [_composeTags $tag $value]
+ set tag ""
+ set scalar 0
+ }
+ if {[info exists value]} {
+ if {$status eq "NODE"} {return $value}
+ foreach {result prev} [_pushValue $result $prev $status $value "BLOCK"] break
+ unset value
+ }
+ }
+ if {$status eq "SEQUENCE"} {
+ set result [huddle sequence {*}$result]
+ } elseif {$status eq "MAPPING"} {
+ if {[llength $prev] == 2} {
+ set result [_set_huddle_mapping $result $prev]
+ }
+ } else {
+ if {[info exists prev]} {
+ set result $prev
+ }
+ set result [lindex $result 0]
+ set result [_composePlain $result]
+ if {![huddle isHuddle $result]} {
+ set result [huddle wrap [list !!str $result]]
+ }
+ }
+ if {$tag ne ""} {
+ set result [_composeTags $tag $result]
+ unset tag
+ }
+ if {[info exists anchor]} {
+ _setAnchor $anchor $result
+ unset anchor
+ }
+ return $result
+}
+
+proc ::yaml::_mergeExpandedAliases {result pos prev} {
+ if {$result eq ""} {set result [huddle mapping]}
+ if {$prev ne ""} {
+ if {[llength $prev] < 2} {error [_getErrorMessage MALFORMED_MERGE_KEY]}
+ set result [_set_huddle_mapping $result $prev]
+ set prev {}
+ }
+
+ set value [_parseBlockNode "" $pos]
+ set type_name [huddle type $value]
+
+ if {$type_name eq "list" || $type_name eq "sequence"} {
+ set len [huddle llength $value]
+ for {set i 0} {$i < $len} {incr i} {
+ set sub [huddle get $value $i]
+ set result [huddle combine $result $sub]
+ }
+
+ } else {
+ set result [huddle combine $result $value]
+ }
+ return [list $result $prev]
+}
+
+proc ::yaml::_parseSubBlock {pos statusnew} {
+ upvar 1 status status
+ set scalar 0
+ set value ""
+ if {[_next_is_blank]} {
+ if {$statusnew ne ""} {
+ set status $statusnew
+ set value [_parseBlockNode "" $pos]
+ }
+ } else {
+ _ungetc
+ set scalar 1
+ }
+ return [list $scalar $value]
+}
+
+proc ::yaml::_set_huddle_mapping {result prev} {
+
+ foreach {key val} $prev break
+
+ set val [_composePlain $val]
+ if {[huddle isHuddle $key]} {
+ set key [huddle get_stripped $key]
+ }
+
+
+ if {$result eq ""} {
+ set result [huddle mapping $key $val]
+ } else {
+ huddle append result $key $val
+ }
+ return $result
+}
+
+
+# remove duplications with saving key order
+proc ::yaml::_remove_duplication {dict} {
+ array set tmp $dict
+ array set tmp2 {}
+ foreach {key nop} $dict {
+ if {[info exists tmp2($key)]} continue
+ lappend result $key $tmp($key)
+ set tmp2($key) 1
+ }
+ return $result
+}
+
+
+# literal "|" (line separator is "\n")
+# folding ">" (line separator is " ")
+proc ::yaml::_parseBlockScalar {base separator} {
+ foreach {explicit chomping} [_parseBlockIndicator] break
+
+ set idch [string repeat " " $explicit]
+ set sep $separator
+ foreach {indent c line} [_getLine] break
+ if {$indent < $base} {return ""}
+ # the first line, NOT ignored comment (as a normal-string)
+ set first $indent
+ set value $line
+ set stop 0
+
+ while {![_eof]} {
+ set pos [_getpos]
+ foreach {indent c line} [_getLine] break
+ if {$line eq ""} {
+ regsub " " $sep "" sep
+ append sep "\n"
+ continue
+ }
+ if {$c eq "#"} {
+ # skip comments
+ continue
+ }
+ if {$indent <= $base} {
+ set stop 1
+ break
+ }
+ append value $sep[string repeat " " [expr {$indent - $first}]]$line
+ set sep $separator
+ }
+ if {[info exists pos] && $stop} {_setpos $pos}
+ switch -- $chomping {
+ "strip" {
+ }
+ "keep" {
+ append value $sep
+ }
+ "clip" {
+ append value "\n"
+ }
+ default {
+ error "Should not be reached (chomping = $chomping)"
+ }
+ }
+ return [huddle wrap [list !!str $value]]
+}
+
+# in {> |}
+proc ::yaml::_parseBlockIndicator {} {
+ set chomping "clip"
+ set explicit 0
+ while {1} {
+ set type [_getc]
+ if {[regexp {[1-9]} $type digit]} { ; # block indentation
+ set explicit $digit
+ } elseif {$type eq "-"} { ; # strip chomping
+ set chomping "strip"
+ } elseif {$type eq "+"} { ; # keep chomping
+ set chomping "keep"
+ } else {
+ _ungetc
+ break
+ }
+ }
+ # Note: skipped after the indicator
+ _getLine
+ return [list $explicit $chomping]
+}
+
+# [162] ns-plain-multi(n,c)
+proc ::yaml::_parsePlainScalarInBlock {base {loop 0}} {
+ if {$loop == 5} { return }
+ variable data
+ set start $data(start)
+ set reStr {(?:[^:#\t \n]*(?::[^\t \n]+)*(?:#[^\t \n]+)* *)*[^:#\t \n]*}
+ set result [_getFoldedString $reStr]
+
+ set result [string trim $result]
+ set c [_getc 0]
+ if {$c eq "\n" || $c eq "#"} { ; # multi-line
+ set lb ""
+ while {1} {
+ set fpos [_getpos]
+ foreach {indent nop line} [_getLine] break
+ if {[_eof]} {break}
+
+ if {$line ne "" && [string index $line 0] ne "#"} {
+ break
+ }
+ append lb "\n"
+ }
+ set lb [string range $lb 1 end]
+ if {!$yaml::data(finished)} {
+ _setpos $fpos
+ }
+ if {$start == $data(start)} {
+ return $result
+ }
+ if {$base <= $indent} {
+ if {$lb eq ""} {
+ set lb " "
+ }
+ set subs [_parsePlainScalarInBlock $base [expr {$loop+1}]]
+ if {$subs ne ""} {
+ append result "$lb$subs"
+ }
+ }
+ }
+ return $result
+}
+
+####################
+# Flow Node parser
+####################
+proc ::yaml::_parseFlowNode {{status ""}} {
+ set scalar 0
+ set result {}
+ set tag ""
+ set prev {}
+ while {1} {
+ _skipSpaces 1
+ set type [_getc]
+ switch -- $type {
+ "" {
+ break
+ }
+ "?" -
+ ":" { ; # mapping value
+ if {[_next_is_blank]} {
+ set value [_parseFlowNode "NODE"]
+ } else {
+ set scalar 1
+ }
+ }
+ "," { ; # ends a flow collection entry
+ if {$status eq"NODE"} {
+ _ungetc
+ return $value
+ }
+ }
+ "\{" { ; # starts a flow mapping
+ set value [_parseFlowNode "MAPPING"]
+ }
+ "\}" { ; # ends a flow mapping
+ if {$status ne "MAPPING"} {error [_getErrorMessage MAPEND_NOT_IN_MAP] }
+ return $result
+ }
+ "\[" { ; # starts a flow sequence
+ set value [_parseFlowNode "SEQUENCE"]
+ }
+ "\]" { ; # ends a flow sequence
+ if {$status ne "SEQUENCE"} {error [_getErrorMessage SEQEND_NOT_IN_SEQ] }
+ set result [huddle sequence {*}$result]
+ return $result
+ }
+ "&" { ; # node's anchor property
+ set anchor [_getToken]
+ }
+ "*" { ; # alias node
+ set alias [_getToken]
+ set value [_getAnchor $alias]
+ }
+ "!" { ; # node's tag
+ _ungetc
+ set tag [_getToken]
+ }
+ "%" { ; # directive line
+ _ungetc
+ _parseDirective
+ }
+ default {
+ set scalar 1
+ }
+ }
+ if {$scalar} {
+ _ungetc
+ set value [_parseScalarNode $type "FLOW"]
+ set value [_composeTags $tag $value]
+ set tag ""
+ set scalar 0
+ }
+ if {[info exists value]} {
+ if {[info exists anchor]} {
+ _setAnchor $anchor $value
+ unset anchor
+ }
+ if {$status eq "" || $status eq "NODE"} {return $value}
+ foreach {result prev} [_pushValue $result $prev $status $value "FLOW"] break
+ unset value
+ }
+ }
+ return $result
+}
+
+proc ::yaml::_pushValue {result prev status value scope} {
+ switch -- $status {
+ "SEQUENCE" {
+ lappend result [_composePlain $value]
+ }
+ "MAPPING" {
+ if {$scope eq "BLOCK"} {
+ if {[llength $prev] == 2} {
+ set result [_set_huddle_mapping $result $prev]
+ set prev [list $value]
+ } else {
+ lappend prev $value
+ }
+ } else {
+ lappend prev $value
+ if {[llength $prev] == 2} {
+ set result [_set_huddle_mapping $result $prev]
+ set prev ""
+ }
+ }
+ }
+ default {
+ if {$scope eq "BLOCK"} {lappend prev $value}
+ }
+ }
+ return [list $result $prev]
+}
+
+proc ::yaml::_parseScalarNode {type scope {pos 0}} {
+ set tag !!str
+ switch -- $type {
+ \" { ; # surrounds a double-quoted flow scalar
+ set value [_parseDoubleQuoted]
+ }
+ {'} { ; # surrounds a single-quoted flow scalar
+ set value [_parseSingleQuoted]
+ }
+ "\t" {error [_getErrorMessage TAB_IN_PLAIN] }
+ "@" {error [_getErrorMessage AT_IN_PLAIN] }
+ "`" {error [_getErrorMessage BT_IN_PLAIN] }
+ default {
+ # Plane Scalar
+ if {$scope eq "FLOW"} {
+ set value [_parsePlainScalarInFlow]
+ } elseif {$scope eq "BLOCK"} {
+ set value [_parsePlainScalarInBlock $pos]
+ }
+ set tag !!plain
+ }
+ }
+ return [huddle wrap [list $tag $value]]
+}
+
+# [time scanning at JST]
+# 2001-12-15T02:59:43.1Z => 1008385183
+# 2001-12-14t21:59:43.10-05:00 => 1008385183
+# 2001-12-14 21:59:43.10 -5 => 1008385183
+# 2001-12-15 2:59:43.10 => 1008352783
+# 2002-12-14 => 1039791600
+proc ::yaml::_parseTimestamp {scalar} {
+ if {![regexp {^\d\d\d\d-\d\d-\d\d} $scalar]} {return ""}
+ set datestr {\d\d\d\d-\d\d-\d\d}
+ set timestr {\d\d?:\d\d:\d\d}
+ set timezone {Z|[-+]\d\d?(?::\d\d)?}
+
+ set canonical [subst -nobackslashes -nocommands {^($datestr)[Tt ]($timestr)\.\d+ ?($timezone)?$}]
+ set dttm [subst -nobackslashes -nocommands {^($datestr)(?:[Tt ]($timestr))?$}]
+ if {$::tcl_version < 8.5} {
+ if {[regexp $canonical $scalar nop dt tm zone]} {
+ # Canonical
+ if {$zone eq ""} {
+ return [list !!timestamp [clock scan "$dt $tm"]]
+ } elseif {$zone eq "Z"} {
+ return [list !!timestamp [clock scan "$dt $tm" -gmt 1]]
+ }
+ if {[regexp {^([-+])(\d\d?)$} $zone nop sign d]} {set zone [format "$sign%02d:00" $d]}
+ regexp {^([-+]\d\d):(\d\d)} $zone nop h m
+ set m [expr {$h > 0 ? $h*60 + $m : $h*60 - $m}]
+ return [list !!timestamp [clock scan "[expr {-$m}] minutes" -base [clock scan "$dt $tm" -gmt 1]]]
+ } elseif {[regexp $dttm $scalar nop dt tm]} {
+ if {$tm ne ""} {
+ return [list !!timestamp [clock scan "$dt $tm"]]
+ } else {
+ return [list !!timestamp [clock scan $dt]]
+ }
+ }
+ } else {
+ if {[regexp $canonical $scalar nop dt tm zone]} {
+ # Canonical
+ if {$zone ne ""} {
+ if {[regexp {^([-+])(\d\d?)$} $zone nop sign d]} {set zone [format "$sign%02d:00" $d]}
+ return [list !!timestamp [clock scan "$dt $tm $zone" -format {%Y-%m-%d %k:%M:%S %Z}]]
+ } else {
+ return [list !!timestamp [clock scan "$dt $tm" -format {%Y-%m-%d %k:%M:%S}]]
+ }
+ } elseif {[regexp $dttm $scalar nop dt tm]} {
+ if {$tm ne ""} {
+ return [list !!timestamp [clock scan "$dt $tm" -format {%Y-%m-%d %k:%M:%S}]]
+ } else {
+ return [list !!timestamp [clock scan $dt -format {%Y-%m-%d}]]
+ }
+ }
+ }
+ return ""
+}
+
+
+proc ::yaml::_parseDirective {} {
+ variable data
+ variable shorthands
+
+ set directive [_getToken]
+
+ if {[regexp {^%YAML} $directive]} {
+ # YAML directive
+ _skipSpaces
+ set version [_getToken]
+ set data(YAMLVersion) $version
+ if {![regexp {^\d\.\d$} $version]} { error [_getErrorMessage ILLEGAL_YAML_DIRECTIVE] }
+ } elseif {[regexp {^%TAG} $directive]} {
+ # TAG directive
+ _skipSpaces
+ set handle [_getToken]
+ if {![regexp {^!$|^!\w*!$} $handle]} { error [_getErrorMessage ILLEGAL_YAML_DIRECTIVE] }
+
+ _skipSpaces
+ set prefix [_getToken]
+ if {![regexp {^!$|^!\w*!$} $prefix]} { error [_getErrorMessage ILLEGAL_YAML_DIRECTIVE] }
+ set shorthands(handle) $prefix
+ }
+}
+
+proc ::yaml::_parseTagHandle {} {
+ set token [_getToken]
+
+ if {[regexp {^(!|!\w*!)(.*)} $token nop handle named]} {
+ # shorthand or non-specific Tags
+ switch -- $handle {
+ ! { ; # local or non-specific Tags
+ }
+ !! { ; # yaml Tags
+ }
+ default { ; # shorthand Tags
+
+ }
+ }
+ if {![info exists prefix($handle)]} { error [_getErrorMessage TAG_NOT_FOUND] }
+ } elseif {[regexp {^!<(.+)>} $token nop uri]} {
+ # Verbatim Tags
+ if {![regexp {^[\w:/]$} $token nop uri]} { error [_getErrorMessage ILLEGAL_TAG_HANDLE] }
+ } else {
+ error [_getErrorMessage ILLEGAL_TAG_HANDLE]
+ }
+
+ return "!<$prefix($handle)$named>"
+}
+
+
+proc ::yaml::_parseDoubleQuoted {} {
+ # capture quoted string with backslash sequences
+ set reStr {(?:(?:\")(?:[^\\\"]*(?:\\.[^\\\"]*)*)(?:\"))}
+ set result [_getFoldedString $reStr]
+ if {$result eq ""} { error [_getErrorMessage MALFORM_D_QUOTE] }
+
+ # [116] nb-double-multi-line
+ regsub -all {[ \t]*\n[\t ]*} $result "\r" result
+ regsub -all {([^\r])\r} $result {\1 } result
+ regsub -all { ?\r} $result "\n" result
+ # [112] s-s-double-escaped(n)
+ # is not impremented.(specification ???)
+
+ # chop off outer ""s and substitute backslashes
+ # This does more than the RFC-specified backslash sequences,
+ # but it does cover them all
+ set chopped [subst -nocommands -novariables \
+ [string range $result 1 end-1]]
+ return $chopped
+}
+
+proc ::yaml::_parseSingleQuoted {} {
+ set reStr {(?:(?:')(?:[^']*(?:''[^']*)*)(?:'))}
+ set result [_getFoldedString $reStr]
+ if {$result eq ""} { error [_getErrorMessage MALFORM_S_QUOTE] }
+
+ # [126] nb-single-multi-line
+ regsub -all {[ \t]*\n[\t ]*} $result "\r" result
+ regsub -all {([^\r])\r} $result {\1 } result
+ regsub -all { ?\r} $result "\n" result
+
+ regsub -all {''} [string range $result 1 end-1] {'} chopped
+
+ return $chopped
+}
+
+
+# [155] nb-plain-char-in
+proc ::yaml::_parsePlainScalarInFlow {} {
+ set sep {\t \n,\[\]\{\}}
+ set reStr {(?:[^$sep:#]*(?::[^$sep]+)*(?:#[^$sep]+)* *)*[^$sep:#]*}
+ set reStr [subst -nobackslashes -nocommands $reStr]
+ set result [_getFoldedString $reStr]
+ set result [string trim $result]
+
+ if {[_getc 0] eq "#"} {
+ _getLine
+ set result "$result [_parsePlainScalarInFlow]"
+ }
+ return $result
+}
+
+####################
+# Generic parser
+####################
+proc ::yaml::_getFoldedString {reStr} {
+ variable data
+
+ set buff [string range $data(buffer) $data(start) end]
+ regexp $reStr $buff token
+ if {![info exists token]} {return}
+
+ set len [string length $token]
+ if {[string first "\n" $token] >= 0} { ; # multi-line
+ set data(current) [expr {$len - [string last "\n" $token]}]
+ } else {
+ incr data(current) $len
+ }
+ incr data(start) $len
+
+ return $token
+}
+
+# get a space separated token
+proc ::yaml::_getToken {} {
+ variable data
+
+ set reStr {^[^ \t\n,\]]+}
+ set result [_getFoldedString $reStr]
+ return $result
+}
+
+proc ::yaml::_skipSpaces {{commentSkip 0}} {
+ variable data
+
+ while {1} {
+ set ch [string index $data(buffer) $data(start)]
+ incr data(start)
+ switch -- $ch {
+ " " {
+ incr data(current)
+ continue
+ }
+ "\n" {
+ set data(current) 0
+ continue
+ }
+ "\#" {
+ if {$commentSkip} {
+ _getLine
+ continue
+ }
+ }
+ default {
+ # Any other character, do nothing
+ }
+ }
+ break
+ }
+ incr data(start) -1
+}
+
+# get a line of stream(line-end trimed)
+# (cannot _ungetc)
+proc ::yaml::_getLine {{scrolled 1}} {
+ variable data
+
+ set pos [string first "\n" $data(buffer) $data(start)]
+ if {$pos == -1} {
+ set pos $data(length)
+ }
+ set line [string range $data(buffer) $data(start) [expr {$pos-1}]]
+ if {$line eq "..." && $data(current) == 0} {
+ set data(finished) 1
+ }
+ regexp {^( *)(.*)} $line nop space result
+ if {$scrolled} {
+ set data(start) [expr {$pos + 1}]
+ set data(current) 0
+ }
+ if {$line == "" && $data(start) == $data(length)} {
+ set data(finished) 1
+ }
+ return [list [string length $space] [string index $result 0] $result]
+}
+
+proc ::yaml::_getCurrent {} {
+ variable data
+ return [expr {$data(current) ? $data(current)-1 : 0}]
+}
+
+proc ::yaml::_getLineNum {} {
+ variable data
+ set prev [string range $data(buffer) 0 $data(start)]
+ return [llength [split $prev "\n"]]
+}
+
+proc ::yaml::_getc {{scrolled 1}} {
+ variable data
+
+ set result [string index $data(buffer) $data(start)]
+ if {$scrolled} {
+ incr data(start)
+ if {$result eq "\n"} {
+ set data(current) 0
+ } else {
+ incr data(current)
+ }
+ }
+ return $result
+}
+
+proc ::yaml::_eof {} {
+ variable data
+ return [expr {$data(finished) || $data(start) == $data(length)}]
+}
+
+
+proc ::yaml::_getpos {} {
+ variable data
+ return $data(start)
+}
+
+proc ::yaml::_setpos {pos} {
+ variable data
+ set data(start) $pos
+}
+
+proc ::yaml::_ungetc {{len 1}} {
+ variable data
+ incr data(start) [expr {-$len}]
+ incr data(current) [expr {-$len}]
+ if {$data(current) < 0} {
+ set prev [string range $data(buffer) 0 $data(start)]
+ if {[string index $prev end] eq "\n"} {set prev [string replace $prev end end a]}
+ set data(current) [expr {$data(start) - [string last "\n" $prev] - 1}]
+ }
+}
+
+proc ::yaml::_next_is_blank {} {
+ set c [_getc 0]
+ if {$c eq " " || $c eq "\n"} {
+ return 1
+ } else {
+ return 0
+ }
+}
+
+proc ::yaml::_setAnchor {anchor value} {
+ variable data
+ set data(anchor:$anchor) $value
+}
+
+proc ::yaml::_getAnchor {anchor} {
+ variable data
+ if {![info exists data(anchor:$anchor)]} {error [_getErrorMessage ANCHOR_NOT_FOUND]}
+ return $data(anchor:$anchor)
+}
+
+proc ::yaml::_getErrorMessage {ID {p1 ""}} {
+ set num [_getLineNum]
+ if {$p1 != ""} {
+ return "line($num): [subst -nobackslashes -nocommands $yaml::errors($ID)]"
+ } else {
+ return "line($num): $yaml::errors($ID)"
+ }
+}
+
+# Finds and returns the indentation of a YAML line
+proc ::yaml::_getIndent {line} {
+ set match [regexp -inline -- {^\s{1,}} " $line"]
+ return [expr {[string length $match] - 3}]
+}
+
+
+################
+## Dumpers ##
+################
+
+proc ::yaml::_imp_huddle2yaml {data {offset ""}} {
+ set nextoff "$offset[string repeat { } $yaml::_dumpIndent]"
+ switch -- [huddle type $data] {
+ "string" {
+ set data [huddle get_stripped $data]
+ return [_dumpScalar $data $offset]
+ }
+ "list" {
+ set inner {}
+ set len [huddle llength $data]
+ for {set i 0} {$i < $len} {incr i} {
+ set sub [huddle get $data $i]
+ set sep [expr {[huddle type $sub] eq "string" ? " " : "\n"}]
+ lappend inner [join [list $offset - $sep [_imp_huddle2yaml $sub $nextoff]] ""]
+ }
+ return [join $inner "\n"]
+ }
+ "dict" {
+ set inner {}
+ foreach {key} [huddle keys $data] {
+ set sub [huddle get $data $key]
+ set sep [expr {[huddle type $sub] eq "string" ? " " : "\n"}]
+ lappend inner [join [list $offset $key: $sep [_imp_huddle2yaml $sub $nextoff]] ""]
+ }
+ return [join $inner "\n"]
+ }
+ default {
+ return $data
+ }
+ }
+}
+
+proc ::yaml::_dumpScalar {value offset} {
+ if { [string first "\n" $value] >= 0
+ || [string first ": " $value] >= 0
+ || [string first "- " $value] >= 0} {
+ return [_doLiteralBlock $value $offset]
+ } else {
+ return [_doFolding $value $offset]
+ }
+}
+
+# Creates a literal block for dumping
+proc ::yaml::_doLiteralBlock {value offset} {
+ if {[string index $value end] eq "\n"} {
+ set newValue "|"
+ set value [string range $value 0 end-1]
+ } else {
+ set newValue "|-"
+ }
+ set exploded [split $value "\n"]
+
+ set value [string trimright $value]
+ foreach {line} $exploded {
+ set newValue "$newValue\n$offset[string trim $line]"
+ }
+ return $newValue
+}
+
+# Folds a string of text, if necessary
+proc ::yaml::_doFolding {value offset} {
+ variable _dumpWordWrap
+ # Don't do anything if wordwrap is set to 0
+ if {$_dumpWordWrap == 0} {
+ return $value
+ }
+
+ if {[string length $value] > $_dumpWordWrap} {
+ set wrapped [_simple_justify $value $_dumpWordWrap "\n$offset"]
+ set value ">\n$offset$wrapped"
+ }
+ return $value
+}
+
+# http://wiki.tcl.tk/1774
+proc ::yaml::_simple_justify {text width {wrap \n} {cut 0}} {
+ set brk ""
+ for {set result {}} {[string length $text] > $width} {
+ set text [string range $text [expr {$brk+1}] end]
+ } {
+ set brk [string last " " $text $width]
+ if { $brk < 0 } {
+ if {$cut == 0} {
+ append result $text
+ return $result
+ } else {
+ set brk $width
+ }
+ }
+ append result [string range $text 0 $brk] $wrap
+ }
+ return $result$text
+}
+
+########################
+## YAML TYPES ##
+########################
+
+namespace eval ::yaml::types {
+ namespace eval mapping {
+ variable settings
+ set settings {
+ superclass dict
+ publicMethods {mapping}
+ tag !!map
+ isContainer yes }
+
+ proc mapping {args} {
+ if {[llength $args] % 2} {error {wrong # args: should be "huddle mapping ?key value ...?"}}
+ set resultL {}
+ foreach {key value} $args {
+ lappend resultL $key [argument_to_node $value !!str]
+ }
+ return [huddle wrap [list !!map $resultL]]
+ }
+
+ }
+
+ namespace eval sequence {
+ variable settings
+
+ set settings {
+ superclass list
+ publicMethods {sequence}
+ isContainer yes
+ tag !!seq
+ }
+
+ proc sequence {args} {
+ set resultL {}
+ foreach {value} $args {
+ lappend resultL [argument_to_node $value !!str]
+ }
+ return [wrap [list !!seq $resultL]]
+ }
+
+ }
+}
+
+proc ::yaml::_makeChildType {type tag} {
+ set full_path_to_type ::yaml::types::$type
+ namespace eval $full_path_to_type [string map [list @TYPE@ $type @TAG@ $tag] {
+ variable settings
+ set settings {
+ superClass string
+ publicMethods {}
+ isContainer no
+ tag @TAG@
+ }
+ }]
+
+ return $full_path_to_type
+}
+
+huddle addType ::yaml::types::mapping
+huddle addType ::yaml::types::sequence
+
+huddle addType [::yaml::_makeChildType str !!str]
+huddle addType [::yaml::_makeChildType timestamp !!timestamp]
+huddle addType [::yaml::_makeChildType float !!float]
+huddle addType [::yaml::_makeChildType int !!int]
+huddle addType [::yaml::_makeChildType null !!null]
+huddle addType [::yaml::_makeChildType true !!true]
+huddle addType [::yaml::_makeChildType false !!false]
+huddle addType [::yaml::_makeChildType binary !!binary]
+huddle addType [::yaml::_makeChildType plain !!plain]
+
+
diff --git a/tcllib/modules/yaml/yaml.test b/tcllib/modules/yaml/yaml.test
new file mode 100644
index 0000000..40820bd
--- /dev/null
+++ b/tcllib/modules/yaml/yaml.test
@@ -0,0 +1,775 @@
+# -*- tcl -*-
+# yaml.test: tests for the yaml library.
+#
+# Copyright (c) 2008 by KATO Kanryu <kanryu6@users.sourceforge.net>
+# All rights reserved.
+#
+
+
+if {[lsearch [namespace children] ::tcltest] == -1} {
+ # single test
+ set selfrun 1
+# lappend auto_path [pwd]
+ set auto_path [linsert $auto_path 0 [pwd]]
+ package require tcltest
+ namespace import ::tcltest::*
+ puts [package require yaml]
+
+} else {
+ # all.tcl
+ source [file join \
+ [file dirname [file dirname [file join [pwd] [info script]]]] \
+ devtools testutilities.tcl]
+
+ testsNeedTcl 8.5
+ testsNeedTcltest 2
+
+ support {
+ use json/json.tcl json
+ useLocal huddle.tcl huddle
+ }
+ testing {
+ useLocal yaml.tcl yaml
+ }
+}
+proc dictsort2 {dict {pattern d}} {
+ set cur [lindex $pattern 0]
+ set subs [lrange $pattern 1 end]
+ foreach {tag sw} $cur break
+ set out {}
+ if {$sw ne ""} {array set msubs $sw}
+ if {$tag eq "l"} { ; # list
+ set i 0
+ foreach {node} $dict {
+ set subs1 $subs
+ if {$sw ne "" && [info exists msubs($i)]} {
+ set subs1 $msubs($i)
+ }
+ if {$subs1 ne ""} {
+ set node [dictsort2 $node $subs1]
+ }
+ lappend out $node
+ incr i
+ }
+ return $out
+ }
+ if {$tag eq "d"} { ; # dict
+ array set map $dict
+ foreach key [lsort [array names map]] {
+ set node $map($key)
+ set subs1 $subs
+ if {$sw ne "" && [info exists msubs($key)]} {
+ set subs1 $msubs($key)
+ }
+ if {$subs1 ne ""} {
+ set node [dictsort2 $node $subs1]
+ }
+ lappend out $key $node
+ }
+ return $out
+ }
+ error
+}
+
+# ------------
+
+test yaml-21.0.06eef112da {ticket 06eef112da} -body {
+ yaml::yaml2dict -file [localPath 06eef112da.data]
+} -result {{} {} {alpha 43 beta {houston {{}} newyork {{{} aaa}}}}}
+
+# ------------
+# error .....
+
+test yaml-1.1 "error" -body {
+ set error1 {
+---
+- [name , \{hr: avg \[\hr: avg\} \] ]
+}
+ set code [catch {yaml::yaml2dict $error1} msg]
+ concat $code $msg
+} -result [concat 1 line(3): $yaml::errors(MAPEND_NOT_IN_MAP)]
+
+test yaml-1.2 "error" -body {
+ set error2 {
+---
+- [name , \[hr: avg \{\hr: avg\] \} ]
+}
+ set code [catch {yaml::yaml2dict $error2} msg]
+ concat $code $msg
+} -result [concat 1 line(3): $yaml::errors(SEQEND_NOT_IN_SEQ)]
+
+test yaml-1.3 "error" -body {
+ set error3 {
+---
+- Clark
+- @Brian
+}
+ set code [catch {yaml::yaml2dict $error3} msg]
+ concat $code $msg
+} -result [concat 1 line(4): $yaml::errors(AT_IN_PLAIN)]
+
+test yaml-1.4 "error" -body {
+ set error4 {
+---
+- Clark
+- `Brian
+}
+ set code [catch {yaml::yaml2dict $error4} msg]
+ concat $code $msg
+} -result [concat 1 line(4): $yaml::errors(BT_IN_PLAIN)]
+
+test yaml-1.5 "error" -body {
+ set error5 {
+---
+- Clark
+- Brian
+}
+ set code [catch {yaml::yaml2dict $error5} msg]
+ concat $code $msg
+} -result [concat 1 line(4): $yaml::errors(TAB_IN_PLAIN)]
+
+test yaml-1.6 "error" -body {
+ set error6 {
+---
+- *a
+- Brian
+- @a Geoge
+}
+ set code [catch {yaml::yaml2dict $error6} msg]
+ concat $code $msg
+} -result [concat 1 line(4): $yaml::errors(ANCHOR_NOT_FOUND)]
+
+test yaml-1.7 "error" -body {
+ set error7 {
+---
+- "Clark
+- Brian
+}
+ set code [catch {yaml::yaml2dict $error7} msg]
+ concat $code $msg
+} -result [concat 1 line(3): $yaml::errors(MALFORM_D_QUOTE)]
+
+test yaml-1.8 "error" -body {
+ set error8 {
+---
+- 'Clark
+- Brian
+}
+ set code [catch {yaml::yaml2dict $error8} msg]
+ concat $code $msg
+} -result [concat 1 line(3): $yaml::errors(MALFORM_S_QUOTE)]
+
+test yaml-1.9 "error" -body {
+ set error9 {
+---
+- !!invalidtag Clark
+- Brian
+}
+ set code [catch {yaml::yaml2dict $error9} msg]
+ concat $code $msg
+} -result [concat 1 {line(4): The "!!invalidtag" handle wasn't declared.}]
+
+test yaml-1.10 "error" -body {
+ set error10 {
+---
+- Clark
+<<
+ - Brian
+}
+ set code [catch {yaml::yaml2dict $error10} msg]
+ concat $code $msg
+} -result [concat 1 line(5): $yaml::errors(INVALID_MERGE_KEY)]
+
+
+
+# -----------
+# flow .....
+
+
+test yaml-2.1 "flow sequence" -body {
+ set inline_seq_seqs {
+---
+- [name , hr, avg ]
+- [Mark McGwire, 65, 0.278]
+- [Sammy Sosa , 63, 0.288]
+...
+- [Sammy Sosa2 , 64, 0.388]
+}
+ yaml::yaml2dict $inline_seq_seqs
+} -result {{name hr avg} {{Mark McGwire} 65 0.278} {{Sammy Sosa} 63 0.288}}
+
+test yaml-2.2 "flow mappings" -body {
+ set inline_map_maps {
+---
+Mark McGwire: {hr: 65, avg: 0.278}
+Sammy Sosa: { hr: 63, avg: 0.288}
+}
+ dictsort2 [yaml::yaml2dict $inline_map_maps] {d d}
+} -result [dictsort2 {{Mark McGwire} {hr 65 avg 0.278} {Sammy Sosa} {hr 63 avg 0.288}} {d d}]
+
+test yaml-2.3 "flow mappings" -body {
+ set inline_map_maps {
+---
+? Mark McGwire: {? hr: 65, ? avg: 0.278}
+? Sammy Sosa
+: {? hr: 63, ? avg: 0.288}
+}
+ dictsort2 [yaml::yaml2dict $inline_map_maps] {d d}
+} -result [dictsort2 {{Mark McGwire} {hr 65 avg 0.278} {Sammy Sosa} {hr 63 avg 0.288}} {d d}]
+
+
+# ------------------
+# block nodes .....
+
+
+test yaml-3.2 "Literal Block Scalar" -body {
+ set literal {
+---
+clipped: | # comment
+ This has one newline.
+ # comment
+
+
+same as "clipped" above: "This has one newline.\n" # comment
+
+stripped: |- # comment
+ This has no newline.
+
+
+
+same as "stripped" above: "This has no newline." # comment
+kept: |+
+ This has four newlines.
+
+
+
+same as "kept" above: "This has four newlines.\n\n\n\n"
+}
+ dictsort2 [yaml::yaml2dict $literal]
+} -result [dictsort2 {clipped {This has one newline.
+} {same as "clipped" above} {This has one newline.
+} stripped {This has no newline.} {same as "stripped" above} {This has no newline.} kept {This has four newlines.
+
+
+
+} {same as "kept" above} {This has four newlines.
+
+
+
+}}]
+
+test yaml-3.3 "Folding Block Scalar" -body {
+ set folding {
+---
+clipped: >
+ This
+ has one newline.
+
+
+
+same as "clipped" above: "This has one newline.\n"
+
+stripped: >-
+ This
+ has
+ no newline.
+
+
+
+same as "stripped" above: "This has no newline."
+
+kept: >+
+ This
+ has
+ no newline.
+
+
+
+same as "kept" above: "This has four newlines.\n\n\n\n"}
+
+ dictsort2 [yaml::yaml2dict $folding]
+} -result [dictsort2 {clipped {This has one newline.
+} {same as "clipped" above} {This has one newline.
+} stripped {This has no newline.} {same as "stripped" above} {This has no newline.} kept {This has no newline.
+
+
+} {same as "kept" above} {This has four newlines.
+
+
+
+}}]
+
+test yaml-3.4 "Folded Block as a Mapping Value" -body {
+ set foldedmap {
+---
+quote: >
+ Mark McGwire's
+ year was crippled
+ by a knee injury.
+source: espn
+}
+ yaml::yaml2dict $foldedmap
+} -result [dict create quote {Mark McGwire's year was crippled by a knee injury.
+} source espn]
+
+# -----------------------
+# Anchor - Aliaces .....
+
+test yaml-4.1 "Alias Node" -body {
+ set alias {
+---
+- &showell Steve
+- Clark
+- Brian
+- Oren
+- *showell
+}
+ yaml::yaml2dict $alias
+} -result {Steve Clark Brian Oren Steve}
+
+test yaml-4.2 "Alias Node" -body {
+ set alias2 {
+---
+- &hello
+ Meat: pork
+ Starch: potato
+- banana
+- *hello
+}
+ yaml::yaml2dict $alias2
+} -result [list [dict create Meat pork Starch potato] banana [dict create Meat pork Starch potato]]
+
+test yaml-4.3 "Flow Alias Node" -body {
+ set alias3 {
+---
+- &hello
+ { Meat: &meat pork,
+ Starch: potato }
+- banana
+- *hello
+- &bye
+ [ The last man, children, *meat ]
+- habana
+- *bye
+}
+ dictsort2 [yaml::yaml2dict $alias3] {{l {0 d 2 d}}}
+} -result [dictsort2 {{Meat pork Starch potato} banana {Meat pork Starch potato} {{The last man} children pork} habana {{The last man} children pork}} \
+{{l {0 d 2 d}}} ]
+
+# -----------------------
+# Plane Characters .....
+
+
+test yaml-5.1 "Plane Characters" -body {
+ set plane_characters {
+---
+# Outside flow collection:
+- ::std::vector
+- Up, up and away!
+- -123
+# Inside flow collection:
+- [ ::std::vector,
+ "Up, up and away!",
+ -123 ]
+}
+ yaml::yaml2dict $plane_characters
+} -result {::std::vector {Up, up and away!} -123 {::std::vector {Up, up and away!} -123}}
+
+test yaml-5.2 "boolean" -body {
+ set boolean {
+---
+india:
+ pork : yes
+ beef : n
+ oil : off
+ polytheism : true
+arabia:
+ pork : no
+ beef : y
+ oil : on
+ polytheism : false
+}
+ dictsort2 [yaml::yaml2dict $boolean] {d d}
+} -result [dictsort2 {india {pork 1 beef 0 oil 0 polytheism 1} arabia {pork 0 beef 1 oil 1 polytheism 0}} {d d}]
+
+if {$::tcl_version < 8.5} {
+ test yaml-5.3 "Timestamps" -body {
+ set timestamps {
+- 2001-12-15T02:59:43.1Z
+- 2001-12-14t21:59:43.10-05:00
+- 2001-12-14 21:59:43.10 -5
+- 2001-12-15 2:59:43.10
+- 2002-12-14
+}
+
+ yaml::yaml2dict $timestamps
+ } -result [list \
+ [clock scan "2001-12-15 02:59:43" -gmt 1] \
+ [clock scan "+5 hours" -base [clock scan "2001-12-14 21:59:43" -gmt 1]] \
+ [clock scan "+5 hours" -base [clock scan "2001-12-14 21:59:43" -gmt 1]] \
+ [clock scan "2001-12-15 02:59:43"] \
+ [clock scan "2002-12-14"]
+ ]
+} else {
+ test yaml-5.3 "Timestamps" -body {
+ set timestamps {
+- 2001-12-15T02:59:43.1Z
+- 2001-12-14t21:59:43.10-05:00
+- 2001-12-14 21:59:43.10 -5
+- 2001-12-15 2:59:43.10
+- 2002-12-14
+}
+
+ yaml::yaml2dict $timestamps
+ } -result [list \
+ [clock scan "2001-12-15 02:59:43 Z" -format {%Y-%m-%d %k:%M:%S %Z}] \
+ [clock scan "2001-12-14 21:59:43 -05:00" -format {%Y-%m-%d %k:%M:%S %Z}] \
+ [clock scan "2001-12-14 21:59:43 -05:00" -format {%Y-%m-%d %k:%M:%S %Z}] \
+ [clock scan "2001-12-15 02:59:43" -format {%Y-%m-%d %k:%M:%S}] \
+ [clock scan "2002-12-14" -format {%Y-%m-%d}]
+ ]
+}
+# {1008385183 1008385183 1008385183 1008352783 1039791600} <- JST
+
+test yaml-5.4 "integer" -body {
+ set integers {
+- 1
+- 1000
+- 100,000,000
+}
+ yaml::yaml2dict $integers
+} -result {1 1000 100000000}
+
+
+
+# -----------
+# block .....
+
+test yaml-6.1 "block sequences" -body {
+ set sequences {
+---
+-
+ - Mark McGwire^---
+ - Sammy Sosa
+-
+ - Sammy Sosa
+ - Ken Griffey
+}
+
+ yaml::yaml2dict $sequences
+} -result {{{Mark McGwire^---} {Sammy Sosa}} {{Sammy Sosa} {Ken Griffey}}}
+
+test yaml-6.2 "block mapping" -body {
+ set mappings {
+---
+bill-to:
+ given : Chris
+ family : Dumars
+hello-to:
+ given : Arnold Berry
+ family : Son
+}
+ yaml::yaml2dict $mappings
+} -result [dict create bill-to [dict create given Chris family Dumars] hello-to [dict create given {Arnold Berry} family Son]]
+
+test yaml-6.3 "block mapping, sequence" -body {
+ set map_seqs {
+---
+hr: # 1998 hr ranking
+ - Mark McGwire
+ - Sammy Sosa
+rbi:
+ # 1998 rbi ranking
+ - Sammy Sosa
+ - Ken Griffey
+}
+ yaml::yaml2dict $map_seqs
+} -result [dict create hr {{Mark McGwire} {Sammy Sosa}} rbi {{Sammy Sosa} {Ken Griffey}}]
+
+test yaml-6.4 "block sequence, mapping" -body {
+ set seq_maps {
+---
+-
+ name: Mark McGwire
+ hr: 65
+ avg: 0.278
+-
+ name: Sammy Sosa
+ hr: 63
+ avg: 0.288
+}
+ yaml::yaml2dict $seq_maps
+} -result [list [dict create name {Mark McGwire} hr 65 avg 0.278] [dict create name {Sammy Sosa} hr 63 avg 0.288]]
+
+test yaml-6.5 "block mapping, noheader" -body {
+ set maps {bar:
+ fruit: apple
+ name: steve
+ sport: baseball
+}
+ dictsort2 [yaml::yaml2dict $maps] {d d}
+} -result [dictsort2 {bar {sport baseball name steve fruit apple}} {d d}]
+
+test yaml-6.6 "block mapping, with empty" -body {
+ set maps {foo:
+some: value
+}
+ dictsort2 [yaml::yaml2dict $maps] {d}
+} -result [dictsort2 {foo {} some value} {d}]
+
+test yaml-6.7 "block mapping, with empty sequence" -body {
+ set maps {foo: []
+some: value
+}
+ dictsort2 [yaml::yaml2dict $maps] {d}
+} -result [dictsort2 {foo {} some value} {d}]
+
+
+
+
+
+# --------------
+# options .....
+
+
+test yaml-7.1 "load from file" -body {
+ set data [yaml::yaml2dict -file [file join [file dirname [info script]] CHANGES]]
+ dict get $data title
+} -result {YAML parser for Tcl.}
+
+test yaml-7.2 "load from file" -body {
+ yaml::setOptions -file
+ set data [yaml::yaml2dict [file join [file dirname [info script]] CHANGES]]
+ yaml::setOptions -stream
+ dict get $data title
+} -result {YAML parser for Tcl.}
+
+
+# -----------------
+# flow nodes .....
+
+test yaml-8.1 "double quote" -body {
+ set dquote {
+- "1st non-empty,
+
+ 2nd non-empty,
+ 3rd non-empty"
+}
+ yaml::yaml2dict $dquote
+} -result {{1st non-empty,
+2nd non-empty, 3rd non-empty}}
+
+
+test yaml-8.2 "single quote" -body {
+ set squote {
+- '1st non-empty,
+
+ 2nd ''non-empty'',
+ 3rd non-empty'
+}
+
+ yaml::yaml2dict $squote
+} -result {{1st non-empty,
+2nd 'non-empty', 3rd non-empty}}
+
+package require base64
+test yaml-9.1 "explicit_tags binary" -body {
+ set explicit_tags {
+---
+not-date: !!str 2002-04-28
+picture: !!binary |
+ R0lGODlhDAAMAIQAAP//9/X
+ 17unp5WZmZgAAAOfn515eXv
+ Pz7Y6OjuDg4J+fn5OTk6enp
+ 56enmleECcgggoBADs=
+
+}
+
+ yaml::yaml2dict $explicit_tags
+} -result [dict create not-date 2002-04-28 picture [::base64::decode {
+R0lGODlhDAAMAIQAAP//9/X
+17unp5WZmZgAAAOfn515eXv
+Pz7Y6OjuDg4J+fn5OTk6enp
+56enmleECcgggoBADs=
+}]]
+
+test yaml-9.2 "explicit_tags(inline)" -body {
+ set explicit_tags {
+---
+{not-date: !!str 2002-04-28,
+ picture: !!binary
+ "R0lGODlhDAAMAIQAAP//9/X
+ 17unp5WZmZgAAAOfn515eXv
+ Pz7Y6OjuDg4J+fn5OTk6enp
+ 56enmleECcgggoBADs="
+}
+}
+
+ dictsort2 [yaml::yaml2dict $explicit_tags]
+} -result [dictsort2 [list not-date 2002-04-28 picture [::base64::decode {
+R0lGODlhDAAMAIQAAP//9/X
+17unp5WZmZgAAAOfn515eXv
+Pz7Y6OjuDg4J+fn5OTk6enp
+56enmleECcgggoBADs=
+} ]] ]
+
+test yaml-10.1 "Merge key" -body {
+ set merge1 {
+---
+mapping:
+ name: Joe
+ job: Accountant
+ <<:
+ age: 38
+}
+ dictsort2 [yaml::yaml2dict $merge1] {d d}
+} -result [dictsort2 {mapping {name Joe job Accountant age 38}} {d d}]
+
+test yaml-10.2 "Merge key 2" -body {
+ set merge2 {
+---
+- &CENTER { x: 1, y: 2 }
+- &LEFT { x: 0, y: 2 }
+- &BIG { r: "spaced string" }
+- &SMALL { r: 1 }
+
+# All the following maps are equal:
+
+- # Explicit keys
+ x: 1
+ y: 2
+ r: 10
+ label: base
+
+- # Merge one map
+ << : *CENTER
+ r: 10
+ label: center
+
+- # Merge multiple maps
+ << : [ *CENTER, *BIG ]
+ label: center/big
+
+- # Override
+ << : [ *BIG, *LEFT, *SMALL ]
+ x: 1
+ label: big/left/small
+}
+ yaml::yaml2dict $merge2
+} -result [list {x 1 y 2} {x 0 y 2} {r {spaced string}} {r 1} \
+ [dict create x 1 y 2 r 10 label base] \
+ [dict create x 1 y 2 r 10 label center] \
+ [dict create x 1 y 2 r {spaced string} label center/big] \
+ [dict create r 1 x 1 y 2 label big/left/small]]
+
+test yaml-11.1 "Invoice" -body {
+ set Invoice {
+--- # !<tag:clarkevans.com,2002:invoice>
+invoice: 34843
+date : 2001-01-23
+bill-to: &id001
+ given : Chris
+ family : Dumars
+ address:
+ lines: |
+ 458 Walkman Dr.
+ Suite #292
+ city : Royal Oak
+ state : MI
+ postal : 48046
+ship-to: *id001
+product:
+ - sku : BL394D
+ quantity : 4
+ description : Basketball
+ price : 450.00
+ - sku : BL4438H
+ quantity : 1
+ description : Super Hoop
+ price : 2392.00
+tax : 251.42
+total: 4443.52
+comments:
+ Late afternoon is best.
+ Backup contact is Nancy
+ Billsmer @ 338-4338.
+}
+ dictsort2 [yaml::yaml2dict $Invoice] {{d {bill-to {{d {address d}}} ship-to {{d {address d}}} product {l d}}}}
+} -result [dictsort2 [string map [list TIMESTAMP [clock scan "2001-01-23"]] \
+[dict create invoice 34843 date TIMESTAMP bill-to [dict create given Chris family Dumars address [dict create lines {458 Walkman Dr.
+Suite #292
+} city {Royal Oak} state MI postal 48046]] ship-to [dict create given Chris family Dumars address [dict create lines {458 Walkman Dr.
+Suite #292
+} city {Royal Oak} state MI postal 48046]] product [list [dict create sku BL394D quantity 4 description Basketball price 450.00] [dict create sku BL4438H quantity 1 description {Super Hoop} price 2392.00]] tax 251.42 total 4443.52 comments {Late afternoon is best. Backup contact is Nancy Billsmer @ 338-4338.}] ] \
+{{d {bill-to {{d {address d}}} ship-to {{d {address d}}} product {l d}}}}]
+
+
+
+
+
+# --------------
+# dumping .....
+
+
+
+
+test yaml-20.1 "list2yaml" -body {
+ set dump1 {
+{Mark McGwire} {Sammy Sosa}
+}
+
+ yaml::list2yaml $dump1
+} -result {---
+- Mark McGwire
+- Sammy Sosa
+}
+
+test yaml-20.2 "dict2yaml" -body {
+ set dump2 { name {Sammy Sosa} hr 63 avg 0.288 }
+ set _before [eval huddle create $dump2]
+ set yaml2 [yaml::dict2yaml $dump2]
+ set _after [yaml::yaml2dict $yaml2]
+ set _after [eval huddle create $_after]
+ huddle equal $_before $_after
+} -result {1}
+
+test yaml-20.3 "dict2yaml block/flow scalars" -body {
+ set dump_scalars [list \
+{http://www.activestate.com/Products/activetcl/} \
+{This is the core development home for the tcllib standardized Tcl library. This is a set of pure-Tcl extensions that you can use to become even more productive with Tcl. See also the Tcl Foundry that collects information about many Tcl-related SourceForge projects.} \
+{tklib: A library of all-Tcl routines for Tk
+tclapps: A set of little apps for Tcl or Tk, to be used as examples, or just for fun
+tclbench: A benchmarking suite for Tcl and Tk} ]
+
+
+
+ yaml::list2yaml $dump_scalars
+} -result {---
+- >
+ http://www.activestate.com/Products/activetcl/
+- >
+ This is the core development home for
+ the tcllib standardized Tcl library.
+ This is a set of pure-Tcl extensions
+ that you can use to become even more
+ productive with Tcl. See also the Tcl
+ Foundry that collects information about
+ many Tcl-related SourceForge projects.
+- |-
+ tklib: A library of all-Tcl routines for Tk
+ tclapps: A set of little apps for Tcl or Tk, to be used as examples, or just for fun
+ tclbench: A benchmarking suite for Tcl and Tk
+}
+
+
+
+# ... Tests of addStrings ...
+# (Requires introspection of parser state)
+
+
+if [info exists selfrun] {
+ tcltest::cleanupTests
+} else {
+ testsuiteCleanup
+}
+
generated by cgit v0.12 at 2024-09-04 07:24:07 (GMT)