Merge branch 'master' of git://factorcode.org/git/factor
Doug Coleman
commit
0c7327a572
|
|
@ -1,8 +1,37 @@
|
|||
IN: documents.tests
|
||||
USING: documents namespaces tools.test ;
|
||||
USING: documents namespaces tools.test make arrays kernel fry ;
|
||||
|
||||
! Tests
|
||||
|
||||
[ { } ] [
|
||||
[
|
||||
{ 1 10 }
|
||||
{ 1 10 } [ , "HI" , ] each-line
|
||||
] { } make
|
||||
] unit-test
|
||||
|
||||
[ { 1 "HI" } ] [
|
||||
[
|
||||
{ 1 10 }
|
||||
{ 1 11 } [ , "HI" , ] each-line
|
||||
] { } make
|
||||
] unit-test
|
||||
|
||||
[ { 1 "HI" 2 "HI" } ] [
|
||||
[
|
||||
{ 1 10 }
|
||||
{ 2 11 } [ , "HI" , ] each-line
|
||||
] { } make
|
||||
] unit-test
|
||||
|
||||
[ { { t f 1 } { t f 2 } } ] [
|
||||
[
|
||||
{ 1 10 } { 2 11 }
|
||||
t f
|
||||
'[ [ _ _ ] dip 3array , ] each-line
|
||||
] { } make
|
||||
] unit-test
|
||||
|
||||
[ { 10 4 } ] [ { "a" } { 10 3 } text+loc ] unit-test
|
||||
[ { 10 4 } ] [ { "a" } { 10 3 } text+loc ] unit-test
|
||||
|
||||
|
|
|
|||
|
|
@ -1,8 +1,8 @@
|
|||
! Copyright (C) 2006, 2007 Slava Pestov
|
||||
! Copyright (C) 2006, 2008 Slava Pestov
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: accessors arrays io kernel math models namespaces make
|
||||
sequences strings splitting combinators unicode.categories
|
||||
math.order ;
|
||||
math.order math.ranges ;
|
||||
IN: documents
|
||||
|
||||
: +col ( loc n -- newloc ) [ first2 ] dip + 2array ;
|
||||
|
|
@ -47,7 +47,7 @@ TUPLE: document < model locs ;
|
|||
2over = [
|
||||
3drop
|
||||
] [
|
||||
[ [ first ] bi@ 1+ dup <slice> ] dip each
|
||||
[ [ first ] bi@ [a,b] ] dip each
|
||||
] if ; inline
|
||||
|
||||
: start/end-on-line ( from to line# -- n1 n2 )
|
||||
|
|
|
|||
|
|
@ -87,7 +87,7 @@ DEFER: compile-element
|
|||
{ [ 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' )
|
||||
|
|
|
|||
|
|
@ -104,7 +104,8 @@ M: unix statvfs>file-system-info drop ;
|
|||
|
||||
: file-system-calculations ( file-system-info -- file-system-info' )
|
||||
{
|
||||
[ dup [ blocks-available>> ] [ block-size>> ] bi * >>free-space drop ]
|
||||
[ dup [ blocks-available>> ] [ block-size>> ] bi * >>available-space drop ]
|
||||
[ dup [ blocks-free>> ] [ block-size>> ] bi * >>free-space drop ]
|
||||
[ dup [ blocks>> ] [ block-size>> ] bi * >>total-space drop ]
|
||||
[ dup [ total-space>> ] [ free-space>> ] bi - >>used-space drop ]
|
||||
[ ]
|
||||
|
|
|
|||
|
|
@ -1,13 +1,13 @@
|
|||
! Copyright (C) 2008 Doug Coleman.
|
||||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: accessors alien.c-types alien.syntax combinators csv
|
||||
io.encodings.utf8 io.files io.streams.string io.unix.files
|
||||
kernel namespaces sequences system unix unix.statfs.linux
|
||||
unix.statvfs.linux ;
|
||||
io.backend io.encodings.utf8 io.files io.streams.string
|
||||
io.unix.files kernel math.order namespaces sequences sorting
|
||||
system unix unix.statfs.linux unix.statvfs.linux ;
|
||||
IN: io.unix.files.linux
|
||||
|
||||
TUPLE: linux-file-system-info < unix-file-system-info
|
||||
namelen spare ;
|
||||
namelen ;
|
||||
|
||||
M: linux new-file-system-info linux-file-system-info new ;
|
||||
|
||||
|
|
@ -26,7 +26,7 @@ M: linux statfs>file-system-info ( struct -- statfs )
|
|||
[ statfs64-f_fsid >>id ]
|
||||
[ statfs64-f_namelen >>namelen ]
|
||||
[ statfs64-f_frsize >>preferred-block-size ]
|
||||
[ statfs64-f_spare >>spare ]
|
||||
! [ statfs64-f_spare >>spare ]
|
||||
} cleave ;
|
||||
|
||||
M: linux file-system-statvfs ( path -- byte-array )
|
||||
|
|
@ -68,3 +68,22 @@ M: linux file-systems
|
|||
[ type>> >>type ]
|
||||
} cleave
|
||||
] map ;
|
||||
|
||||
ERROR: file-system-not-found ;
|
||||
|
||||
M: linux file-system-info ( path -- )
|
||||
normalize-path
|
||||
[
|
||||
[ new-file-system-info ] dip
|
||||
[ file-system-statfs statfs>file-system-info ]
|
||||
[ file-system-statvfs statvfs>file-system-info ] bi
|
||||
file-system-calculations
|
||||
] keep
|
||||
|
||||
parse-mtab [ [ mount-point>> ] bi@ <=> invert-comparison ] sort
|
||||
[ mount-point>> head? ] with find nip [ file-system-not-found ] unless*
|
||||
{
|
||||
[ file-system-name>> >>device-name drop ]
|
||||
[ mount-point>> >>mount-point drop ]
|
||||
[ type>> >>type ]
|
||||
} 2cleave ;
|
||||
|
|
|
|||
|
|
@ -81,7 +81,7 @@ TUPLE: entry title url description date ;
|
|||
[
|
||||
{ "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
|
||||
]
|
||||
[
|
||||
|
|
|
|||
|
|
@ -235,10 +235,11 @@ M: editor ungraft*
|
|||
editor get selection-color>> gl-color
|
||||
editor get selection-start/end
|
||||
over first [
|
||||
2dup [
|
||||
2dup '[
|
||||
[ _ _ ] dip
|
||||
draw-selected-line
|
||||
1 translate-lines
|
||||
] with with each-line
|
||||
] each-line
|
||||
] with-editor-translation ;
|
||||
|
||||
M: editor draw-gadget*
|
||||
|
|
|
|||
|
|
@ -2,7 +2,7 @@
|
|||
! 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 ;
|
||||
|
|
@ -34,8 +34,25 @@ C: <contained> contained
|
|||
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
|
||||
|
|
@ -47,7 +64,7 @@ TUPLE: attrs alist ;
|
|||
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*
|
||||
|
|
@ -56,7 +73,7 @@ M: attrs set-at
|
|||
2dup attr@ nip [
|
||||
2nip set-second
|
||||
] [
|
||||
>r assure-name swap 2array r>
|
||||
[ assure-name swap 2array ] dip
|
||||
[ alist>> ?push ] keep (>>alist)
|
||||
] if* ;
|
||||
|
||||
|
|
@ -67,7 +84,7 @@ M: attrs >alist alist>> ;
|
|||
: >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 ;
|
||||
|
|
@ -107,9 +124,9 @@ M: tag like
|
|||
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 ;
|
||||
|
|
@ -129,7 +146,7 @@ CONSULT: name xml body>> ;
|
|||
|
||||
<PRIVATE
|
||||
: tag>xml ( xml tag -- newxml )
|
||||
>r [ prolog>> ] [ before>> ] [ after>> ] tri r>
|
||||
[ [ prolog>> ] [ before>> ] [ after>> ] tri ] dip
|
||||
swap <xml> ;
|
||||
|
||||
: seq>xml ( xml seq -- newxml )
|
||||
|
|
|
|||
|
|
@ -1,6 +1,6 @@
|
|||
! 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
|
||||
|
|
@ -19,7 +19,7 @@ IN: xml.entities
|
|||
|
||||
: 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 ;
|
||||
|
|
|
|||
|
|
@ -1,8 +1,9 @@
|
|||
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" "" }
|
||||
|
|
@ -24,5 +25,3 @@ T{ pre/post-content f "x" t } "x<y/>" xml-error-test
|
|||
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
|
||||
|
|
|
|||
|
|
@ -5,13 +5,13 @@ debugger sequences state-parser accessors summary
|
|||
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
|
||||
|
|
@ -22,8 +22,10 @@ M: pre/post-content summary ( obj -- str )
|
|||
] 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
|
||||
|
|
@ -31,8 +33,10 @@ M: no-entity summary ( obj -- str )
|
|||
] 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
|
||||
|
|
@ -40,8 +44,10 @@ M: xml-string-error summary ( obj -- str )
|
|||
] 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
|
||||
|
|
@ -51,9 +57,12 @@ M: mismatched summary ( obj -- str )
|
|||
] 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
|
||||
|
|
@ -63,8 +72,10 @@ M: unclosed summary ( obj -- str )
|
|||
] 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
|
||||
|
|
@ -72,8 +83,10 @@ M: bad-uri summary ( obj -- str )
|
|||
] 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
|
||||
|
|
@ -81,8 +94,10 @@ M: nonexist-ns summary ( obj -- str )
|
|||
] 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
|
||||
|
|
@ -90,8 +105,10 @@ M: unopened summary ( obj -- str )
|
|||
] 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
|
||||
|
|
@ -101,8 +118,10 @@ M: not-yes/no summary ( obj -- str )
|
|||
|
||||
! 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
|
||||
|
|
@ -111,22 +130,26 @@ M: extra-attrs summary ( obj -- str )
|
|||
] 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
|
||||
|
|
@ -135,8 +158,10 @@ M: bad-prolog summary ( obj -- str )
|
|||
] 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
|
||||
|
|
@ -146,8 +171,10 @@ M: capitalized-prolog summary ( obj -- str )
|
|||
] 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
|
||||
|
|
@ -155,23 +182,55 @@ M: versionless-prolog summary ( obj -- str )
|
|||
] 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
|
||||
|
|
|
|||
|
|
@ -1,3 +1,3 @@
|
|||
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
|
||||
|
|
|
|||
|
|
@ -5,12 +5,11 @@ sequences ;
|
|||
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
|
||||
|
||||
|
|
|
|||
|
|
@ -6,7 +6,7 @@ USING: xml io kernel math sequences strings xml.utilities tools.test math.parser
|
|||
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 ;
|
||||
|
|
|
|||
|
|
@ -0,0 +1,9 @@
|
|||
! 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
|
||||
|
|
@ -0,0 +1,2 @@
|
|||
<?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>
|
||||
|
||||
|
|
@ -20,7 +20,7 @@ M: object (r-ref) drop ;
|
|||
|
||||
! Example
|
||||
|
||||
: sample-doc
|
||||
: sample-doc ( -- string )
|
||||
{
|
||||
"<html xmlns:f='http://littledan.onigirihouse.com/namespaces/replace'>"
|
||||
"<body>"
|
||||
|
|
|
|||
|
|
@ -4,7 +4,7 @@ IN: xml.tests
|
|||
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
|
||||
|
|
@ -44,10 +44,20 @@ SYMBOL: xml-file
|
|||
"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
|
||||
|
|
|
|||
|
|
@ -0,0 +1,9 @@
|
|||
! 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
|
||||
|
|
@ -3,7 +3,7 @@
|
|||
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
|
||||
|
|
@ -26,7 +26,7 @@ SYMBOL: ns-stack
|
|||
|
||||
: 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 ;
|
||||
|
|
@ -44,7 +44,7 @@ SYMBOL: ns-stack
|
|||
|
||||
: 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
|
||||
|
||||
|
|
@ -58,7 +58,7 @@ SYMBOL: ns-stack
|
|||
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 )
|
||||
|
|
@ -70,9 +70,9 @@ SYMBOL: ns-stack
|
|||
: (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 ;
|
||||
|
||||
|
|
@ -95,7 +95,7 @@ SYMBOL: ns-stack
|
|||
|
||||
: 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 ;
|
||||
|
|
@ -111,7 +111,7 @@ SYMBOL: ns-stack
|
|||
get-char dup "'\"" member? [
|
||||
next parse-quot
|
||||
] [
|
||||
"Attribute lacks quote" <xml-string-error> throw
|
||||
"Attribute lacks quote" xml-string-error
|
||||
] if ;
|
||||
|
||||
: parse-attr ( -- )
|
||||
|
|
@ -141,8 +141,92 @@ SYMBOL: ns-stack
|
|||
: 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 {
|
||||
|
|
@ -155,7 +239,7 @@ SYMBOL: ns-stack
|
|||
{
|
||||
{ "yes" [ t ] }
|
||||
{ "no" [ f ] }
|
||||
[ <not-yes/no> throw ]
|
||||
[ not-yes/no ]
|
||||
} case ;
|
||||
|
||||
: assure-no-extra ( seq -- )
|
||||
|
|
@ -164,14 +248,14 @@ SYMBOL: ns-stack
|
|||
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
|
||||
|
|
@ -187,7 +271,7 @@ SYMBOL: ns-stack
|
|||
(parse-name) dup "xml" =
|
||||
[ drop parse-prolog ] [
|
||||
dup >lower "xml" =
|
||||
[ <capitalized-prolog> throw ]
|
||||
[ capitalized-prolog ]
|
||||
[ "?>" take-string append <instruction> ] if
|
||||
] if ;
|
||||
|
||||
|
|
|
|||
|
|
@ -2,7 +2,7 @@
|
|||
! 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
|
||||
|
|
@ -16,30 +16,30 @@ M: process-missing error.
|
|||
|
||||
: 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 } ;
|
||||
|
|
@ -69,13 +69,13 @@ M: process-missing error.
|
|||
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,
|
||||
|
|
@ -89,22 +89,22 @@ M: process-missing error.
|
|||
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 ;
|
||||
|
|
@ -114,4 +114,4 @@ M: process-missing error.
|
|||
[ swap V{ } like >>children drop ] if ;
|
||||
|
||||
: insert-child ( child tag -- )
|
||||
>r 1vector r> insert-children ;
|
||||
[ 1vector ] dip insert-children ;
|
||||
|
|
|
|||
|
|
@ -2,7 +2,7 @@
|
|||
! See http://factorcode.org/license.txt for BSD license.
|
||||
USING: hashtables kernel math namespaces sequences strings
|
||||
assocs combinators io io.streams.string accessors
|
||||
xml.data wrap xml.entities unicode.categories ;
|
||||
xml.data wrap xml.entities unicode.categories fry ;
|
||||
IN: xml.writer
|
||||
|
||||
SYMBOL: xml-pprint?
|
||||
|
|
@ -12,7 +12,7 @@ SYMBOL: indenter
|
|||
" " indenter set-global
|
||||
|
||||
: sensitive? ( tag -- ? )
|
||||
sensitive-tags get swap [ names-match? ] curry contains? ;
|
||||
sensitive-tags get swap '[ _ names-match? ] contains? ;
|
||||
|
||||
: indent-string ( -- string )
|
||||
xml-pprint? get
|
||||
|
|
@ -52,9 +52,9 @@ SYMBOL: indenter
|
|||
"\"" write
|
||||
] assoc-each ;
|
||||
|
||||
GENERIC: write-item ( object -- )
|
||||
GENERIC: write-xml-chunk ( object -- )
|
||||
|
||||
M: string write-item
|
||||
M: string write-xml-chunk
|
||||
escape-string dup empty? not xml-pprint? get and
|
||||
[ nl 80 indent-string indented-break ] when write ;
|
||||
|
||||
|
|
@ -65,54 +65,89 @@ M: string write-item
|
|||
: write-start-tag ( tag -- )
|
||||
write-tag ">" write ;
|
||||
|
||||
M: contained-tag write-item
|
||||
M: contained-tag write-xml-chunk
|
||||
write-tag "/>" write ;
|
||||
|
||||
: write-children ( tag -- )
|
||||
indent children>> ?filter-children
|
||||
[ write-item ] each unindent ;
|
||||
[ write-xml-chunk ] each unindent ;
|
||||
|
||||
: write-end-tag ( tag -- )
|
||||
?indent "</" write print-name CHAR: > write1 ;
|
||||
|
||||
M: open-tag write-item
|
||||
xml-pprint? get >r
|
||||
{
|
||||
[ sensitive? not xml-pprint? get and xml-pprint? set ]
|
||||
[ write-start-tag ]
|
||||
[ write-children ]
|
||||
[ write-end-tag ]
|
||||
} cleave
|
||||
r> xml-pprint? set ;
|
||||
M: open-tag write-xml-chunk
|
||||
xml-pprint? get [
|
||||
{
|
||||
[ sensitive? not xml-pprint? get and xml-pprint? set ]
|
||||
[ write-start-tag ]
|
||||
[ write-children ]
|
||||
[ write-end-tag ]
|
||||
} cleave
|
||||
] dip xml-pprint? set ;
|
||||
|
||||
M: comment write-item
|
||||
M: comment write-xml-chunk
|
||||
"<!--" write text>> write "-->" write ;
|
||||
|
||||
M: directive write-item
|
||||
M: element-decl write-xml-chunk
|
||||
"<!ELEMENT " write
|
||||
[ name>> write " " write ]
|
||||
[ content-spec>> write ">" write ]
|
||||
bi ;
|
||||
|
||||
M: attlist-decl write-xml-chunk
|
||||
"<!ATTLIST " write
|
||||
[ name>> write " " write ]
|
||||
[ att-defs>> write ">" write ]
|
||||
bi ;
|
||||
|
||||
M: entity-decl write-xml-chunk
|
||||
"<!ENTITY " write
|
||||
[ name>> write " " write ]
|
||||
[ def>> write-xml-chunk ">" write ]
|
||||
bi ;
|
||||
|
||||
M: system-id write-xml-chunk
|
||||
"SYSTEM '" write system-literal>> write "'" write ;
|
||||
|
||||
M: public-id write-xml-chunk
|
||||
"PUBLIC '" write
|
||||
[ pubid-literal>> write "' '" write ]
|
||||
[ system-literal>> write "'>" write ] bi ;
|
||||
|
||||
M: doctype-decl write-xml-chunk
|
||||
"<!DOCTYPE " write
|
||||
[ name>> write " " write ]
|
||||
[ external-id>> [ write-xml-chunk " " write ] when* ]
|
||||
[
|
||||
internal-subset>>
|
||||
[ "[" write [ write-xml-chunk ] each "]" write ] when* ">" write
|
||||
] tri ;
|
||||
|
||||
M: directive write-xml-chunk
|
||||
"<!" write text>> write CHAR: > write1 ;
|
||||
|
||||
M: instruction write-item
|
||||
M: instruction write-xml-chunk
|
||||
"<?" write text>> write "?>" write ;
|
||||
|
||||
M: sequence write-xml-chunk
|
||||
[ write-xml-chunk ] each ;
|
||||
|
||||
: write-prolog ( xml -- )
|
||||
"<?xml version=\"" write dup version>> write
|
||||
"\" encoding=\"" write dup encoding>> write
|
||||
standalone>> [ "\" standalone=\"yes" write ] when
|
||||
"\"?>" write ;
|
||||
|
||||
: write-chunk ( seq -- )
|
||||
[ write-item ] each ;
|
||||
|
||||
: write-xml ( xml -- )
|
||||
{
|
||||
[ prolog>> write-prolog ]
|
||||
[ before>> write-chunk ]
|
||||
[ body>> write-item ]
|
||||
[ after>> write-chunk ]
|
||||
[ before>> write-xml-chunk ]
|
||||
[ body>> write-xml-chunk ]
|
||||
[ after>> write-xml-chunk ]
|
||||
} cleave ;
|
||||
|
||||
M: xml write-item
|
||||
body>> write-item ;
|
||||
M: xml write-xml-chunk
|
||||
body>> write-xml-chunk ;
|
||||
|
||||
: print-xml ( xml -- )
|
||||
write-xml nl ;
|
||||
|
|
|
|||
|
|
@ -173,10 +173,10 @@ HELP: names-match?
|
|||
{ $example "USING: prettyprint xml.data ;" "T{ name f \"rpc\" \"methodCall\" f } T{ name f f \"methodCall\" \"http://www.xmlrpc.org/\" } names-match? ." "t" }
|
||||
{ $see-also name } ;
|
||||
|
||||
HELP: xml-chunk
|
||||
HELP: read-xml-chunk
|
||||
{ $values { "stream" "an input stream" } { "seq" "a sequence of elements" } }
|
||||
{ $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." }
|
||||
{ $see-also write-chunk read-xml } ;
|
||||
{ $see-also write-xml-chunk read-xml } ;
|
||||
|
||||
HELP: get-id
|
||||
{ $values { "tag" "an XML tag or document" } { "id" "a string" } { "elem" "an XML element or f" } }
|
||||
|
|
@ -239,15 +239,10 @@ HELP: pull-event
|
|||
{ $description "gets the next XML event from the given XML pull parser. Returns f upon exhaustion." }
|
||||
{ $see-also pull-xml <pull-xml> pull-elem } ;
|
||||
|
||||
HELP: write-item
|
||||
HELP: write-xml-chunk
|
||||
{ $values { "object" "an XML element" } }
|
||||
{ $description "writes an XML element to " { $link output-stream } "." }
|
||||
{ $see-also write-chunk write-xml } ;
|
||||
|
||||
HELP: write-chunk
|
||||
{ $values { "seq" "an XML document fragment" } }
|
||||
{ $description "writes an XML document fragment, ie a sequence of XML elements, to " { $link output-stream } "." }
|
||||
{ $see-also write-item write-xml } ;
|
||||
{ $see-also write-xml-chunk write-xml } ;
|
||||
|
||||
HELP: deep-tag-named
|
||||
{ $values { "tag" "an XML tag or document" } { "name/string" "an XML name or string representing a name" } { "matching-tag" tag } }
|
||||
|
|
@ -352,13 +347,13 @@ ARTICLE: { "xml" "reading" } "Reading XML"
|
|||
"The following words are used to read something into an XML document"
|
||||
{ $subsection string>xml }
|
||||
{ $subsection read-xml }
|
||||
{ $subsection xml-chunk }
|
||||
{ $subsection read-xml-chunk }
|
||||
{ $subsection string>xml-chunk }
|
||||
{ $subsection file>xml } ;
|
||||
|
||||
ARTICLE: { "xml" "writing" } "Writing XML"
|
||||
"These words are used in implementing prettyprint"
|
||||
{ $subsection write-item }
|
||||
{ $subsection write-chunk }
|
||||
{ $subsection write-xml-chunk }
|
||||
"These words are used to print XML normally"
|
||||
{ $subsection xml>string }
|
||||
{ $subsection write-xml }
|
||||
|
|
|
|||
|
|
@ -24,17 +24,17 @@ M: object process add-child ;
|
|||
|
||||
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
|
||||
|
|
@ -44,13 +44,13 @@ 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 ( -- )
|
||||
|
|
@ -69,27 +69,25 @@ M: closer process
|
|||
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
|
||||
|
||||
|
|
@ -142,24 +140,27 @@ TUPLE: pull-xml scope ;
|
|||
: (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 ;
|
||||
|
|
|
|||
Loading…
Reference in New Issue