XML chunks are a separate datatype; XML tags are no longer assocs

db4
Daniel Ehrenberg 2009-01-28 14:33:33 -06:00
parent 5402778655
commit af9d70c65a
11 changed files with 46 additions and 31 deletions

View File

@ -70,8 +70,8 @@ TUPLE: entry title url description date ;
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
@ -95,7 +95,7 @@ TUPLE: entry title url description date ;
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 ;

View File

@ -150,9 +150,11 @@ TUPLE: tag
[ 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>> ;
@ -217,8 +219,14 @@ M: xml like
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

View File

@ -65,11 +65,12 @@ IN: xml.elements
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 )
{
@ -79,7 +80,7 @@ IN: xml.elements
} 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 )

View File

@ -2,14 +2,14 @@
! 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

View File

@ -33,8 +33,9 @@ M: string push-item , ;
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 , ;

View File

@ -19,7 +19,7 @@ SYMBOL: xml-file
[ "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
@ -30,7 +30,7 @@ SYMBOL: xml-file
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
@ -43,9 +43,11 @@ SYMBOL: xml-file
"<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
@ -58,5 +60,6 @@ SYMBOL: xml-file
[ 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 ] [ [ "&xi;" string>xml-chunk ] with-html-entities first first ] unit-test
[ "x" "<" ] [ "<x value='&lt;'/>" string>xml [ name>> main>> ] [ "value" swap at ] bi ] unit-test
[ "x" "<" ] [ "<x value='&lt;'/>" 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

View File

@ -1,16 +1,16 @@
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 ;
@ -51,3 +51,5 @@ MACRO: drop-input ( quot -- newquot )
: failing-valids ( -- tests )
partition-xml-tests nip [ second first ] map [ type>> "valid" = ] filter ;
[ ] [ partition-xml-tests 2drop ] unit-test

View File

@ -52,7 +52,6 @@ IN: xml.writer.tests
<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>" ]

View File

@ -162,7 +162,8 @@ PRIVATE>
: 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?

View File

@ -13,10 +13,10 @@ TAG: PROPS
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 ;

View File

@ -297,7 +297,7 @@ M: mark-previous-rule handle-rule-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