steve
/
factor
1
0
Fork 0
Code Issues Pull Requests Releases Wiki Activity

Fix some bugs in xml.utilities and add new unit tests

db4
Slava Pestov 2009-01-31 21:01:55 -06:00
parent 55bbbd0ff0
commit 1194ce38aa
2 changed files with 30 additions and 16 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

10
basis/xml/utilities/utilities-tests.factor
View File

@ -1,6 +1,6 @@
! Copyright (C) 2005, 2009 Daniel Ehrenberg ! Copyright (C) 2005, 2009 Daniel Ehrenberg
! See http://factorcode.org/license.txt for BSD license. ! See http://factorcode.org/license.txt for BSD license.
USING: xml xml.utilities tools.test xml.data ; USING: xml xml.utilities tools.test xml.data sequences ;
IN: xml.utilities.tests IN: xml.utilities.tests
[ "bar" ] [ "<foo>bar</foo>" string>xml children>string ] unit-test [ "bar" ] [ "<foo>bar</foo>" string>xml children>string ] unit-test
@ -12,3 +12,11 @@ IN: xml.utilities.tests
XML-NS: foo http://blah.com XML-NS: foo http://blah.com
[ T{ name { main "bling" } { url "http://blah.com" } } ] [ "bling" foo ] unit-test [ T{ name { main "bling" } { url "http://blah.com" } } ] [ "bling" foo ] unit-test
[ "blah" ] [ "<foo attr='blah'/>" string>xml-chunk "foo" deep-tag-named "attr" attr ] unit-test
[ { "blah" } ] [ "<foo attr='blah'/>" string>xml-chunk "foo" deep-tags-named [ "attr" attr ] map ] unit-test
[ "blah" ] [ "<foo attr='blah'/>" string>xml "foo" deep-tag-named "attr" attr ] unit-test
[ { "blah" } ] [ "<foo attr='blah'/>" string>xml "foo" deep-tags-named [ "attr" attr ] map ] unit-test

36
basis/xml/utilities/utilities.factor
View File

@ -8,8 +8,10 @@ IN: xml.utilities
: children>string ( tag -- string ) : children>string ( tag -- string )
children>> { children>> {
{ [ dup empty? ] [ drop "" ] } { [ dup empty? ] [ drop "" ] }
{ [ dup [ string? not ] any? ] {
[ "XML tag unexpectedly contains non-text children" throw ] } [ dup [ string? not ] any? ]
[ "XML tag unexpectedly contains non-text children" throw ]
}
[ concat ] [ concat ]
} cond ; } cond ;
@ -22,20 +24,24 @@ IN: xml.utilities
: tag-named? ( name elem -- ? ) : tag-named? ( name elem -- ? )
dup tag? [ names-match? ] [ 2drop f ] if ; dup tag? [ names-match? ] [ 2drop f ] if ;
: tags@ ( tag name -- children name )
[ { } like ] dip assure-name ;
: deep-tag-named ( tag name/string -- matching-tag )
assure-name '[ _ swap tag-named? ] deep-find ;
: deep-tags-named ( tag name/string -- tags-seq )
tags@ '[ _ swap tag-named? ] deep-filter ;
: tag-named ( tag name/string -- matching-tag ) : tag-named ( tag name/string -- matching-tag )
assure-name swap [ tag-named? ] with find nip ; assure-name '[ _ swap tag-named? ] find nip ;
: tags-named ( tag name/string -- tags-seq ) : tags-named ( tag name/string -- tags-seq )
tags@ swap [ tag-named? ] with filter ; assure-name '[ _ swap tag-named? ] filter { } like ;
<PRIVATE
: prepare-deep ( xml name/string -- tag name/string )
[ dup xml? [ body>> ] when ] [ assure-name ] bi* ;
PRIVATE>
: deep-tag-named ( tag name/string -- matching-tag )
prepare-deep '[ _ swap tag-named? ] deep-find ;
: deep-tags-named ( tag name/string -- tags-seq )
prepare-deep '[ _ swap tag-named? ] deep-filter { } like ;
: tag-with-attr? ( elem attr-value attr-name -- ? ) : tag-with-attr? ( elem attr-value attr-name -- ? )
rot dup tag? [ swap attr = ] [ 3drop f ] if ; rot dup tag? [ swap attr = ] [ 3drop f ] if ;
@ -44,13 +50,13 @@ IN: xml.utilities
assure-name '[ _ _ tag-with-attr? ] find nip ; assure-name '[ _ _ tag-with-attr? ] find nip ;
: tags-with-attr ( tag attr-value attr-name -- tags-seq ) : tags-with-attr ( tag attr-value attr-name -- tags-seq )
tags@ '[ _ _ tag-with-attr? ] filter children>> ; assure-name '[ _ _ tag-with-attr? ] filter children>> ;
: deep-tag-with-attr ( tag attr-value attr-name -- matching-tag ) : deep-tag-with-attr ( tag attr-value attr-name -- matching-tag )
assure-name '[ _ _ tag-with-attr? ] deep-find ; assure-name '[ _ _ tag-with-attr? ] deep-find ;
: deep-tags-with-attr ( tag attr-value attr-name -- tags-seq ) : deep-tags-with-attr ( tag attr-value attr-name -- tags-seq )
tags@ '[ _ _ tag-with-attr? ] deep-filter ; assure-name '[ _ _ tag-with-attr? ] deep-filter ;
: get-id ( tag id -- elem ) : get-id ( tag id -- elem )
"id" deep-tag-with-attr ; "id" deep-tag-with-attr ;