! See http://factorcode.org/license.txt for BSD license.
USING: kernel namespaces sequences words io assocs
quotations strings parser arrays xml.data xml.writer debugger
-splitting ;
+splitting vectors ;
IN: xml.utilities
! * System for words specialized on tag names
! * Common utility functions
: build-tag* ( items name -- tag )
- "" swap "" <name>
- swap >r { } r> <tag> ;
+ assure-name swap >r f r> <tag> ;
: build-tag ( item name -- tag )
>r 1array r> build-tag* ;
+: standard-prolog ( -- prolog )
+ T{ prolog f "1.0" "iso-8859-1" f } ;
+
: build-xml ( tag -- xml )
- T{ prolog f "1.0" "iso-8859-1" f } { } rot { } <xml> ;
+ standard-prolog { } rot { } <xml> ;
: children>string ( tag -- string )
tag-children
GENERIC# xml-find 1 ( quot tag -- tag ) inline
M: tag xml-find
- [ call ] 2keep spin [
+ [ call ] 2keep swap rot [
f swap
[ nip over >r swap xml-find r> swap dup ] find
2drop ! leaves result of quot
M: xml xml-inject >r delegate >r xml-inject ;
! * Accessing part of an XML document
+! for tag- words, a start means that it searches all children
+! and no star searches only direct children
-: get-id ( tag id -- elem ) ! elem=tag.getElementById(id)
- swap [
- dup tag?
- [ "id" swap at over = ]
- [ drop f ] if
- ] xml-find nip ;
-
-: (get-tag) ( name elem -- ? )
+: tag-named? ( name elem -- ? )
dup tag? [ names-match? ] [ 2drop f ] if ;
: tag-named* ( tag name/string -- matching-tag )
- assure-name swap [ dupd (get-tag) ] xml-find nip ;
+ assure-name swap [ dupd tag-named? ] xml-find nip ;
: tags-named* ( tag name/string -- tags-seq )
- assure-name swap [ dupd (get-tag) ] xml-subset nip ;
+ assure-name swap [ dupd tag-named? ] xml-subset nip ;
: tag-named ( tag name/string -- matching-tag )
! like get-name-tag but only looks at direct children,
! not all the children down the tree.
- assure-name swap [ (get-tag) ] curry* find nip ;
+ assure-name swap [ tag-named? ] curry* find nip ;
: tags-named ( tag name/string -- tags-seq )
- assure-name swap [ (get-tag) ] curry* subset ;
+ assure-name swap [ tag-named? ] curry* subset ;
: assert-tag ( name name -- )
names-match? [ "Unexpected XML tag found" throw ] unless ;
+
+: insert-children ( children tag -- )
+ dup tag-children [ push-all ]
+ [ >r V{ } like r> set-tag-children ] if ;
+
+: insert-child ( child tag -- )
+ >r 1vector r> insert-children ;
+
+: tag-with-attr? ( elem attr-value attr-name -- ? )
+ rot dup tag? [ at = ] [ drop f ] if ;
+
+: tag-with-attr ( tag attr-value attr-name -- matching-tag )
+ assure-name [ tag-with-attr? ] 2curry find nip ;
+
+: tags-with-attr ( tag attr-value attr-name -- tags-seq )
+ assure-name [ tag-with-attr? ] 2curry subset ;
+
+: tag-with-attr* ( tag attr-value attr-name -- matching-tag )
+ assure-name [ tag-with-attr? ] 2curry xml-find nip ;
+
+: tags-with-attr* ( tag attr-value attr-name -- tags-seq )
+ assure-name [ tag-with-attr? ] 2curry xml-subset ;
+
+: get-id ( tag id -- elem ) ! elem=tag.getElementById(id)
+ "id" tag-with-attr ;
+
+: tags-named-with-attr* ( tag tag-name attr-value attr-name -- tags )
+ >r >r tags-named* r> r> tags-with-attr ;