Merge branch 'xml-utils'
commit
49b8380787
|
@ -1,6 +1,6 @@
|
||||||
! Copyright (C) 2005, 2006 Daniel Ehrenberg
|
! Copyright (C) 2005, 2006 Daniel Ehrenberg
|
||||||
! See http://factorcode.org/license.txt for BSD license.
|
! See http://factorcode.org/license.txt for BSD license.
|
||||||
USING: kernel sequences sequences.private assocs arrays ;
|
USING: kernel sequences sequences.private assocs arrays vectors ;
|
||||||
IN: xml.data
|
IN: xml.data
|
||||||
|
|
||||||
TUPLE: name space tag url ;
|
TUPLE: name space tag url ;
|
||||||
|
@ -60,7 +60,8 @@ M: attrs set-at
|
||||||
2dup attr@ nip [
|
2dup attr@ nip [
|
||||||
2nip set-second
|
2nip set-second
|
||||||
] [
|
] [
|
||||||
>r assure-name swap 2array r> push
|
[ >r assure-name swap 2array r> ?push ] keep
|
||||||
|
set-delegate
|
||||||
] if* ;
|
] if* ;
|
||||||
|
|
||||||
M: attrs assoc-size length ;
|
M: attrs assoc-size length ;
|
||||||
|
@ -68,14 +69,15 @@ M: attrs new-assoc drop V{ } new <attrs> ;
|
||||||
M: attrs >alist delegate >alist ;
|
M: attrs >alist delegate >alist ;
|
||||||
|
|
||||||
: >attrs ( assoc -- attrs )
|
: >attrs ( assoc -- attrs )
|
||||||
V{ } assoc-clone-like
|
dup [
|
||||||
[ >r assure-name r> ] assoc-map
|
V{ } assoc-clone-like
|
||||||
<attrs> ;
|
[ >r assure-name r> ] assoc-map
|
||||||
|
] when <attrs> ;
|
||||||
M: attrs assoc-like
|
M: attrs assoc-like
|
||||||
drop dup attrs? [ >attrs ] unless ;
|
drop dup attrs? [ >attrs ] unless ;
|
||||||
|
|
||||||
M: attrs clear-assoc
|
M: attrs clear-assoc
|
||||||
delete-all ;
|
f swap set-delegate ;
|
||||||
M: attrs delete-at
|
M: attrs delete-at
|
||||||
tuck attr@ drop [ swap delete-nth ] [ drop ] if* ;
|
tuck attr@ drop [ swap delete-nth ] [ drop ] if* ;
|
||||||
|
|
||||||
|
|
|
@ -2,7 +2,7 @@
|
||||||
! See http://factorcode.org/license.txt for BSD license.
|
! See http://factorcode.org/license.txt for BSD license.
|
||||||
USING: kernel namespaces sequences words io assocs
|
USING: kernel namespaces sequences words io assocs
|
||||||
quotations strings parser arrays xml.data xml.writer debugger
|
quotations strings parser arrays xml.data xml.writer debugger
|
||||||
splitting ;
|
splitting vectors ;
|
||||||
IN: xml.utilities
|
IN: xml.utilities
|
||||||
|
|
||||||
! * System for words specialized on tag names
|
! * System for words specialized on tag names
|
||||||
|
@ -36,14 +36,16 @@ M: process-missing error.
|
||||||
! * Common utility functions
|
! * Common utility functions
|
||||||
|
|
||||||
: build-tag* ( items name -- tag )
|
: build-tag* ( items name -- tag )
|
||||||
"" swap "" <name>
|
assure-name swap >r f r> <tag> ;
|
||||||
swap >r { } r> <tag> ;
|
|
||||||
|
|
||||||
: build-tag ( item name -- tag )
|
: build-tag ( item name -- tag )
|
||||||
>r 1array r> build-tag* ;
|
>r 1array r> build-tag* ;
|
||||||
|
|
||||||
|
: standard-prolog ( -- prolog )
|
||||||
|
T{ prolog f "1.0" "iso-8859-1" f } ;
|
||||||
|
|
||||||
: build-xml ( tag -- xml )
|
: build-xml ( tag -- xml )
|
||||||
T{ prolog f "1.0" "iso-8859-1" f } { } rot { } <xml> ;
|
standard-prolog { } rot { } <xml> ;
|
||||||
|
|
||||||
: children>string ( tag -- string )
|
: children>string ( tag -- string )
|
||||||
tag-children
|
tag-children
|
||||||
|
@ -111,30 +113,54 @@ M: object xml-inject 2drop ;
|
||||||
M: xml xml-inject >r delegate >r xml-inject ;
|
M: xml xml-inject >r delegate >r xml-inject ;
|
||||||
|
|
||||||
! * Accessing part of an XML document
|
! * 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)
|
: tag-named? ( name elem -- ? )
|
||||||
swap [
|
|
||||||
dup tag?
|
|
||||||
[ "id" swap at over = ]
|
|
||||||
[ drop f ] if
|
|
||||||
] xml-find nip ;
|
|
||||||
|
|
||||||
: (get-tag) ( name elem -- ? )
|
|
||||||
dup tag? [ names-match? ] [ 2drop f ] if ;
|
dup tag? [ names-match? ] [ 2drop f ] if ;
|
||||||
|
|
||||||
: tag-named* ( tag name/string -- matching-tag )
|
: tag-named* ( tag name/string -- matching-tag )
|
||||||
assure-name swap [ dupd (get-tag) ] xml-find nip ;
|
assure-name swap [ dupd tag-matches? ] xml-find nip ;
|
||||||
|
|
||||||
: tags-named* ( tag name/string -- tags-seq )
|
: tags-named* ( tag name/string -- tags-seq )
|
||||||
assure-name swap [ dupd (get-tag) ] xml-subset nip ;
|
assure-name swap [ dupd tag-matches? ] xml-subset nip ;
|
||||||
|
|
||||||
: tag-named ( tag name/string -- matching-tag )
|
: tag-named ( tag name/string -- matching-tag )
|
||||||
! like get-name-tag but only looks at direct children,
|
! like get-name-tag but only looks at direct children,
|
||||||
! not all the children down the tree.
|
! not all the children down the tree.
|
||||||
assure-name swap [ (get-tag) ] curry* find nip ;
|
assure-name swap [ tag-matches? ] curry* find nip ;
|
||||||
|
|
||||||
: tags-named ( tag name/string -- tags-seq )
|
: tags-named ( tag name/string -- tags-seq )
|
||||||
assure-name swap [ (get-tag) ] curry* subset ;
|
assure-name swap [ tag-matches? ] curry* subset ;
|
||||||
|
|
||||||
: assert-tag ( name name -- )
|
: assert-tag ( name name -- )
|
||||||
names-match? [ "Unexpected XML tag found" throw ] unless ;
|
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 ;
|
||||||
|
|
||||||
|
|
Loading…
Reference in New Issue