92 lines
2.4 KiB
Factor
92 lines
2.4 KiB
Factor
|
! Copyright (C) 2005, 2006 Daniel Ehrenberg
|
||
|
|
! See http://factorcode.org/license.txt for BSD license.
|
||
|
|
USING: hashtables kernel math namespaces sequences strings
|
||
|
|
io generic xml-data xml-tokenize xml-errors errors ;
|
||
|
|
IN: xml-writer
|
||
|
|
|
||
|
|
GENERIC: write-str-elem ( elem -- )
|
||
|
|
|
||
|
|
: chars>entities ( str -- str )
|
||
|
|
#! Convert <, >, &, ' and " to HTML entities.
|
||
|
|
[ [ dup entities hash [ % ] [ , ] ?if ] each ] "" make ;
|
||
|
|
|
||
|
|
M: string write-str-elem
|
||
|
|
chars>entities write ;
|
||
|
|
|
||
|
|
M: entity write-str-elem
|
||
|
|
CHAR: & write1 entity-name write CHAR: ; write1 ;
|
||
|
|
|
||
|
|
UNION: str-elem string entity ;
|
||
|
|
|
||
|
|
: print-name ( name -- )
|
||
|
|
dup name-space dup "" = [ drop ]
|
||
|
|
[ write CHAR: : write1 ] if
|
||
|
|
name-tag write ;
|
||
|
|
|
||
|
|
M: mismatched error.
|
||
|
|
dup xml-error.
|
||
|
|
"Mismatched tags" print
|
||
|
|
"Opening tag: <" write dup mismatched-open print-name ">" print
|
||
|
|
"Closing tag: </" write mismatched-close print-name ">" print ;
|
||
|
|
M: unclosed error.
|
||
|
|
"Unclosed tags" print
|
||
|
|
"Tags: " print
|
||
|
|
unclosed-tags [ " <" write print-name ">" print ] each ;
|
||
|
|
|
||
|
|
: print-props ( hash -- )
|
||
|
|
[
|
||
|
|
" " write swap print-name "=\"" write
|
||
|
|
[ write-str-elem ] each "\"" write
|
||
|
|
] hash-each ;
|
||
|
|
|
||
|
|
GENERIC: write-item ( object -- )
|
||
|
|
|
||
|
|
M: str-elem write-item ! string element
|
||
|
|
write-str-elem ;
|
||
|
|
|
||
|
|
M: contained-tag write-item
|
||
|
|
CHAR: < write1
|
||
|
|
dup print-name
|
||
|
|
tag-props print-props
|
||
|
|
"/>" write ;
|
||
|
|
|
||
|
|
M: open-tag write-item
|
||
|
|
CHAR: < write1
|
||
|
|
dup print-name
|
||
|
|
dup tag-props print-props
|
||
|
|
CHAR: > write1
|
||
|
|
dup tag-children [ write-item ] each
|
||
|
|
"</" write print-name CHAR: > write1 ;
|
||
|
|
|
||
|
|
M: comment write-item
|
||
|
|
"<!--" write comment-text write "-->" write ;
|
||
|
|
|
||
|
|
M: directive write-item
|
||
|
|
"<!" write directive-text write CHAR: > write1 ;
|
||
|
|
|
||
|
|
M: instruction write-item
|
||
|
|
"<?" write instruction-text write "?>" write ;
|
||
|
|
|
||
|
|
: xml-preamble ( xml -- )
|
||
|
|
"<?xml version=\"" write dup prolog-version write
|
||
|
|
"\" encoding=\"" write dup prolog-encoding write
|
||
|
|
"\" standalone=\"" write
|
||
|
|
prolog-standalone "yes" "no" ? write
|
||
|
|
"\"?>" write ;
|
||
|
|
|
||
|
|
: write-chunk ( seq -- )
|
||
|
|
[ write-item ] each ;
|
||
|
|
|
||
|
|
: write-xml ( xml-doc -- )
|
||
|
|
dup xml-doc-prolog xml-preamble
|
||
|
|
dup xml-doc-before write-chunk
|
||
|
|
dup delegate write-item
|
||
|
|
xml-doc-after write-chunk ;
|
||
|
|
|
||
|
|
: print-xml ( xml-doc -- )
|
||
|
|
write-xml terpri ;
|
||
|
|
|
||
|
|
: xml>string ( xml-doc -- string )
|
||
|
|
[ write-xml ] string-out ;
|
||
|
|
|