tri ;
: atom-entry-link ( tag -- url/f )
- "link" tags-named [ "rel" swap at "alternate" = ] find nip
- dup [ "href" swap at >url ] when ;
+ "link" tags-named [ "rel" attr "alternate" = ] find nip
+ dup [ "href" attr >url ] when ;
: atom1.0-entry ( tag -- entry )
entry new
feed new
swap
[ "title" tag-named children>string >>title ]
- [ "link" tag-named "href" swap at >url >>url ]
+ [ "link" tag-named "href" attr >url >>url ]
[ "entry" tags-named [ atom1.0-entry ] map set-entries ]
tri ;
[ assure-name ] [ T{ attrs } assoc-like ] [ ] tri*
tag boa ;
-! For convenience, tags follow the assoc protocol too (for attrs)
-CONSULT: assoc-protocol tag attrs>> ;
-INSTANCE: tag assoc
+: attr ( tag name -- string )
+ swap attrs>> at ;
+
+: set-attr ( tag value name -- )
+ rot attrs>> set-at ;
! They also follow the sequence protocol (for children)
CONSULT: sequence-protocol tag children>> ;
PREDICATE: contained-tag < tag children>> not ;
PREDICATE: open-tag < tag children>> ;
-UNION: xml-data
- tag comment string directive instruction ;
-
TUPLE: unescaped string ;
C: <unescaped> unescaped
+
+UNION: xml-data
+ tag comment string directive instruction unescaped ;
+
+TUPLE: xml-chunk seq ;
+C: <xml-chunk> xml-chunk
+
+CONSULT: sequence-protocol xml-chunk seq>> ;
+INSTANCE: xml-chunk sequence
dup { "1.0" "1.1" } member? [ bad-version ] unless ;
: prolog-version ( alist -- version )
- T{ name f "" "version" f } swap at
+ T{ name { space "" } { main "version" } } swap at
[ good-version ] [ versionless-prolog ] if* ;
: prolog-encoding ( alist -- encoding )
- T{ name f "" "encoding" f } swap at "UTF-8" or ;
+ T{ name { space "" } { main "encoding" } } swap at
+ "UTF-8" or ;
: yes/no>bool ( string -- t/f )
{
} case ;
: prolog-standalone ( alist -- version )
- T{ name f "" "standalone" f } swap at
+ T{ name { space "" } { main "standalone" } } swap at
[ yes/no>bool ] [ f ] if* ;
: prolog-attrs ( alist -- prolog )
! See http://factorcode.org/license.txt for BSD license.
USING: tools.test xml.interpolate multiline kernel assocs
sequences accessors xml.writer xml.interpolate.private
-locals splitting urls ;
+locals splitting urls xml.data ;
IN: xml.interpolate.tests
[ "a" "c" { "a" "c" f } ] [
"<?xml version='1.0'?><x><-a-><b val=<-c->/><-></x>"
string>doc
[ second var>> ]
- [ fourth "val" swap at var>> ]
+ [ fourth "val" attr var>> ]
[ extract-variables ] tri
] unit-test
M: xml-data push-item , ;
M: object push-item present , ;
M: sequence push-item
- [ dup array? [ % ] [ , ] if ] each ;
+ dup xml-data? [ , ] [ [ push-item ] each ] if ;
M: number push-item present , ;
+M: xml-chunk push-item % ;
GENERIC: interpolate-item ( table item -- )
M: object interpolate-item nip , ;
[ "a" ] [ xml-file get space>> ] unit-test
[ "http://www.hello.com" ] [ xml-file get url>> ] unit-test
[ "that" ] [
- xml-file get T{ name f "" "this" "http://d.de" } swap at
+ xml-file get T{ name f "" "this" "http://d.de" } attr
] unit-test
[ t ] [ xml-file get children>> second contained-tag? ] unit-test
[ "<a></b>" string>xml ] [ xml-error? ] must-fail-with
xml-file get after>> [ instruction? ] find nip text>>
] unit-test
[ V{ "fa&g" } ] [ xml-file get "x" get-id children>> ] unit-test
-[ "that" ] [ xml-file get "this" swap at ] unit-test
+[ "that" ] [ xml-file get "this" attr ] unit-test
[ "abcd" ] [
"<main>a<sub>bc</sub>d<nothing/></main>" string>xml
[ [ dup string? [ % ] [ drop ] if ] deep-each ] "" make
"<a><b id='c'>foo</b><d id='e'/></a>" string>xml
"c" get-id children>string
] unit-test
-[ "foo" ] [ "<x y='foo'/>" string>xml "y" over
- at swap "z" [ tuck ] dip swap set-at
- T{ name f "blah" "z" f } swap at ] unit-test
+[ "foo" ] [
+ "<x y='foo'/>" string>xml
+ dup dup "y" attr "z" set-attr
+ T{ name { space "blah" } { main "z" } } attr
+] unit-test
[ "foo" ] [ "<boo><![CDATA[foo]]></boo>" string>xml children>string ] unit-test
[ "<!-- B+, B, or B--->" string>xml ] must-fail
[ ] [ "<?xml version='1.0'?><!-- declarations for <head> & <body> --><foo/>" string>xml drop ] unit-test
[ T{ doctype-decl f "foo" T{ system-id f "blah.dtd" } } ] [ "<!DOCTYPE foo SYSTEM 'blah.dtd'>" string>xml-chunk first ] unit-test
[ T{ doctype-decl f "foo" T{ system-id f "blah.dtd" } } ] [ "<!DOCTYPE foo SYSTEM \"blah.dtd\" >" string>xml-chunk first ] unit-test
[ 958 ] [ [ "ξ" string>xml-chunk ] with-html-entities first first ] unit-test
-[ "x" "<" ] [ "<x value='<'/>" string>xml [ name>> main>> ] [ "value" swap at ] bi ] unit-test
+[ "x" "<" ] [ "<x value='<'/>" string>xml [ name>> main>> ] [ "value" attr ] bi ] unit-test
[ "foo" ] [ "<!DOCTYPE foo [<!ENTITY bar 'foo'>]><x>&bar;</x>" string>xml children>string ] unit-test
+[ T{ xml-chunk f V{ "hello" } } ] [ "hello" string>xml-chunk ] unit-test
USING: accessors assocs combinators continuations fry generalizations
io.pathnames kernel macros sequences stack-checker tools.test xml
-xml.utilities xml.writer arrays ;
+xml.utilities xml.writer arrays xml.data ;
IN: xml.tests.suite
TUPLE: xml-test id uri sections description type ;
: >xml-test ( tag -- test )
xml-test new swap {
- [ "TYPE" swap at >>type ]
- [ "ID" swap at >>id ]
- [ "URI" swap at >>uri ]
- [ "SECTIONS" swap at >>sections ]
+ [ "TYPE" attr >>type ]
+ [ "ID" attr >>id ]
+ [ "URI" attr >>uri ]
+ [ "SECTIONS" attr >>sections ]
[ children>> xml-chunk>string >>description ]
} cleave ;
: failing-valids ( -- tests )
partition-xml-tests nip [ second first ] map [ type>> "valid" = ] filter ;
+
+[ ] [ partition-xml-tests 2drop ] unit-test
<x>&foo;</x>"} pprint-reprints-as
[ t ] [ "<!DOCTYPE html PUBLIC '-//W3C//DTD XHTML 1.1//EN' 'http://www.w3.org/TR/xhtml11/DTD/xhtml11.dtd' >" dup string>xml-chunk xml-chunk>string = ] unit-test
-[ V{ "hello" } ] [ "hello" string>xml-chunk ] unit-test
[ "<?xml version=\"1.0\" encoding=\"UTF-8\"?><a b=\"c\"/>" ]
[ "<a b='c'/>" string>xml xml>string ] unit-test
[ "<?xml version=\"1.0\" encoding=\"UTF-8\"?><foo>bar baz</foo>" ]
: read-xml-chunk ( stream -- seq )
1 depth
- [ (read-xml-chunk) nip ] with-variable ;
+ [ (read-xml-chunk) nip ] with-variable
+ <xml-chunk> ;
: string>xml ( string -- xml )
t string-input?
parse-props-tag >>props drop ;
TAG: IMPORT
- "DELEGATE" swap at swap import-rule-set ;
+ "DELEGATE" attr swap import-rule-set ;
TAG: TERMINATE
- "AT_CHAR" swap at string>number >>terminate-char drop ;
+ "AT_CHAR" attr string>number >>terminate-char drop ;
RULE: SEQ seq-rule
shared-tag-attrs delegate-attr literal-start ;
: tokenize-line ( line-context line rules -- line-context' seq )
[
- "MAIN" swap at -rot
+ "MAIN" attr -rot
init-token-marker
mark-token-loop
mark-remaining