{ [ dup [ tag? ] [ xml? ] bi or ] [ compile-tag ] }
{ [ dup string? ] [ escape-string [write] ] }
{ [ dup comment? ] [ drop ] }
- [ [ write-item ] [code-with] ]
+ [ [ write-xml-chunk ] [code-with] ]
} cond ;
: with-compiler ( quot -- quot' )
[
{ "content" "summary" } any-tag-named
dup children>> [ string? not ] contains?
- [ children>> [ write-chunk ] with-string-writer ]
+ [ children>> [ write-xml-chunk ] with-string-writer ]
[ children>string ] if >>description
]
[
! See http://factorcode.org/license.txt for BSD license.
USING: kernel sequences sequences.private assocs arrays
delegate.protocols delegate vectors accessors multiline
-macros words quotations combinators slots ;
+macros words quotations combinators slots fry ;
IN: xml.data
TUPLE: name space main url ;
TUPLE: comment text ;
C: <comment> comment
-TUPLE: directive text ;
-C: <directive> directive
+TUPLE: directive ;
+
+TUPLE: element-decl < directive name content-spec ;
+C: <element-decl> element-decl
+
+TUPLE: attlist-decl < directive name att-defs ;
+C: <attlist-decl> attlist-decl
+
+TUPLE: entity-decl < directive name def ;
+C: <entity-decl> entity-decl
+
+TUPLE: system-id system-literal ;
+C: <system-id> system-id
+
+TUPLE: public-id pubid-literal system-literal ;
+C: <public-id> public-id
+
+TUPLE: doctype-decl < directive name external-id internal-subset ;
+C: <doctype-decl> doctype-decl
TUPLE: instruction text ;
C: <instruction> instruction
C: <attrs> attrs
: attr@ ( key alist -- index {key,value} )
- >r assure-name r> alist>>
+ [ assure-name ] dip alist>>
[ first names-match? ] with find ;
M: attrs at*
2dup attr@ nip [
2nip set-second
] [
- >r assure-name swap 2array r>
+ [ assure-name swap 2array ] dip
[ alist>> ?push ] keep (>>alist)
] if* ;
: >attrs ( assoc -- attrs )
dup [
V{ } assoc-clone-like
- [ >r assure-name r> ] assoc-map
+ [ [ assure-name ] dip ] assoc-map
] when <attrs> ;
M: attrs assoc-like
drop dup attrs? [ >attrs ] unless ;
MACRO: clone-slots ( class -- tuple )
[
"slots" word-prop
- [ name>> reader-word 1quotation [ clone ] compose ] map
- [ cleave ] curry
- ] [ [ boa ] curry ] bi compose ;
+ [ name>> reader-word '[ _ execute clone ] ] map
+ '[ _ cleave ]
+ ] [ '[ _ boa ] ] bi compose ;
M: tag clone
tag clone-slots ;
<PRIVATE
: tag>xml ( xml tag -- newxml )
- >r [ prolog>> ] [ before>> ] [ after>> ] tri r>
+ [ [ prolog>> ] [ before>> ] [ after>> ] tri ] dip
swap <xml> ;
: seq>xml ( xml seq -- newxml )
! Copyright (C) 2005, 2006 Daniel Ehrenberg
! See http://factorcode.org/license.txt for BSD license.
-USING: namespaces make kernel assocs sequences ;
+USING: namespaces make kernel assocs sequences fry ;
IN: xml.entities
: entities-out
: escape-string-by ( str table -- escaped )
#! Convert <, >, &, ' and " to HTML entities.
- [ [ dupd at [ % ] [ , ] ?if ] curry each ] "" make ;
+ [ '[ dup _ at [ % ] [ , ] ?if ] each ] "" make ;
: escape-string ( str -- newstr )
entities-out escape-string-by ;
-USING: continuations xml xml.errors tools.test kernel arrays xml.data state-parser quotations ;
+USING: continuations xml xml.errors tools.test kernel arrays
+xml.data state-parser quotations fry ;
IN: xml.errors.tests
: xml-error-test ( expected-error xml-string -- )
- [ string>xml ] curry swap [ = ] curry must-fail-with ;
+ '[ _ string>xml ] swap '[ _ = ] must-fail-with ;
T{ no-entity f 1 10 "nbsp" } "<x> </x>" xml-error-test
T{ mismatched f 1 8 T{ name f "" "x" "" } T{ name f "" "y" "" }
T{ versionless-prolog f 1 8 } "<?xml?><x/>" xml-error-test
T{ bad-instruction f 1 11 T{ instruction f "xsl" }
} "<x><?xsl?></x>" xml-error-test
-T{ bad-directive f 1 15 T{ directive f "DOCTYPE" }
-} "<x/><!DOCTYPE>" xml-error-test
namespaces io.streams.string xml.backend ;
IN: xml.errors
-TUPLE: multitags ;
-C: <multitags> multitags
+ERROR: multitags ;
+
M: multitags summary ( obj -- str )
drop "XML document contains multiple main tags" ;
-TUPLE: pre/post-content string pre? ;
-C: <pre/post-content> pre/post-content
+ERROR: pre/post-content string pre? ;
+
M: pre/post-content summary ( obj -- str )
[
"The text string:" print
] with-string-writer ;
TUPLE: no-entity < parsing-error thing ;
-: <no-entity> ( string -- error )
- \ no-entity parsing-error swap >>thing ;
+
+: no-entity ( string -- * )
+ \ no-entity parsing-error swap >>thing throw ;
+
M: no-entity summary ( obj -- str )
[
dup call-next-method write
] with-string-writer ;
TUPLE: xml-string-error < parsing-error string ; ! this should not exist
-: <xml-string-error> ( string -- xml-string-error )
- \ xml-string-error parsing-error swap >>string ;
+
+: xml-string-error ( string -- * )
+ \ xml-string-error parsing-error swap >>string throw ;
+
M: xml-string-error summary ( obj -- str )
[
dup call-next-method write
] with-string-writer ;
TUPLE: mismatched < parsing-error open close ;
-: <mismatched> ( open close -- error )
- \ mismatched parsing-error swap >>close swap >>open ;
+
+: mismatched ( open close -- * )
+ \ mismatched parsing-error swap >>close swap >>open throw ;
+
M: mismatched summary ( obj -- str )
[
dup call-next-method write
] with-string-writer ;
TUPLE: unclosed < parsing-error tags ;
-: <unclosed> ( -- unclosed )
- unclosed parsing-error
- xml-stack get rest-slice [ first name>> ] map >>tags ;
+
+: unclosed ( -- * )
+ \ unclosed parsing-error
+ xml-stack get rest-slice [ first name>> ] map >>tags
+ throw ;
+
M: unclosed summary ( obj -- str )
[
dup call-next-method write
] with-string-writer ;
TUPLE: bad-uri < parsing-error string ;
-: <bad-uri> ( string -- bad-uri )
- \ bad-uri parsing-error swap >>string ;
+
+: bad-uri ( string -- * )
+ \ bad-uri parsing-error swap >>string throw ;
+
M: bad-uri summary ( obj -- str )
[
dup call-next-method write
] with-string-writer ;
TUPLE: nonexist-ns < parsing-error name ;
-: <nonexist-ns> ( name-string -- nonexist-ns )
- \ nonexist-ns parsing-error swap >>name ;
+
+: nonexist-ns ( name-string -- * )
+ \ nonexist-ns parsing-error swap >>name throw ;
+
M: nonexist-ns summary ( obj -- str )
[
dup call-next-method write
] with-string-writer ;
TUPLE: unopened < parsing-error ; ! this should give which tag was unopened
-: <unopened> ( -- unopened )
- \ unopened parsing-error ;
+
+: unopened ( -- * )
+ \ unopened parsing-error throw ;
+
M: unopened summary ( obj -- str )
[
call-next-method write
] with-string-writer ;
TUPLE: not-yes/no < parsing-error text ;
-: <not-yes/no> ( text -- not-yes/no )
- \ not-yes/no parsing-error swap >>text ;
+
+: not-yes/no ( text -- * )
+ \ not-yes/no parsing-error swap >>text throw ;
+
M: not-yes/no summary ( obj -- str )
[
dup call-next-method write
! this should actually print the names
TUPLE: extra-attrs < parsing-error attrs ;
-: <extra-attrs> ( attrs -- extra-attrs )
- \ extra-attrs parsing-error swap >>attrs ;
+
+: extra-attrs ( attrs -- * )
+ \ extra-attrs parsing-error swap >>attrs throw ;
+
M: extra-attrs summary ( obj -- str )
[
dup call-next-method write
] with-string-writer ;
TUPLE: bad-version < parsing-error num ;
-: <bad-version> ( num -- error )
- \ bad-version parsing-error swap >>num ;
+
+: bad-version ( num -- * )
+ \ bad-version parsing-error swap >>num throw ;
+
M: bad-version summary ( obj -- str )
[
"XML version must be \"1.0\" or \"1.1\". Version here was " write
num>> .
] with-string-writer ;
-TUPLE: notags ;
-C: <notags> notags
+ERROR: notags ;
+
M: notags summary ( obj -- str )
drop "XML document lacks a main tag" ;
TUPLE: bad-prolog < parsing-error prolog ;
-: <bad-prolog> ( prolog -- bad-prolog )
- \ bad-prolog parsing-error swap >>prolog ;
+
+: bad-prolog ( prolog -- * )
+ \ bad-prolog parsing-error swap >>prolog throw ;
+
M: bad-prolog summary ( obj -- str )
[
dup call-next-method write
] with-string-writer ;
TUPLE: capitalized-prolog < parsing-error name ;
-: <capitalized-prolog> ( name -- capitalized-prolog )
- \ capitalized-prolog parsing-error swap >>name ;
+
+: capitalized-prolog ( name -- capitalized-prolog )
+ \ capitalized-prolog parsing-error swap >>name throw ;
+
M: capitalized-prolog summary ( obj -- str )
[
dup call-next-method write
] with-string-writer ;
TUPLE: versionless-prolog < parsing-error ;
-: <versionless-prolog> ( -- versionless-prolog )
- \ versionless-prolog parsing-error ;
+
+: versionless-prolog ( -- * )
+ \ versionless-prolog parsing-error throw ;
+
M: versionless-prolog summary ( obj -- str )
[
call-next-method write
] with-string-writer ;
TUPLE: bad-instruction < parsing-error instruction ;
-: <bad-instruction> ( instruction -- bad-instruction )
- \ bad-instruction parsing-error swap >>instruction ;
+
+: bad-instruction ( instruction -- * )
+ \ bad-instruction parsing-error swap >>instruction throw ;
+
M: bad-instruction summary ( obj -- str )
[
dup call-next-method write
"Misplaced processor instruction:" print
- instruction>> write-item nl
+ instruction>> write-xml-chunk nl
] with-string-writer ;
TUPLE: bad-directive < parsing-error dir ;
-: <bad-directive> ( directive -- bad-directive )
- \ bad-directive parsing-error swap >>dir ;
+
+: bad-directive ( directive -- * )
+ \ bad-directive parsing-error swap >>dir throw ;
+
M: bad-directive summary ( obj -- str )
+ [
+ dup call-next-method write
+ "Unknown directive:" print
+ dir>> write
+ ] with-string-writer ;
+
+TUPLE: bad-doctype-decl < parsing-error ;
+
+: bad-doctype-decl ( -- * )
+ \ bad-doctype-decl parsing-error throw ;
+
+M: bad-doctype-decl summary ( obj -- str )
+ call-next-method "\nBad DOCTYPE" append ;
+
+TUPLE: bad-external-id < parsing-error ;
+
+: bad-external-id ( -- * )
+ \ bad-external-id parsing-error throw ;
+
+M: bad-external-id summary ( obj -- str )
+ call-next-method "\nBad external ID" append ;
+
+TUPLE: misplaced-directive < parsing-error dir ;
+
+: misplaced-directive ( directive -- * )
+ \ misplaced-directive parsing-error swap >>dir throw ;
+
+M: misplaced-directive summary ( obj -- str )
[
dup call-next-method write
"Misplaced directive:" print
- dir>> write-item nl
+ dir>> write-xml-chunk nl
] with-string-writer ;
UNION: xml-parse-error multitags notags extra-attrs nonexist-ns
USING: tools.test io.streams.string xml.generator xml.writer accessors ;
[ "<html><body><a href=\"blah\"/></body></html>" ]
-[ "html" [ "body" [ "a" { { "href" "blah" } } contained*, ] tag, ] make-xml [ body>> write-item ] with-string-writer ] unit-test
+[ "html" [ "body" [ "a" { { "href" "blah" } } contained*, ] tag, ] make-xml [ body>> write-xml-chunk ] with-string-writer ] unit-test
IN: xml.generator
: comment, ( string -- ) <comment> , ;
-: directive, ( string -- ) <directive> , ;
: instruction, ( string -- ) <instruction> , ;
: nl, ( -- ) "\n" , ;
: (tag,) ( name attrs quot -- tag )
- -rot >r >r V{ } make r> r> rot <tag> ; inline
+ -rot [ V{ } make ] 2dip rot <tag> ; inline
: tag*, ( name attrs quot -- )
(tag,) , ; inline
PROCESS: calculate ( tag -- n )
: calc-2children ( tag -- n n )
- children-tags first2 >r calculate r> calculate ;
+ children-tags first2 [ calculate ] dip calculate ;
TAG: number calculate
children>string string>number ;
--- /dev/null
+! Copyright (C) 2008 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+IN: xml.tests
+USING: xml xml.writer io.files io.encodings.utf8 tools.test kernel ;
+
+[ t ] [
+ "resource:basis/xml/tests/funny-dtd.xml" utf8 file-contents string>xml
+ dup xml>string string>xml =
+] unit-test
--- /dev/null
+<?xml version="1.0" standalone="yes" ?><!DOCTYPE SHOUTCASTSERVER [<!ELEMENT SHOUTCASTSERVER (CURRENTLISTENERS,PEAKLISTENERS,MAXLISTENERS,REPORTEDLISTENERS,AVERAGETIME,SERVERGENRE,SERVERURL,SERVERTITLE,SONGTITLE,SONGURL,IRC,ICQ,AIM,WEBHITS,STREAMHITS,STREAMSTATUS,BITRATE,CONTENT,VERSION,WEBDATA,LISTENERS,SONGHISTORY)><!ELEMENT CURRENTLISTENERS (#PCDATA)><!ELEMENT PEAKLISTENERS (#PCDATA)><!ELEMENT MAXLISTENERS (#PCDATA)><!ELEMENT REPORTEDLISTENERS (#PCDATA)><!ELEMENT AVERAGETIME (#PCDATA)><!ELEMENT SERVERGENRE (#PCDATA)><!ELEMENT SERVERURL (#PCDATA)><!ELEMENT SERVERTITLE (#PCDATA)><!ELEMENT SONGTITLE (#PCDATA)><!ELEMENT SONGURL (#PCDATA)><!ELEMENT IRC (#PCDATA)><!ELEMENT ICQ (#PCDATA)><!ELEMENT AIM (#PCDATA)><!ELEMENT WEBHITS (#PCDATA)><!ELEMENT STREAMHITS (#PCDATA)><!ELEMENT STREAMSTATUS (#PCDATA)><!ELEMENT BITRATE (#PCDATA)><!ELEMENT CONTENT (#PCDATA)><!ELEMENT VERSION (#PCDATA)><!ELEMENT WEBDATA (INDEX,LISTEN,PALM7,LOGIN,LOGINFAIL,PLAYED,COOKIE,ADMIN,UPDINFO,KICKSRC,KICKDST,UNBANDST,BANDST,VIEWBAN,UNRIPDST,RIPDST,VIEWRIP,VIEWXML,VIEWLOG,INVALID)><!ELEMENT INDEX (#PCDATA)><!ELEMENT LISTEN (#PCDATA)><!ELEMENT PALM7 (#PCDATA)><!ELEMENT LOGIN (#PCDATA)><!ELEMENT LOGINFAIL (#PCDATA)><!ELEMENT PLAYED (#PCDATA)><!ELEMENT COOKIE (#PCDATA)><!ELEMENT ADMIN (#PCDATA)><!ELEMENT UPDINFO (#PCDATA)><!ELEMENT KICKSRC (#PCDATA)><!ELEMENT KICKDST (#PCDATA)><!ELEMENT UNBANDST (#PCDATA)><!ELEMENT BANDST (#PCDATA)><!ELEMENT VIEWBAN (#PCDATA)><!ELEMENT UNRIPDST (#PCDATA)><!ELEMENT RIPDST (#PCDATA)><!ELEMENT VIEWRIP (#PCDATA)><!ELEMENT VIEWXML (#PCDATA)><!ELEMENT VIEWLOG (#PCDATA)><!ELEMENT INVALID (#PCDATA)><!ELEMENT LISTENERS (LISTENER*)><!ELEMENT LISTENER (HOSTNAME,USERAGENT,UNDERRUNS,CONNECTTIME, POINTER, UID)><!ELEMENT HOSTNAME (#PCDATA)><!ELEMENT USERAGENT (#PCDATA)><!ELEMENT UNDERRUNS (#PCDATA)><!ELEMENT CONNECTTIME (#PCDATA)><!ELEMENT POINTER (#PCDATA)><!ELEMENT UID (#PCDATA)><!ELEMENT SONGHISTORY (SONG*)><!ELEMENT SONG (PLAYEDAT, TITLE)><!ELEMENT PLAYEDAT (#PCDATA)><!ELEMENT TITLE (#PCDATA)>]><SHOUTCASTSERVER><CURRENTLISTENERS>0</CURRENTLISTENERS><PEAKLISTENERS>3</PEAKLISTENERS><MAXLISTENERS>500</MAXLISTENERS><REPORTEDLISTENERS>0</REPORTEDLISTENERS><AVERAGETIME>85</AVERAGETIME><SERVERGENRE>various</SERVERGENRE><SERVERURL>http://zomgwtfbbq.info</SERVERURL><SERVERTITLE>[zOMBradio][DJKyleL]</SERVERTITLE><SONGTITLE>Daft Punk - One More Time / Aerodynamic</SONGTITLE><SONGURL></SONGURL><IRC></IRC><ICQ></ICQ><AIM>arkz1372</AIM><WEBHITS>1645</WEBHITS><STREAMHITS>78</STREAMHITS><STREAMSTATUS>0</STREAMSTATUS><BITRATE>96</BITRATE><CONTENT>audio/aacp</CONTENT><VERSION>1.9.8</VERSION><WEBDATA><INDEX>61</INDEX><LISTEN>6</LISTEN><PALM7>0</PALM7><LOGIN>0</LOGIN><LOGINFAIL>30</LOGINFAIL><PLAYED>2</PLAYED><COOKIE>1</COOKIE><ADMIN>11</ADMIN><UPDINFO>1</UPDINFO><KICKSRC>0</KICKSRC><KICKDST>0</KICKDST><UNBANDST>0</UNBANDST><BANDST>0</BANDST><VIEWBAN>3</VIEWBAN><UNRIPDST>0</UNRIPDST><RIPDST>1</RIPDST><VIEWRIP>3</VIEWRIP><VIEWXML>1490</VIEWXML><VIEWLOG>3</VIEWLOG><INVALID>30</INVALID></WEBDATA><LISTENERS></LISTENERS><SONGHISTORY><SONG><PLAYEDAT>1227896017</PLAYEDAT><TITLE>Daft Punk - One More Time / Aerodynamic</TITLE></SONG></SONGHISTORY></SHOUTCASTSERVER>
+
! Example
-: sample-doc
+: sample-doc ( -- string )
{
"<html xmlns:f='http://littledan.onigirihouse.com/namespaces/replace'>"
"<body>"
USING: kernel xml tools.test io namespaces make sequences
xml.errors xml.entities parser strings xml.data io.files
xml.writer xml.utilities state-parser continuations assocs
-sequences.deep accessors ;
+sequences.deep accessors io.streams.string ;
! This is insufficient
\ read-xml must-infer
"c" get-id children>string
] unit-test
[ "foo" ] [ "<x y='foo'/>" string>xml "y" over
- at swap "z" >r tuck r> swap set-at
+ at swap "z" [ tuck ] dip swap set-at
T{ name f "blah" "z" f } swap at ] unit-test
[ "foo" ] [ "<boo><![CDATA[foo]]></boo>" string>xml children>string ] unit-test
[ "<?xml version=\"1.0\" encoding=\"UTF-8\"?><foo>bar baz</foo>" ]
[ "<foo>bar</foo>" string>xml [ " baz" append ] map xml>string ] unit-test
[ "<?xml version=\"1.0\" encoding=\"UTF-8\"?>\n<foo>\n bar\n</foo>" ]
[ "<foo> bar </foo>" string>xml pprint-xml>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{ element-decl f "br" "EMPTY" } ] [ "<!ELEMENT br EMPTY>" string>xml-chunk second ] unit-test
+[ T{ element-decl f "p" "(#PCDATA|emph)*" } ] [ "<!ELEMENT p (#PCDATA|emph)*>" string>xml-chunk second ] unit-test
+[ T{ element-decl f "%name.para;" "%content.para;" } ] [ "<!ELEMENT %name.para; %content.para;>" string>xml-chunk second ] unit-test
+[ T{ element-decl f "container" "ANY" } ] [ "<!ELEMENT container ANY>" string>xml-chunk second ] unit-test
+[ T{ doctype-decl f "foo" } ] [ "<!DOCTYPE foo>" string>xml-chunk second ] unit-test
+[ T{ doctype-decl f "foo" } ] [ "<!DOCTYPE foo >" string>xml-chunk second ] unit-test
+[ T{ doctype-decl f "foo" T{ system-id f "blah.dtd" } } ] [ "<!DOCTYPE foo SYSTEM 'blah.dtd'>" string>xml-chunk second ] unit-test
+[ T{ doctype-decl f "foo" T{ system-id f "blah.dtd" } } ] [ "<!DOCTYPE foo SYSTEM \"blah.dtd\" >" string>xml-chunk second ] unit-test
--- /dev/null
+! Copyright (C) 2008 Slava Pestov.
+! See http://factorcode.org/license.txt for BSD license.
+USING: xml io.encodings.utf8 io.files kernel tools.test ;
+IN: xml.tests
+
+[ ] [
+ "resource:basis/xmode/xmode.dtd" utf8 <file-reader>
+ read-xml-chunk drop
+] unit-test
USING: xml.errors xml.data xml.utilities xml.char-classes sets
xml.entities kernel state-parser kernel namespaces make strings
math math.parser sequences assocs arrays splitting combinators
-unicode.case accessors ;
+unicode.case accessors fry ascii ;
IN: xml.tokenize
! XML namespace processing: ns = namespace
: add-ns ( name -- )
dup space>> dup ns-stack get assoc-stack
- [ nip ] [ <nonexist-ns> throw ] if* >>url drop ;
+ [ nip ] [ nonexist-ns ] if* >>url drop ;
: push-ns ( hash -- )
ns-stack get push ;
: tag-ns ( name attrs-alist -- name attrs )
dup attrs>ns push-ns
-
>r dup add-ns r> dup [ drop add-ns ] assoc-each <attrs> ;
+
[ dup add-ns ] dip dup [ drop add-ns ] assoc-each <attrs> ;
! Parsing names
get-char name-start? [
[ dup get-char name-char? not ] take-until nip
] [
- "Malformed name" <xml-string-error> throw
+ "Malformed name" xml-string-error
] if ;
: parse-name ( -- name )
: (parse-entity) ( string -- )
dup entities at [ , ] [
prolog-data get standalone>>
- [ <no-entity> throw ] [
+ [ no-entity ] [
dup extra-entities get at
- [ , ] [ <no-entity> throw ] ?if
+ [ , ] [ no-entity ] ?if
] if
] ?if ;
: parse-quot ( ch -- string )
parse-char get-char
- [ "XML file ends in a quote" <xml-string-error> throw ] unless ;
+ [ "XML file ends in a quote" xml-string-error ] unless ;
: parse-text ( -- string )
CHAR: < parse-char ;
get-char dup "'\"" member? [
next parse-quot
] [
- "Attribute lacks quote" <xml-string-error> throw
+ "Attribute lacks quote" xml-string-error
] if ;
: parse-attr ( -- )
: take-cdata ( -- string )
"[CDATA[" expect-string "]]>" take-string ;
+: take-element-decl ( -- element-decl )
+ pass-blank " " take-string pass-blank ">" take-string <element-decl> ;
+
+: take-attlist-decl ( -- doctype-decl )
+ pass-blank " " take-string pass-blank ">" take-string <attlist-decl> ;
+
+: take-until-one-of ( seps -- str sep )
+ '[ get-char _ member? ] take-until get-char ;
+
+: only-blanks ( str -- )
+ [ blank? ] all? [ bad-doctype-decl ] unless ;
+
+: take-system-literal ( -- str )
+ pass-blank get-char next {
+ { CHAR: ' [ "'" take-string ] }
+ { CHAR: " [ "\"" take-string ] }
+ } case ;
+
+: take-system-id ( -- system-id )
+ take-system-literal <system-id>
+ ">" take-string only-blanks ;
+
+: take-public-id ( -- public-id )
+ take-system-literal
+ take-system-literal <public-id>
+ ">" take-string only-blanks ;
+
+DEFER: direct
+
+: (take-internal-subset) ( -- )
+ pass-blank get-char {
+ { CHAR: ] [ next ] }
+ [ drop "<!" expect-string direct , (take-internal-subset) ]
+ } case ;
+
+: take-internal-subset ( -- seq )
+ [ (take-internal-subset) ] { } make ;
+
+: (take-external-id) ( token -- external-id )
+ pass-blank {
+ { "SYSTEM" [ take-system-id ] }
+ { "PUBLIC" [ take-public-id ] }
+ [ bad-external-id ]
+ } case ;
+
+: take-external-id ( -- external-id )
+ " " take-string (take-external-id) ;
+
+: take-doctype-decl ( -- doctype-decl )
+ pass-blank " >" take-until-one-of {
+ { CHAR: \s [
+ pass-blank get-char CHAR: [ = [
+ next take-internal-subset f swap
+ ">" take-string only-blanks
+ ] [
+ " >" take-until-one-of {
+ { CHAR: \s [ (take-external-id) ] }
+ { CHAR: > [ only-blanks f ] }
+ } case f
+ ] if
+ ] }
+ { CHAR: > [ f f ] }
+ } case <doctype-decl> ;
+
+: take-entity-def ( -- entity-name entity-def )
+ " " take-string pass-blank get-char {
+ { CHAR: ' [ take-system-literal ] }
+ { CHAR: " [ take-system-literal ] }
+ [ drop take-external-id ]
+ } case ;
+
+: take-entity-decl ( -- entity-decl )
+ pass-blank get-char {
+ { CHAR: % [ next pass-blank take-entity-def ] }
+ [ drop take-entity-def ]
+ } case
+ ">" take-string only-blanks <entity-decl> ;
+
: take-directive ( -- directive )
- CHAR: > take-char <directive> next ;
+ " " take-string {
+ { "ELEMENT" [ take-element-decl ] }
+ { "ATTLIST" [ take-attlist-decl ] }
+ { "DOCTYPE" [ take-doctype-decl ] }
+ { "ENTITY" [ take-entity-decl ] }
+ [ bad-directive ]
+ } case ;
: direct ( -- object )
get-char {
{
{ "yes" [ t ] }
{ "no" [ f ] }
- [ <not-yes/no> throw ]
+ [ not-yes/no ]
} case ;
: assure-no-extra ( seq -- )
T{ name f "" "encoding" f }
T{ name f "" "standalone" f }
} diff
- [ <extra-attrs> throw ] unless-empty ;
+ [ extra-attrs ] unless-empty ;
: good-version ( version -- version )
- dup { "1.0" "1.1" } member? [ <bad-version> throw ] unless ;
+ dup { "1.0" "1.1" } member? [ bad-version ] unless ;
: prolog-attrs ( alist -- prolog )
[ T{ name f "" "version" f } swap at
- [ good-version ] [ <versionless-prolog> throw ] if* ] keep
+ [ good-version ] [ versionless-prolog ] if* ] keep
[ T{ name f "" "encoding" f } swap at
"UTF-8" or ] keep
T{ name f "" "standalone" f } swap at
(parse-name) dup "xml" =
[ drop parse-prolog ] [
dup >lower "xml" =
- [ <capitalized-prolog> throw ]
+ [ capitalized-prolog ]
[ "?>" take-string append <instruction> ] if
] if ;
! See http://factorcode.org/license.txt for BSD license.
USING: accessors kernel namespaces sequences words io assocs
quotations strings parser lexer arrays xml.data xml.writer debugger
-splitting vectors sequences.deep combinators ;
+splitting vectors sequences.deep combinators fry ;
IN: xml.utilities
! * System for words specialized on tag names
: run-process ( tag word -- )
2dup "xtable" word-prop
- >r dup main>> r> at* [ 2nip call ] [
+ [ dup main>> ] dip at* [ 2nip call ] [
drop \ process-missing boa throw
] if ;
: PROCESS:
CREATE
dup H{ } clone "xtable" set-word-prop
- dup [ run-process ] curry define ; parsing
+ dup '[ _ run-process ] define ; parsing
: TAG:
scan scan-word
parse-definition
swap "xtable" word-prop
- rot "/" split [ >r 2dup r> swap set-at ] each 2drop ;
+ rot "/" split [ [ 2dup ] dip swap set-at ] each 2drop ;
parsing
! * Common utility functions
: build-tag* ( items name -- tag )
- assure-name swap >r f r> <tag> ;
+ assure-name swap f swap <tag> ;
: build-tag ( item name -- tag )
- >r 1array r> build-tag* ;
+ [ 1array ] dip build-tag* ;
: standard-prolog ( -- prolog )
T{ prolog f "1.0" "UTF-8" f } ;
dup tag? [ names-match? ] [ 2drop f ] if ;
: tags@ ( tag name -- children name )
- >r { } like r> assure-name ;
+ [ { } like ] dip assure-name ;
: deep-tag-named ( tag name/string -- matching-tag )
- assure-name [ swap tag-named? ] curry deep-find ;
+ assure-name '[ _ swap tag-named? ] deep-find ;
: deep-tags-named ( tag name/string -- tags-seq )
- tags@ [ swap tag-named? ] curry deep-filter ;
+ tags@ '[ _ swap tag-named? ] deep-filter ;
: tag-named ( tag name/string -- matching-tag )
! like get-name-tag but only looks at direct children,
rot dup tag? [ at = ] [ 3drop f ] if ;
: tag-with-attr ( tag attr-value attr-name -- matching-tag )
- assure-name [ tag-with-attr? ] 2curry find nip ;
+ assure-name '[ _ _ tag-with-attr? ] find nip ;
: tags-with-attr ( tag attr-value attr-name -- tags-seq )
- tags@ [ tag-with-attr? ] 2curry filter children>> ;
+ tags@ '[ _ _ tag-with-attr? ] filter children>> ;
: deep-tag-with-attr ( tag attr-value attr-name -- matching-tag )
- assure-name [ tag-with-attr? ] 2curry deep-find ;
+ assure-name '[ _ _ tag-with-attr? ] deep-find ;
: deep-tags-with-attr ( tag attr-value attr-name -- tags-seq )
- tags@ [ tag-with-attr? ] 2curry deep-filter ;
+ tags@ '[ _ _ tag-with-attr? ] deep-filter ;
: get-id ( tag id -- elem ) ! elem=tag.getElementById(id)
"id" deep-tag-with-attr ;
: deep-tags-named-with-attr ( tag tag-name attr-value attr-name -- tags )
- >r >r deep-tags-named r> r> tags-with-attr ;
+ [ deep-tags-named ] 2dip tags-with-attr ;
: assert-tag ( name name -- )
names-match? [ "Unexpected XML tag found" throw ] unless ;
[ swap V{ } like >>children drop ] if ;
: insert-child ( child tag -- )
- >r 1vector r> insert-children ;
+ [ 1vector ] dip insert-children ;
! See http://factorcode.org/license.txt for BSD license.\r
USING: hashtables kernel math namespaces sequences strings\r
assocs combinators io io.streams.string accessors\r
-xml.data wrap xml.entities unicode.categories ;\r
+xml.data wrap xml.entities unicode.categories fry ;\r
IN: xml.writer\r
\r
SYMBOL: xml-pprint?\r
" " indenter set-global\r
\r
: sensitive? ( tag -- ? )\r
- sensitive-tags get swap [ names-match? ] curry contains? ;\r
+ sensitive-tags get swap '[ _ names-match? ] contains? ;\r
\r
: indent-string ( -- string )\r
xml-pprint? get\r
"\"" write\r
] assoc-each ;\r
\r
-GENERIC: write-item ( object -- )\r
+GENERIC: write-xml-chunk ( object -- )\r
\r
-M: string write-item\r
+M: string write-xml-chunk\r
escape-string dup empty? not xml-pprint? get and\r
[ nl 80 indent-string indented-break ] when write ;\r
\r
: write-start-tag ( tag -- )\r
write-tag ">" write ;\r
\r
-M: contained-tag write-item\r
+M: contained-tag write-xml-chunk\r
write-tag "/>" write ;\r
\r
: write-children ( tag -- )\r
indent children>> ?filter-children\r
- [ write-item ] each unindent ;\r
+ [ write-xml-chunk ] each unindent ;\r
\r
: write-end-tag ( tag -- )\r
?indent "</" write print-name CHAR: > write1 ;\r
\r
-M: open-tag write-item\r
- xml-pprint? get >r\r
- {\r
- [ sensitive? not xml-pprint? get and xml-pprint? set ]\r
- [ write-start-tag ]\r
- [ write-children ]\r
- [ write-end-tag ]\r
- } cleave\r
- r> xml-pprint? set ;\r
-\r
-M: comment write-item\r
+M: open-tag write-xml-chunk\r
+ xml-pprint? get [\r
+ {\r
+ [ sensitive? not xml-pprint? get and xml-pprint? set ]\r
+ [ write-start-tag ]\r
+ [ write-children ]\r
+ [ write-end-tag ]\r
+ } cleave\r
+ ] dip xml-pprint? set ;\r
+\r
+M: comment write-xml-chunk\r
"<!--" write text>> write "-->" write ;\r
\r
-M: directive write-item\r
+M: element-decl write-xml-chunk\r
+ "<!ELEMENT " write\r
+ [ name>> write " " write ]\r
+ [ content-spec>> write ">" write ]\r
+ bi ;\r
+\r
+M: attlist-decl write-xml-chunk\r
+ "<!ATTLIST " write\r
+ [ name>> write " " write ]\r
+ [ att-defs>> write ">" write ]\r
+ bi ;\r
+\r
+M: entity-decl write-xml-chunk\r
+ "<!ENTITY " write\r
+ [ name>> write " " write ]\r
+ [ def>> write-xml-chunk ">" write ]\r
+ bi ;\r
+\r
+M: system-id write-xml-chunk\r
+ "SYSTEM '" write system-literal>> write "'" write ;\r
+\r
+M: public-id write-xml-chunk\r
+ "PUBLIC '" write\r
+ [ pubid-literal>> write "' '" write ]\r
+ [ system-literal>> write "'>" write ] bi ;\r
+\r
+M: doctype-decl write-xml-chunk\r
+ "<!DOCTYPE " write\r
+ [ name>> write " " write ]\r
+ [ external-id>> [ write-xml-chunk " " write ] when* ]\r
+ [\r
+ internal-subset>>\r
+ [ "[" write [ write-xml-chunk ] each "]" write ] when* ">" write\r
+ ] tri ;\r
+\r
+M: directive write-xml-chunk\r
"<!" write text>> write CHAR: > write1 ;\r
\r
-M: instruction write-item\r
+M: instruction write-xml-chunk\r
"<?" write text>> write "?>" write ;\r
\r
+M: sequence write-xml-chunk\r
+ [ write-xml-chunk ] each ;\r
+\r
: write-prolog ( xml -- )\r
"<?xml version=\"" write dup version>> write\r
"\" encoding=\"" write dup encoding>> write\r
standalone>> [ "\" standalone=\"yes" write ] when\r
"\"?>" write ;\r
\r
-: write-chunk ( seq -- )\r
- [ write-item ] each ;\r
-\r
: write-xml ( xml -- )\r
{\r
[ prolog>> write-prolog ]\r
- [ before>> write-chunk ]\r
- [ body>> write-item ]\r
- [ after>> write-chunk ]\r
+ [ before>> write-xml-chunk ]\r
+ [ body>> write-xml-chunk ]\r
+ [ after>> write-xml-chunk ]\r
} cleave ;\r
\r
-M: xml write-item\r
- body>> write-item ;\r
+M: xml write-xml-chunk\r
+ body>> write-xml-chunk ;\r
\r
: print-xml ( xml -- )\r
write-xml nl ;\r
{ $example "USING: prettyprint xml.data ;" "T{ name f \"rpc\" \"methodCall\" f } T{ name f f \"methodCall\" \"http://www.xmlrpc.org/\" } names-match? ." "t" }\r
{ $see-also name } ;\r
\r
-HELP: xml-chunk\r
+HELP: read-xml-chunk\r
{ $values { "stream" "an input stream" } { "seq" "a sequence of elements" } }\r
{ $description "rather than parse a document, as " { $link read-xml } " does, this word parses and returns a sequence of XML elements (tags, strings, etc), ie a document fragment. This is useful for pieces of XML which may have more than one main tag." }\r
-{ $see-also write-chunk read-xml } ;\r
+{ $see-also write-xml-chunk read-xml } ;\r
\r
HELP: get-id\r
{ $values { "tag" "an XML tag or document" } { "id" "a string" } { "elem" "an XML element or f" } }\r
{ $description "gets the next XML event from the given XML pull parser. Returns f upon exhaustion." }\r
{ $see-also pull-xml <pull-xml> pull-elem } ;\r
\r
-HELP: write-item\r
+HELP: write-xml-chunk\r
{ $values { "object" "an XML element" } }\r
{ $description "writes an XML element to " { $link output-stream } "." }\r
-{ $see-also write-chunk write-xml } ;\r
-\r
-HELP: write-chunk\r
-{ $values { "seq" "an XML document fragment" } }\r
-{ $description "writes an XML document fragment, ie a sequence of XML elements, to " { $link output-stream } "." }\r
-{ $see-also write-item write-xml } ;\r
+{ $see-also write-xml-chunk write-xml } ;\r
\r
HELP: deep-tag-named\r
{ $values { "tag" "an XML tag or document" } { "name/string" "an XML name or string representing a name" } { "matching-tag" tag } }\r
"The following words are used to read something into an XML document"\r
{ $subsection string>xml }\r
{ $subsection read-xml }\r
- { $subsection xml-chunk }\r
+ { $subsection read-xml-chunk }\r
+ { $subsection string>xml-chunk }\r
{ $subsection file>xml } ;\r
\r
ARTICLE: { "xml" "writing" } "Writing XML"\r
"These words are used in implementing prettyprint"\r
- { $subsection write-item }\r
- { $subsection write-chunk }\r
+ { $subsection write-xml-chunk }\r
"These words are used to print XML normally"\r
{ $subsection xml>string }\r
{ $subsection write-xml }\r
M: prolog process
xml-stack get V{ { f V{ "" } } } =
- [ <bad-prolog> throw ] unless drop ;
+ [ bad-prolog ] unless drop ;
M: instruction process
xml-stack get length 1 =
- [ <bad-instruction> throw ] unless
+ [ bad-instruction ] unless
add-child ;
M: directive process
xml-stack get dup length 1 =
swap first second [ tag? ] contains? not and
- [ <bad-directive> throw ] unless
+ [ misplaced-directive ] unless
add-child ;
M: contained process
M: opener process push-xml ;
: check-closer ( name opener -- name opener )
- dup [ <unopened> throw ] unless
+ dup [ unopened ] unless
2dup name>> =
- [ name>> swap <mismatched> throw ] unless ;
+ [ name>> swap mismatched ] unless ;
M: closer process
name>> pop-xml first2
- >r check-closer attrs>> r>
+ [ check-closer attrs>> ] dip
<tag> add-child ;
: init-xml-stack ( -- )
swap [ string? ] filter
[
dup [ blank? ] all?
- [ drop ] [ swap <pre/post-content> throw ] if
+ [ drop ] [ swap pre/post-content ] if
] each drop ;
: no-pre/post ( pre post -- pre post/* )
! this does *not* affect the contents of the stack
- >r dup t assert-blanks r>
- dup f assert-blanks ;
+ [ dup t assert-blanks ] [ dup f assert-blanks ] bi* ;
: no-post-tags ( post -- post/* )
! this does *not* affect the contents of the stack
- dup [ tag? ] contains? [ <multitags> throw ] when ;
+ dup [ tag? ] contains? [ multitags ] when ;
: assure-tags ( seq -- seq )
! this does *not* affect the contents of the stack
- [ <notags> throw ] unless* ;
+ [ notags ] unless* ;
: make-xml-doc ( prolog seq -- xml-doc )
dup [ tag? ] find
- >r assure-tags cut rest
- no-pre/post no-post-tags
- r> swap <xml> ;
+ [ assure-tags cut rest no-pre/post no-post-tags ] dip
+ swap <xml> ;
! * Views of XML
: (read-xml) ( -- )
[ process ] sax-loop ; inline
-: (xml-chunk) ( stream -- prolog seq )
+: (read-xml-chunk) ( stream -- prolog seq )
[
init-xml (read-xml)
- done? [ <unclosed> throw ] unless
+ done? [ unclosed ] unless
xml-stack get first second
prolog-data get swap
] state-parse ;
: read-xml ( stream -- xml )
#! Produces a tree of XML nodes
- (xml-chunk) make-xml-doc ;
+ (read-xml-chunk) make-xml-doc ;
-: xml-chunk ( stream -- seq )
- (xml-chunk) nip ;
+: read-xml-chunk ( stream -- seq )
+ (read-xml-chunk) nip ;
: string>xml ( string -- xml )
<string-reader> read-xml ;
+: string>xml-chunk ( string -- xml )
+ <string-reader> read-xml-chunk ;
+
: file>xml ( filename -- xml )
! Autodetect encoding!
utf8 <file-reader> read-xml ;
projects / factor.git / commitdiff