Index: modules/yaml/huddle.man ================================================================== --- modules/yaml/huddle.man +++ modules/yaml/huddle.man @@ -1,7 +1,8 @@ +[vset VERSION 0.1.6] [comment {-*- tcl -*- doctools manpage}] -[manpage_begin huddle n 0.1.5] +[manpage_begin huddle n [vset VERSION]] [see_also yaml] [keywords {data exchange}] [keywords {exchange format}] [keywords huddle] [keywords json] @@ -10,11 +11,11 @@ [keywords yaml] [copyright {2008 KATO Kanryu }] [moddesc {HUDDLE}] [titledesc {Create and manipulate huddle object}] [require Tcl 8.4] -[require huddle [opt 0.1.5]] +[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] @@ -55,31 +56,53 @@ 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 ..."]]] +[call [cmd "huddle get_stripped"] [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 ..."]]] +[call [cmd "huddle remove"] [arg objectVar] [arg key] [opt [arg "key ..."]]] Almost the same as [cmd "dict remove"]. -Remove a sub-object from the huddle object. +Remove in place a sub-object from the huddle object. [arg key] can be used to huddle-list's index. +[call [cmd "huddle removed"] [arg object] [arg key] [opt [arg "key ..."]]] +Makes a copy of the huddle object and remove the indicated sub-object. +This is more efficient than making first a clone and then use [cmd "huddle remove"] for removing the desired sub-object. + [call [cmd "huddle combine"] [arg object1] [arg object2] [opt [arg "object3 ..."]]] -Merging huddle objects given. +Merging huddle objects given. The objects should be of the same type. [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] @@ -99,13 +122,15 @@ 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. +[call [cmd "huddle update_children"] [arg objectVar] [arg key] [arg value] [opt [arg "key value ..."]]] +Update child elements. Lists only allow update indexes that are in its range. + +[call [cmd "huddle lappend"] [arg listVar] [arg value] [opt [arg "value ..."]]] +Append new children to a list. [example { % set aa [huddle create a b c d] HUDDLE {D {a {s b} c {s d}}} % huddle append aa a k l m @@ -138,10 +163,22 @@ [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 @@ -152,11 +189,11 @@ }] [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]]] +[call [cmd "huddle json_dump"] [arg object] [opt [arg offset]] [opt [arg newline]] [opt [arg begin_offset]]] dump a json-stream from the huddle-object. [para] [list_begin options] @@ -165,11 +202,11 @@ 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}}}} +% huddle json_dump {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", @@ -182,11 +219,11 @@ ["g"] ], "t" ] # stripped output -% huddle jsondump {HUDDLE {D {dd {D {bb {D {a {s baa} c {s {d +% huddle json_dump {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]] @@ -223,29 +260,29 @@ 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 is_huddle"] [arg object]] +if [arg object] is a huddle, returns 1. Otherwise, returns 0. -[call [cmd "huddle checkHuddle"] [arg object]] -if [arg object] is not a huddle, rises an error. +[call [cmd "huddle check_huddle"] [arg object]] +raise an error if [arg object] is not huddle. -[call [cmd "huddle to_node"] [arg object] [opt [arg tag]]] +[call [cmd "huddle argument_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 +% huddle argument_to_node str s str -% huddle to_node str !!str +% huddle argument_to_node str !!str !!str str -% huddle to_node {HUDDLE {s str}} +% huddle argument_to_node {HUDDLE {s str}} s str -% huddle to_node {HUDDLE {l {a b c}}} +% huddle argument_to_node {HUDDLE {l {a b c}}} l {a b c} }] [call [cmd "huddle wrap"] [arg tag] [arg src]] for type-callbacks. @@ -262,81 +299,84 @@ [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]] +[call [cmd "huddle add_type"] [arg namespace]] 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]] +[opt_def namespace] + +name of namespace with the definition of the new type. + +[list_end] +[list_end] + +[section {TYPE NAMESPACE}] +[para] + +There is two kind of types: +[list_begin definitions] +[def "Containers"]It can contain other huddle object +[def "Not containers"] It can not contain other huddle object +[list_end] + +All the types require a variable named settings. This variable has these attributes related to the type: + +[list_begin definitions] +[def "[const isContainer] boolean_flag"] +a boolean value indicating whether the new type is a container + +[def "[const superclass] name_of_superclass"] +this is optional. It indicantes what is the super class of these type. All the methods of the super class are inherited. + +[def "[const publicMethods] {method1 method2 method3 ...}"] +method list as huddle subcommand. Then, you can call [cmd {[huddle method1 ...]}] + +[def "[const map] {huddle_subcommand1 proc_name1 huddle_subcommand2 proc_name2 ...}"] +it defines a map bettween huddle subcommands and the associated proc inside the type namespace. + +[def "[const tag] tag_name"] +a tag representing the type + +[list_end] + + + +[para] +There is some required procs in a container type: + +[list_begin definitions] +[call [cmd Set] [arg src_var] [arg key] [arg value]] +set a subnode in the guiven variable containing a subnode content +[call [cmd Strip] [arg src]] +returns the node content stripped +[call [cmd Exists] [arg src] [arg key]] +returns a boolean value indicating whether the key exists in the node content +[call [cmd Equal] [arg src1] [arg src2]] +returns a boolean vlaue indicating whether the two node contents are equal +[call [cmd Update_children] [arg src_var] [arg items]] +udpate several subnodes at the same time for performance +[call [cmd Get_subnode] [arg src] [arg key]] +returns a sub node specified by [arg key]. +[call [cmd Combine] [arg list_of_src]] +returns a combined node content using the content of several nodes of the same type +[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 { @@ -354,11 +394,11 @@ # "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 + get_subnode { ; # 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 @@ -389,11 +429,11 @@ 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] + lappend resultL $key [huddle argument_to_node $value $str] } else { lappend resultL $key $value } } return [eval dict create $resultL] @@ -400,11 +440,11 @@ } 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] + lappend resultL $key [huddle argument_to_node $value] } return [huddle wrap D $resultL] } keys { foreach {src nop} $args break @@ -431,11 +471,11 @@ } 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] + lappend resultL $key [huddle argument_to_node $value !!str] } return [huddle wrap !!map $resultL] } default { ; # devolving to default dict-callback return [huddle call D $command $args] @@ -445,20 +485,36 @@ }] [section "How to add type"] [para] -You can add huddle-node types e.g. ::struct::tree. +You can add huddle-node types e.g. a special type for dates. + +To do so, first, define a namespace for additional tagged-type. -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. +The namespace require a variable named settings indicating the options associated to this type. [para] -And, addType subcommand will called. +And, execute the proc [cmd add_type] [arg "namespace_of_the_type"] +to register this new type. + [example { -huddle addType my_dict_setting +huddle add_type type_name }] + +If the new type is a container of other types, the namespace will require the definition of these procs as mentioned before: +[list_begin itemized] +[item] Set +[item] Strip +[item] Remove +[item] Equal +[item] Exists +[item] Get_subnode +[item] Update_children +[item] Combine + +[list_end] [section "WORKING SAMPLE"] [example { # create as a dict % set bb [huddle create a b c d] @@ -491,11 +547,11 @@ 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 +% huddle json_dump $folding [ { "bb": { "a": "b", "c": "kkk" Index: modules/yaml/huddle.tcl ================================================================== --- modules/yaml/huddle.tcl +++ modules/yaml/huddle.tcl @@ -1,462 +1,522 @@ -# huddle.tcl (working title) -# -# huddle.tcl 0.1.5 2011-08-23 14:46:47 KATO Kanryu(kanryu6@users.sourceforge.net) +# huddle.tcl # # 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 +# Copyright (c) 2015 Miguel Martínez López -if { [package vcompare [package provide Tcl] 8.5] < 0 } { - package require dict -} - -package provide huddle 0.1.5 +package require Tcl 8.5 +package provide huddle 0.2.0 namespace eval ::huddle { - namespace export huddle - # common subcommands: - # get gets strip jsondump set remove - # type specified subcommands: - # create list llength keys - - variable methods - variable types -} - -if {$::tcl_version < 8.5} { - proc huddle {command args} { - variable huddle::methods - if {[info exists huddle::methods($command)]} { - return [eval $huddle::methods($command) $command $args] - } - return [eval ::huddle::$command $args] - } - # some subcommands conflict reserved words. so, add prefix "_" (e.g. from "set" to "_set") - proc ::huddle::proc_add_ub {command args} { - return [eval ::huddle::_$command $args] - } -} else { - proc huddle {command args} { - variable huddle::methods - if {[info exists huddle::methods($command)]} { - return [$huddle::methods($command) $command {*}$args] - } - return [::huddle::$command {*}$args] - } - - proc ::huddle::proc_add_ub {command args} { - return [::huddle::_$command {*}$args] - } -} - -proc ::huddle::addType {procedure} { - variable methods - variable types - - set setting [$procedure setting] - dict with setting { - foreach {m} $method { - set methods($m) $procedure - } - foreach {t node} $tag { - set types(type:$t) $type - set types(node:$t) $node - set types(callback:$t) $procedure - set types(constructor:$t) $constructor - set types(str:$t) $str - } - } -} - -proc ::huddle::isHuddle {arg} { - if {[lindex $arg 0] ne "HUDDLE" || [llength $arg] != 2} { - return 0 - } - variable types - set sub [lindex $arg 1] - if {[llength $sub] != 2 && [array get types "type:[lindex $sub 1]"] == ""} { - return 0 - } - return 1 -} - -proc ::huddle::strip {node} { - variable types - foreach {head value} $node break - if {[info exists types(type:$head)]} { - if {$types(node:$head) eq "parent"} { - return [$types(callback:$head) strip $value] - } else { - return $value - } - } - switch -- $head { - HUDDLE { - return [strip $value] - } - default { - error "\{$src\} is not a huddle." - } - } - return $value -} - -proc ::huddle::call {tag cmd arg} { - variable types - return [eval $types(callback:$tag) $cmd $arg] + namespace export huddle wrap unwrap is_huddle strip_node are_equal_nodes argument_to_node get_src delete_src + + variable types + + namespace ensemble create -map { + set ::huddle::set_huddle + get ::huddle::get + get_stripped ::huddle::get_stripped + update_children ::huddle::update_children + removed ::huddle::removed + remove ::huddle::remove + combine ::huddle::combine + type ::huddle::type + equal ::huddle::equal + exists ::huddle::exists + clone ::huddle::clone + is_huddle ::huddle::is_huddle + wrap ::huddle::wrap + unwrap ::huddle::unwrap + add_type ::huddle::add_type + json_dump ::huddle::json_dump + compile ::huddle::compile + } +} + +proc ::huddle::add_type {typeNamespace} { + variable types + + set typeName [namespace tail $typeNamespace] + set typeCommand ::huddle::Type_of_$typeName + + namespace upvar $typeNamespace settings settings + + # We start building the map of the ensemble + 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::is_huddle ::huddle::strip_node ::huddle::are_equal_nodes ::huddle::argument_to_node ::huddle::get_src ::huddle::delete_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} { + variable types + + set settings [$ensembleCmd settings] + + if {[dict exists $settings superclass]} { + set superclass [dict get $settings superclass] + + set map [namespace ensemble configure $ensembleCmd -map] + + set superclass_tag $types(tagOfType:$superclass) + dict set map $subcommand [list $types(callback:$superclass_tag) $subcommand] + + namespace ensemble configure $ensembleCmd -map $map + return "" + } else { + error "Invalid subcommand '$subcommand' for type '$ensembleCmd'" + } +} + +proc ::huddle::is_huddle {obj} { + # This proc makes the assumption that the user is a good citizen + + if {!([string is list $obj] && [lindex $obj 0] eq "HUDDLE")} { + return 0 + } else { + return 1 + } +} + +proc ::huddle::strip_node {node} { + variable types + lassign $node head src + + 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 tag "" - foreach {obj} $args { - foreach {nop node} $obj break - foreach {t src} $node break - if {$tag eq ""} { - set tag $t - } else { - if {$tag ne $t} {error "unmatched huddles are given."} - } - eval lappend result $src - } - set src [$types(callback:$tag) append "" {} $result] - return [wrap $tag $src] - -} - -proc ::huddle::checkHuddle {src} { - if {![isHuddle $src]} { - error "\{$src\} is not a huddle." - } -} - -proc ::huddle::to_node {src {tag ""}} { - if {$tag eq ""} {set tag s} - if {[isHuddle $src]} { - return [lindex $src 1] - } else { - return [list $tag $src] - } -} - -proc ::huddle::wrap {head src} { - if {$head ne ""} { - return [list HUDDLE [list $head $src]] - } else { - return [list HUDDLE $src] - } -} - -proc ::huddle::_get {src args} { - checkHuddle $src - return [_key_reflexive _get2 [lindex $src 1] [llength $args] $args 0] -} - -proc ::huddle::_gets {src args} { - checkHuddle $src - return [_key_reflexive _get2 [lindex $src 1] [llength $args] $args 1] -} - -proc ::huddle::type {src args} { - checkHuddle $src - lappend args "nop" - return [_key_reflexive _type [lindex $src 1] [llength $args] $args] -} - -proc ::huddle::_set {objvar args} { - upvar 3 $objvar obj - checkHuddle $obj - set path [lrange $args 0 end-1] - set value [lindex $args end] - set value [to_node $value] - foreach {nop node} $obj break - set node [_set_subs set $node [llength $path] $path $value] - set obj [wrap "" $node] -} - -proc ::huddle::remove {src args} { - checkHuddle $src - foreach {nop src} $src break - set src [_set_subs remove $src [llength $args] $args ""] - set obj [wrap "" $src] -} - -proc ::huddle::equal {obj1 obj2} { - checkHuddle $obj1 - checkHuddle $obj2 - return [_equal_subs [lindex $obj1 1] [lindex $obj2 1]] -} -proc ::huddle::_equal_subs {obj1 obj2} { - variable types - - foreach {tag1 src1} $obj1 break - foreach {tag2 src2} $obj2 break - if {$tag1 ne $tag2} {return 0} - return [$types(callback:$tag1) equal $src1 $src2] -} - -proc ::huddle::_append {objvar args} { - variable types - - upvar 3 $objvar obj - checkHuddle $obj - foreach {tag src} [lindex $obj 1] break - set src [$types(callback:$tag) append $types(str:$tag) $src $args] - set obj [wrap $tag $src] - return $obj -} - -proc ::huddle::_set_subs {command node len path value} { - variable types - foreach {tag src} $node break - if {$len > 1} { - set key [lindex $path 0] - set subpath [lrange $path 1 end] - incr len -1 - if {![info exists types(type:$tag)]} {error "\{$src\} don't have any child node."} - set subs [$types(callback:$tag) get_sub $src $key] - set subs [_set_subs $command $subs $len $subpath $value] - set src [$types(callback:$tag) set $src $key $subs] - return [list $tag $src] - } - if {![info exists types(type:$tag)]} {error "\{$src\} is not a huddle node."} - set src [$types(callback:$tag) $command $src $path $value] - return [list $tag $src] -} - -proc ::huddle::_key_reflexive {command node len path {option ""}} { - variable types - foreach {tag src} $node break - if {$len > 1} { - set key [lindex $path 0] - set subpath [lrange $path 1 end] - incr len -1 - if {![info exists types(type:$tag)]} {error "\{$src\} don't have any child node."} - set subs [$types(callback:$tag) get_sub $src $key] - return [_key_reflexive $command $subs $len $subpath $option] - } - if {![info exists types(type:$tag)]} {error "\{$src\} is not a huddle node."} - return [$command $node $path $option] -} - -proc ::huddle::_get2 {node path strip} { - variable types - foreach {tag src} $node break - set subs [$types(callback:$tag) get_sub $src $path] - return [_strip_wrap "" $subs $strip] -} - -proc ::huddle::_type {node nop nop} { - variable types - foreach {tag src} $node break - return $types(type:$tag) -} - -proc ::huddle::_strip_wrap {head src {striped 0}} { - if {$striped} { - return [strip $src] - } else { - return [wrap $head $src] - } -} - -proc ::huddle::_dict_setting {command args} { -# __TRANSCRIBE_BEGIN__ - 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" - } - } -# __TRANSCRIBE_END__ -} - -proc ::huddle::_list_setting {command args} { - switch -- $command { - setting { - return { - type list - method {list llength} - tag {l child L parent} - constructor list - str s - } - } - get_sub { - foreach {src index} $args break - return [lindex $src $index] - } - strip { - foreach {src nop} $args break - set result {} - foreach {val} $src { - lappend result [strip $val] - } - return $result - } - set { - foreach {src index value} $args break - lset src $index $value - return $src - } - remove { - foreach {src index value} $args break - return [lreplace $src $index $index] - } - equal { - foreach {src1 src2} $args break - if {[llength $src1] != [llength $src2]} {return 0} - set i 0 - foreach {val1} $src1 { - if {![huddle _equal_subs $val1 [lindex $src2 $i]]} {return 0} - incr i - } - return 1 - } - append { ; # append nodes - foreach {str src list} $args break - set resultL $src - foreach {value} $list { - if {$str ne ""} { - lappend resultL [huddle to_node $value $str] - } else { - lappend resultL $value - } - } - return $resultL - } - list { - set resultL {} - foreach {value} $args { - lappend resultL [huddle to_node $value] - } - return [huddle wrap L $resultL] - } - llength { - foreach {src nop} $args break - return [llength [lindex [lindex $src 1] 1]] - } - default { - error "$command is not callback for list" - } - } -} - -proc ::huddle::_string_setting {command args} { - switch -- $command { - setting { - return { - type string - method {string} - tag {s child} - constructor string - str s - } - } - string { - return [huddle wrap s $args] - } - equal { - foreach {src1 src2} $args break - return [expr {$src1 eq $src2}] - } - default { - error "$command is not callback for string" - } - } -} - - -proc ::huddle::jsondump {data {offset " "} {newline "\n"} {begin ""}} { + check_huddle $obj + } + + set first_object [lindex $args 0] + set tag_of_group [lindex [unwrap $first_object] 0] + + foreach {obj} $args { + set node [unwrap $obj] + + lassign $node tag src + + if {$tag_of_group ne $tag} { + error "unmatched types given to 'combine' subcommand." + } + + lappend list_of_src $src + } + + set combined_src [$types(callback:$tag_of_group) Combine $list_of_src] + + return [wrap [list $tag $combined_src]] +} + +proc ::huddle::check_huddle {huddle_object} { + if {![is_huddle $huddle_object]} { + error "\{$huddle_object\} is not a huddle." + } +} + +proc ::huddle::argument_to_node {src {default_tag s}} { + if {[is_huddle $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::delete_src { huddle_var } { + upvar 1 $huddle_var huddle_object + lset $huddle_object 1 1 "" +} + +proc ::huddle::update_children {objvar args} { + variable types + + upvar 1 $objvar obj + check_huddle $obj + + if {[llength $args] % 2} { + return -code error {wrong # args: should be "huddle append objvar ?key value ...?"} + } + + lassign [unwrap $obj] tag src + + set subsrc_list [list] + + $types(callback:$tag) Update_children src $args + set obj [wrap [list $tag $src]] + return $obj +} + +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 striped} { + check_huddle $huddle_object + + set target_node [Find_node [unwrap $huddle_object] $path] + + if {$striped} { + return [strip_node $target_node] + } else { + return [wrap $target_node] + } +} + +proc ::huddle::type {huddle_object args} { + variable types + + check_huddle $huddle_object + + set target_node [Find_node [unwrap $huddle_object] $args] + + lassign $target_node tag src + + return $types(type:$tag) +} + +proc ::huddle::Find_node {node path} { + variable types + + set subnode $node + + foreach subpath $path { + lassign $subnode tag src + set subnode [$types(callback:$tag) Get_subnode $src $subpath] + } + + return $subnode +} + +proc ::huddle::exists {huddle_object args} { + variable types + + check_huddle $huddle_object + + set subnode [unwrap $huddle_object] + + foreach key $args { + lassign $subnode tag src + + 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} { + check_huddle $obj1 + check_huddle $obj2 + return [are_equal_nodes [unwrap $obj1] [unwrap $obj2]] +} + +proc ::huddle::are_equal_nodes {node1 node2} { + variable types + + lassign $node1 tag1 src1 + lassign $node2 tag2 src2 + + if {$tag1 ne $tag2} {return 0} + return [$types(callback:$tag1) Equal $src1 $src2] +} + + +proc ::huddle::set_huddle {objvar args} { + upvar 1 $objvar obj + + check_huddle $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 [list $new_subnode] + set obj [wrap $root_node] +} + +proc ::huddle::remove {objvar args} { + upvar 1 $objvar obj + check_huddle $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::apply_to_subnode {subcommand node_var len path {subcommand_arguments ""}} { + # This proc is optimized for performance. + # We make all the surgery for keeping a reference count of 1 for all the variables that we + # want to change in place. + # It's necessary that the user that wants to apply this optimization keeps a reference count + # of 1 for his huddle object before calling "huddle set" or "huddle remove". + + variable types + + upvar 1 $node_var node + + lassign $node tag src + + # 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 + # We don't want to delete the key, because we will use again later. + # We only delete delete its subnode associated. + $types(callback:$tag) Set 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::removed {obj args} { + # The procedure returns a cloned huddle object with the requested subnode removed. + + check_huddle $obj + + set modified_node [Remove_node_and_clone [unwrap $obj] [llength $args] $args] + + set obj [wrap $modified_node] +} + +proc ::huddle::Remove_node_and_clone {node len path} { + variable types + + lassign $node tag src + + set key_containing_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] { + lassign $item key subnode + + if {$key eq $key_containing_removed_subnode} { + set modified_subnode [Remove_node_and_clone $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 $key_containing_removed_subnode + return [list $tag $src] + } +} + +proc ::huddle::clone {obj} { + set cloned_node [Clone_node [unwrap $obj]] + + return [wrap $cloned_node] +} + +proc ::huddle::Clone_node {node} { + variable types + + lassign $node tag src + + + if { $types(isContainer:$tag) } { + set cloned_src "" + + foreach item [$types(callback:$tag) items $src] { + lassign $item key subnode + + 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::json_dump {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 $data] + + set type [type $huddle_object] + switch -- $type { - "string" { - set data [huddle strip $data] - if {[string is double -strict $data]} {return $data} - if {[regexp {^true$|^false$|^null$} $data]} {return $data} + boolean - + number - + null { + return [get_stripped $huddle_object] + } + + string { + set data [get_stripped $huddle_object] + # JSON permits only oneline string set data [string map { \n \\n \t \\t \r \\r @@ -465,36 +525,40 @@ \\ \\\\ \" \\\" / \\/ } $data ] - return "\"$data\"" + return "\"$data\"" } - "list" { + + list { set inner {} - set len [huddle llength $data] + set len [huddle llength $huddle_object] for {set i 0} {$i < $len} {incr i} { - set sub [huddle get $data $i] - lappend inner [jsondump $sub $offset $newline $nextoff] + set subobject [get $huddle_object $i] + lappend inner [json_dump $subobject $offset $newline $nextoff] } if {[llength $inner] == 1} { return "\[[lindex $inner 0]\]" } + return "\[$nlof[join $inner ,$nlof]$newline$begin\]" } - "dict" { + + dict { set inner {} - foreach {key} [huddle keys $data] { - lappend inner [subst {"$key":$sp[jsondump [huddle get $data $key] $offset $newline $nextoff]}] + foreach {key} [huddle keys $huddle_object] { + lappend inner [subst {"$key":$sp[json_dump [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] + return [$types(callback:$type) json_dump $data $offset $newline $nextoff] } } } # data is plain old tcl values @@ -505,64 +569,96 @@ # {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] { +proc ::huddle::Compile_to_node {spec data} { + + while {[llength $spec]} { set type [lindex $spec 0] set spec [lrange $spec 1 end] switch -- $type { dict { - lappend spec * string + if {![llength $spec]} { + lappend spec * string + } - set result [huddle create] - foreach {key val} $data { - foreach {keymatch valtype} $spec { - if {[string match $keymatch $key]} { - huddle append result $key [compile $valtype $val] + set dict_src [dict create] + foreach {key value} $data { + foreach {matching_key subspec} $spec { + if {[string match $matching_key $key]} { + dict set dict_src $key [Compile_to_node $subspec $value] break } } } - return $result + + return [list D $dict_src] } + list { if {![llength $spec]} { set spec string } else { set spec [lindex $spec 0] } - set result [huddle list] - foreach {val} $data { - huddle append result [compile $spec $val] - } - return $result - } - string { -# if {[string is double -strict $data]} { -# return $data -# } else { - return [huddle wrap s $data] -# } - } - default {error "Invalid type"} - } - } -} - -namespace eval ::huddle { - array set methods {} - array set types {} - array set callbacks {} - ::huddle::addType ::huddle::_dict_setting - ::huddle::addType ::huddle::_list_setting - ::huddle::addType ::huddle::_string_setting - set methods(set) ::huddle::proc_add_ub - set methods(append) ::huddle::proc_add_ub - set methods(get) ::huddle::proc_add_ub - set methods(gets) ::huddle::proc_add_ub -} - - - + + set list_src [list] + foreach list_item $data { + lappend list_src [Compile_to_node $spec $list_item] + } + + return [list L $list_src] + } + + string { + set data [string map {\" \\\"} $data] + set data [string map {\n \\n} $data] + + return [list s $data] + } + + number { + return [list num $data] + } + + bool { + return [list b $data] + } + + null { + if {$data eq ""} { + return [list null] + } else { + error "Data must be an empty string: '$data'" + } + } + + huddle { + if {[is_huddle $data]} { + return [unwrap $data] + } else { + error "Data is not a huddle object: $data" + } + } + + default {error "Invalid type: '$type'"} + } + } +} + +proc ::huddle::compile {spec data} { + return [wrap [Compile_to_node $spec $data]] +} + +apply {{selfdir} { + source [file join $selfdir huddle_types.tcl] + + foreach typeNamespace [namespace children ::huddle::types] { + add_type $typeNamespace + } + + return +} ::huddle} [file dirname [file normalize [info script]]] + +return Index: modules/yaml/huddle.test ================================================================== --- modules/yaml/huddle.test +++ modules/yaml/huddle.test @@ -3,18 +3,18 @@ # # Copyright (c) 2008 by KATO Kanryu # All rights reserved. # - 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] + + source huddle.tcl package require json proc dictsort {dict} { array set a $dict set out [list] @@ -27,28 +27,20 @@ # 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 - } - } + testsNeedTcl 8.5 + testsNeedTcltest 2 + #testsNeed dict 1 support { - use json/json.tcl json + 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}}}} @@ -71,15 +63,15 @@ 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 gets $folding dd + 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 gets $folding dd cc + 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} @@ -113,15 +105,15 @@ 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 gets $folding 0 + 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 gets $folding 0 1 + 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} @@ -133,14 +125,18 @@ 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 strip {HUDDLE {L {{s a} {L {}} {s c}}}} + 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} { +test huddle-2.12 "test of huddle list" -body { + huddle llength {HUDDLE {L {{s a} {s b} {s c}}}} +} -result {3} + +#test huddle-3.1 "test of huddle json_dump" {[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] { @@ -157,17 +153,17 @@ # close $fd # # set data [json::json2dict $json1] ## set data [huddle_build $data] ## -## set json2 [huddle jsondump $data] +## set json2 [huddle json_dump $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 {{s 1.0} {s true} {s g} {s h}}}}} {s t}}}} +test huddle-3.2 "test of huddle json_dump" -body { + huddle json_dump {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", @@ -179,53 +175,77 @@ ] ], "t" ]} -if { [package vcompare [package provide Tcl] 8.5] > 0 } { -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 {s 1} j {s { m\a}}}}}}} - set json1 [huddle jsondump $huddle1] + +test huddle-3.3 "test of huddle json_dump" -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 json_dump $huddle1] set json2 {{ "dd": { "bb": { "a": "baa", - "c": "d\na" + "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" } }} - if {$json1 == $json2} {return 1} + set data [json::json2dict $json1] - set data [huddle compile {dict dd {dict * dict} ee dict} $data] + 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] +test huddle-4.2 "test of huddle removed" -body { + set data_dict [huddle removed $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] + huddle remove data_list 0 2 + return $data_list } -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 @@ -248,14 +268,101 @@ 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 -# ... Tests of addStrings ... -# (Requires introspection of parser state) +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 add_type ::new_types::mapping + huddle add_type ::new_types::str + + set a [huddle mapping key1 var1] + huddle update_children a key2 [huddle mapping key3 var3] +} -result {HUDDLE {!!map {key1 {!!str var1} key2 {!!map {key3 {!!str var3}}}}}} + -if [info exists selfrun] { +if {[info exists selfrun]} { tcltest::cleanupTests } else { testsuiteCleanup } ADDED modules/yaml/huddle_types.tcl Index: modules/yaml/huddle_types.tcl ================================================================== --- /dev/null +++ modules/yaml/huddle_types.tcl @@ -0,0 +1,313 @@ +namespace eval ::huddle::types { + namespace export * + + namespace eval dict { + variable settings + + # type definition + set settings { + publicMethods {create keys} + tag D + isContainer yes} + + + 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 + } + + # 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 Combine {list_of_src} { + set combined_src [dict merge {*}$list_of_src] + return $combined_src + } + + proc Update_children {src_var items} { + upvar 1 $src_var src + + foreach {key value} $items { + dict set src $key [argument_to_node $value] + } + } + + # $args: all arguments after "huddle create" + proc create {args} { + if {[llength $args] % 2} {error {wrong # args: should be "huddle create ?key value ...?"}} + set resultD [dict create] + + foreach {key value} $args { + if {[is_huddle $key]} { + lassign [unwrap $key] tag src + + if {$tag ne "string"} { + return -code error "The key '$key' must a string literal or huddle string" + } + set key $src + } + dict set resultD $key [argument_to_node $value] + } + return [wrap [list D $resultD]] + } + + 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 lappend} + tag L + isContainer yes + map {list List llength Llength lappend Lappend} } + + 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 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 Combine {list_of_src} { + set combined_src [list] + foreach src $list_of_src { + lappend combined_src {*}$src + } + + return $combined_src + } + + proc Update_children {src_var items} { + upvar 1 $src_var src + + foreach {key value} $items { + if {!([string is digit $key] && [string index $key 0] ne "0")} { + return -code error "The key should be a natural number: $key" + } + + if { $key >= [llength $src]} { + return -code error "The key is out of range: $key. List type only allow update children that exists in the list." + } + + lset src $key [argument_to_node $value] + } + } + + proc Lappend {huddle_var args} { + upvar 1 $huddle_var huddle_object + + set src [get_src $huddle_object] + + delete_src huddle_object + + foreach argument $args { + set subnode [argument_to_node $argument] + lappend src $subnode + } + return [wrap [list L $src]] + } + + 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 { + return -code 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 + } + } +} ADDED modules/yaml/json2huddle.tcl Index: modules/yaml/json2huddle.tcl ================================================================== --- /dev/null +++ modules/yaml/json2huddle.tcl @@ -0,0 +1,383 @@ +# -*- tcl -*- +# (c) 2015 Miguel Martínez López + +package require Tcl 8.5 +package require huddle 0.2.0 + +package require TclOO ; # For 8.5. Integrated with 8.6 +package require try ; # For 8.5. Integrated with 8.6. Tcllib. +package require throw ; # For 8.5. Integrated with 8.6. Tcllib. + +package provide huddle::json 0.1 + + +interp alias {} ::huddle::json2huddle {} ::huddle::json::json2huddle parse + +namespace eval ::huddle { + namespace export json2huddle +} + + +namespace eval ::huddle::json { + + oo::class create Json2huddle { + + variable cursor jsonText EndOfTextException numberRE + + constructor {} { + + 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 parseNextData + } + + 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 parseNextData {} { + + 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 parseNextData] + } + "-" - + "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 parseNextData] + + 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 parseNextData] + + 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 + +} + + ADDED modules/yaml/json2huddle.test Index: modules/yaml/json2huddle.test ================================================================== --- /dev/null +++ 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 + + 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 Index: modules/yaml/pkgIndex.tcl ================================================================== --- modules/yaml/pkgIndex.tcl +++ modules/yaml/pkgIndex.tcl @@ -1,12 +1,6 @@ -# Tcl package index file, version 1.1 -# This file is generated by the "pkg_mkIndex" command -# and sourced either when an application starts up or -# by a "package unknown" script. It invokes the -# "package ifneeded" command to set up package-related -# information so that packages will be loaded automatically -# in response to "package require" commands. When this -# script is sourced, the variable $dir must contain the -# full path name of this file's directory. - -package ifneeded yaml 0.3.7 [list source [file join $dir yaml.tcl]] -package ifneeded huddle 0.1.5 [list source [file join $dir huddle.tcl]] + +if {![package vsatisfies [package provide Tcl] 8.5]} {return} + +package ifneeded yaml 0.3.8 [list source [file join $dir yaml.tcl]] +package ifneeded huddle 0.2.0 [list source [file join $dir huddle.tcl]] +package ifneeded huddle::json 0.1 [list source [file join $dir json2huddle.tcl]] Index: modules/yaml/rb.test ================================================================== --- modules/yaml/rb.test +++ modules/yaml/rb.test @@ -1,6 +1,6 @@ -# +# -*- tcl -*- # rb.test: test samples for the yaml library. # http://yaml4r.sourceforge.net/cookbook/ # if {[lsearch [namespace children] ::tcltest] == -1} { Index: modules/yaml/yaml.tcl ================================================================== --- modules/yaml/yaml.tcl +++ modules/yaml/yaml.tcl @@ -10,18 +10,14 @@ # # It currently supports a very limited subsection of the YAML spec. # # -if {$::tcl_version < 8.5} { - package require dict -} - -package provide yaml 0.3.7 +package require Tcl 8.5 +package provide yaml 0.3.8 package require cmdline -package require huddle - +package require huddle 0.2.0 namespace eval ::yaml { namespace export load setOptions dict2dump list2dump variable data array set data {} @@ -34,20 +30,20 @@ # 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 + variable defaults array set defaults { isfile 0 validate 0 types {timestamp int float null true false} composer { @@ -66,22 +62,22 @@ 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 setting(null/true/false)}} - {m:null.arg "" {null modifier setting(default {"" {null "" ~}})}} - {m:true.arg "" {true modifier setting(default {1 {true on + yes y}})}} - {m:false.arg "" {false modifier setting(default {0 {false off - no n}})}} - {types.arg "" {modifier list setting(default {nop timestamp integer null true false})}} + {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 { @@ -97,28 +93,31 @@ 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 strip $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 @@ -132,46 +131,46 @@ # Dump TCL List to YAML # proc ::yaml::list2yaml {list {indent 2} {wordwrap 40}} { - return [huddle2yaml [eval huddle list $list] $indent $wordwrap] + return [huddle2yaml [huddle list {*}$list] $indent $wordwrap] } proc ::yaml::dict2yaml {dict {indent 2} {wordwrap 40}} { - return [huddle2yaml [eval huddle create $dict] $indent $wordwrap] + 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 Setting +# Option settings #################### proc ::yaml::_getOption {argv} { variable data variable parsers variable fixed variable composer - # default setting + # 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 @@ -188,11 +187,11 @@ variable defaults variable opts array set options [array get defaults] - # default setting + # default settings array set fixed $options(fixed) # parse argv set argc [llength $argv] while {[set err [::cmdline::getopt argv $opts opt arg]]} { @@ -234,19 +233,19 @@ ######################### # Scalar/Block Composers ######################### proc ::yaml::_composeTags {tag value} { if {$tag eq ""} {return $value} - set value [huddle strip $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 [eval huddle wrap $pair] + return [huddle wrap $pair] } proc ::yaml::_composeBinary {value} { package require base64 return [list !!binary [::base64::decode $value]] @@ -253,19 +252,19 @@ } proc ::yaml::_composePlain {value} { if {$value ne ""} { if {[huddle type $value] ne "plain"} {return $value} - set value [huddle strip $value] + set value [huddle get_stripped $value] } set pair [_toType $value] - return [eval huddle wrap $pair] + 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} @@ -323,15 +322,15 @@ 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, + # 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 "."} { @@ -339,15 +338,15 @@ 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, +# # 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 @@ -430,11 +429,11 @@ foreach {result prev} [_pushValue $result $prev $status $value "BLOCK"] break unset value } } if {$status eq "SEQUENCE"} { - set result [eval huddle sequence $result] + set result [huddle sequence {*}$result] } elseif {$status eq "MAPPING"} { if {[llength $prev] == 2} { set result [_set_huddle_mapping $result $prev] } } else { @@ -441,12 +440,12 @@ if {[info exists prev]} { set result $prev } set result [lindex $result 0] set result [_composePlain $result] - if {![huddle isHuddle $result]} { - set result [huddle wrap !!str $result] + if {![huddle is_huddle $result]} { + set result [huddle wrap [list !!str $result]] } } if {$tag ne ""} { set result [_composeTags $tag $result] unset tag @@ -465,23 +464,23 @@ set result [_set_huddle_mapping $result $prev] set prev {} } set value [_parseBlockNode "" $pos] - if {[huddle type $value] eq "list"} { + + if {[huddle type $value] 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] } - unset sub len + } 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 "" @@ -496,19 +495,23 @@ } 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 strip $key] + if {[huddle is_huddle $key]} { + set key [huddle get_stripped $key] } + + if {$result eq ""} { set result [huddle mapping $key $val] } else { - huddle append result $key $val + huddle update_children result $key $val } return $result } @@ -527,20 +530,20 @@ # 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 @@ -567,11 +570,11 @@ } "clip" { append value "\n" } } - return [huddle wrap !!str $value] + return [huddle wrap [list !!str $value]] } # in {> |} proc ::yaml::_parseBlockIndicator {} { set chomping "clip" @@ -675,11 +678,11 @@ "\[" { ; # starts a flow sequence set value [_parseFlowNode "SEQUENCE"] } "\]" { ; # ends a flow sequence if {$status ne "SEQUENCE"} {error [_getErrorMessage SEQEND_NOT_IN_SEQ] } - set result [eval huddle sequence $result] + set result [huddle sequence {*}$result] return $result } "&" { ; # node's anchor property set anchor [_getToken] } @@ -767,11 +770,11 @@ set value [_parsePlainScalarInBlock $pos] } set tag !!plain } } - return [huddle wrap $tag $value] + 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 @@ -829,11 +832,11 @@ proc ::yaml::_parseDirective {} { variable data variable shorthands set directive [_getToken] - + if {[regexp {^%YAML} $directive]} { # YAML directive _skipSpaces set version [_getToken] set data(YAMLVersion) $version @@ -851,30 +854,30 @@ } } 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 {} { @@ -907,11 +910,11 @@ 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 @@ -936,19 +939,19 @@ 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 {} { @@ -1105,11 +1108,11 @@ proc ::yaml::_imp_huddle2yaml {data {offset ""}} { set nextoff "$offset[string repeat { } $yaml::_dumpIndent]" switch -- [huddle type $data] { "string" { - set data [huddle strip $data] + set data [huddle get_stripped $data] return [_dumpScalar $data $offset] } "list" { set inner {} set len [huddle llength $data] @@ -1167,11 +1170,11 @@ 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 @@ -1196,92 +1199,77 @@ } return $result$text } ######################## -## Huddle Settings ## +## YAML TYPES ## ######################## - -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" +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 [huddle to_node $value !!str] - } - return [huddle wrap !!map $resultL] - } - default { ; # devolving to default dict-callback - return [huddle call D $command $args] - } - } -} - -proc ::yaml::_huddle_sequence {command args} { - switch -- $command { - setting { ; # type definition - return { - type list - method {sequence} - tag {!!seq parent} - constructor sequence - str !!str - } - } - sequence { + 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 [huddle to_node $value !!str] + lappend resultL [argument_to_node $value !!str] } - return [huddle wrap !!seq $resultL] + return [wrap [list !!seq $resultL]] } - default { - return [huddle call L $command $args] - } + } } proc ::yaml::_makeChildType {type tag} { - set procname ::yaml::_huddle_$type - proc $procname {command args} [string map "@TYPE@ $type @TAG@ $tag" { - switch -- $command { - setting { ; # type definition - return { - type @TYPE@ - method {} - tag {@TAG@ child} - constructor "" - str @TAG@ - } - } - default { - return [huddle call s $command $args] - } - } - }] - return $procname -} - -huddle addType ::yaml::_huddle_mapping -huddle addType ::yaml::_huddle_sequence -huddle addType [::yaml::_makeChildType string !!str] -huddle addType [::yaml::_makeChildType string !!timestamp] -huddle addType [::yaml::_makeChildType string !!float] -huddle addType [::yaml::_makeChildType string !!int] -huddle addType [::yaml::_makeChildType string !!null] -huddle addType [::yaml::_makeChildType string !!true] -huddle addType [::yaml::_makeChildType string !!false] -huddle addType [::yaml::_makeChildType string !!binary] -huddle addType [::yaml::_makeChildType plain !!plain] + 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 add_type ::yaml::types::mapping +huddle add_type ::yaml::types::sequence + +huddle add_type [::yaml::_makeChildType str !!str] +huddle add_type [::yaml::_makeChildType timestamp !!timestamp] +huddle add_type [::yaml::_makeChildType float !!float] +huddle add_type [::yaml::_makeChildType int !!int] +huddle add_type [::yaml::_makeChildType null !!null] +huddle add_type [::yaml::_makeChildType true !!true] +huddle add_type [::yaml::_makeChildType false !!false] +huddle add_type [::yaml::_makeChildType binary !!binary] +huddle add_type [::yaml::_makeChildType plain !!plain] Index: modules/yaml/yaml.test ================================================================== --- modules/yaml/yaml.test +++ modules/yaml/yaml.test @@ -19,23 +19,18 @@ # 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 huddle.tcl huddle + 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]