diff options
author | William Joye <wjoye@cfa.harvard.edu> | 2016-10-27 19:39:39 (GMT) |
---|---|---|
committer | William Joye <wjoye@cfa.harvard.edu> | 2016-10-27 19:39:39 (GMT) |
commit | ea28451286d3ea4a772fa174483f9a7a66bb1ab3 (patch) | |
tree | 6ee9d8a7848333a7ceeee3b13d492e40225f8b86 /tcllib/modules/yaml | |
parent | b5ca09bae0d6a1edce939eea03594dd56383f2c8 (diff) | |
parent | 7c621da28f07e449ad90c387344f07a453927569 (diff) | |
download | blt-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.data | 7 | ||||
-rw-r--r-- | tcllib/modules/yaml/CHANGES | 62 | ||||
-rw-r--r-- | tcllib/modules/yaml/ChangeLog | 52 | ||||
-rwxr-xr-x | tcllib/modules/yaml/huddle.man | 558 | ||||
-rwxr-xr-x | tcllib/modules/yaml/huddle.tcl | 646 | ||||
-rwxr-xr-x | tcllib/modules/yaml/huddle.test | 363 | ||||
-rw-r--r-- | tcllib/modules/yaml/huddle_types.tcl | 296 | ||||
-rw-r--r-- | tcllib/modules/yaml/json2huddle.tcl | 389 | ||||
-rw-r--r-- | tcllib/modules/yaml/json2huddle.test | 181 | ||||
-rwxr-xr-x | tcllib/modules/yaml/layers.txt | 224 | ||||
-rw-r--r-- | tcllib/modules/yaml/pkgIndex.tcl | 6 | ||||
-rw-r--r-- | tcllib/modules/yaml/rb.test | 654 | ||||
-rwxr-xr-x | tcllib/modules/yaml/yaml.bench | 87 | ||||
-rw-r--r-- | tcllib/modules/yaml/yaml.man | 189 | ||||
-rw-r--r-- | tcllib/modules/yaml/yaml.tcl | 1283 | ||||
-rw-r--r-- | tcllib/modules/yaml/yaml.test | 775 |
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 +} + |