summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorAndy Wingo <wingo@pobox.com>2013-01-30 15:29:18 +0100
committerAndy Wingo <wingo@pobox.com>2013-01-30 15:29:18 +0100
commite10c250928bc6c4116d6344616d39f3c52edc36b (patch)
treedffa1373ad37416ead9549da2f971185608eec73
parent1260fd0b2c4ce1d0d7e7b17df924c245f67f9058 (diff)
downloadguile-e10c250928bc6c4116d6344616d39f3c52edc36b.tar.gz
add #:doctype-handler to xml->sxml
* module/sxml/simple.scm (read-internal-doctype-as-string): New helper. (xml->sxml): Add #:doctype-handler argument. * doc/ref/sxml.texi (Reading and Writing XML): Document #:doctype-handler. Fix some other examples, and fix the default value of #:declare-namespaces?. * test-suite/tests/sxml.simple.test: Add all tests from the manual here.
-rw-r--r--doc/ref/sxml.texi52
-rw-r--r--module/sxml/simple.scm56
-rw-r--r--test-suite/tests/sxml.simple.test85
3 files changed, 170 insertions, 23 deletions
diff --git a/doc/ref/sxml.texi b/doc/ref/sxml.texi
index 66584bf89..6dc261f31 100644
--- a/doc/ref/sxml.texi
+++ b/doc/ref/sxml.texi
@@ -57,7 +57,8 @@ to text.
@deffn {Scheme Procedure} xml->sxml [string-or-port] [#:namespaces='()] @
[#:declare-namespaces?=#t] [#:trim-whitespace?=#f] @
- [#:entities='()] [#:default-entity-handler=#f]
+ [#:entities='()] [#:default-entity-handler=#f] @
+ [#:doctype-handler=#f]
Use SSAX to parse an XML document into SXML. Takes one optional
argument, @var{string-or-port}, which defaults to the current input
port. Returns the resulting SXML document. If @var{string-or-port} is
@@ -99,18 +100,19 @@ for certain namespaces with the @code{#:namespaces} keyword argument to
@result{} (*TOP* (foo (ns2:baz)))
@end example
-Passing a true @code{#:declare-namespaces?} argument will cause the
-user-given @code{#:namespaces} to be treated as if they were declared on
-the root element.
+By default, namespaces passed to @code{xml->sxml} are treated as if they
+were declared on the root element. Passing a false
+@code{#:declare-namespaces?} argument will disable this behavior,
+requiring in-document declarations of namespaces before use..
@example
(xml->sxml "<foo><ns2:baz/></foo>"
#:namespaces '((ns2 . "http://example.org/ns2")))
-@result{} error: undeclared namespace: `bar'
+@result{} (*TOP* (foo (ns2:baz)))
(xml->sxml "<foo><ns2:baz/></foo>"
#:namespaces '((ns2 . "http://example.org/ns2"))
- #:declare-namespaces? #t)
-@result{} (*TOP* (foo (ns2:baz)))
+ #:declare-namespaces? #f)
+@result{} error: undeclared namespace: `bar'
@end example
By default, all whitespace in XML is significant. Passing the
@@ -120,10 +122,10 @@ whitespace in front, behind and between elements, treating it as
@example
(xml->sxml "<foo>\n<bar> Alfie the parrot! </bar>\n</foo>")
-@result{} (*TOP* (foo "\n" (bar " Alfie the parrot! ") "\n")
+@result{} (*TOP* (foo "\n" (bar " Alfie the parrot! ") "\n"))
(xml->sxml "<foo>\n<bar> Alfie the parrot! </bar>\n</foo>"
#:trim-whitespace? #t)
-@result{} (*TOP* (foo (bar " Alfie the parrot! "))
+@result{} (*TOP* (foo (bar " Alfie the parrot! ")))
@end example
Parsed entities may be declared with the @code{#:entities} keyword
@@ -159,6 +161,38 @@ numeric character entities.
@result{} (*TOP* (foo "\xa0 foo"))
@end example
+By default, @code{xml->sxml} skips over the @code{<!DOCTYPE>}
+declaration, if any. This behavior can be overridden with the
+@code{#:doctype-handler} argument, which should be a procedure of three
+arguments: the @dfn{docname} (a symbol), @dfn{systemid} (a string), and
+the internal doctype subset (as a string or @code{#f} if not present).
+
+The handler should return keyword arguments as multiple values, as if it
+were calling its continuation with keyword arguments. The continuation
+accepts the @code{#:entities} and @code{#:namespaces} keyword arguments,
+in the same format that @code{xml->sxml} itself takes. These entities
+and namespaces will be prepended to those given to the @code{xml->sxml}
+invocation.
+
+@example
+(define (handle-foo docname systemid internal-subset)
+ (case docname
+ ((foo)
+ (values #:entities '((greets . "<i>Hello, world!</i>"))))
+ (else
+ (values))))
+
+(xml->sxml "<!DOCTYPE foo><p>&greets;</p>"
+ #:doctype-handler handle-foo)
+@result{} (*TOP* (p (i "Hello, world!")))
+@end example
+
+If the document has no doctype declaration, the @var{doctype-handler} is
+invoked with @code{#f} for the three arguments.
+
+In the future, the continuation may accept other keyword arguments, for
+example to validate the parsed SXML against the doctype.
+
@deffn {Scheme Procedure} sxml->xml tree [port]
Serialize the SXML tree @var{tree} as XML. The output will be written to
the current output port, unless the optional argument @var{port} is
diff --git a/module/sxml/simple.scm b/module/sxml/simple.scm
index 606975df9..703ad9137 100644
--- a/module/sxml/simple.scm
+++ b/module/sxml/simple.scm
@@ -26,6 +26,7 @@
;;; Code:
(define-module (sxml simple)
+ #:use-module (sxml ssax input-parse)
#:use-module (sxml ssax)
#:use-module (sxml transform)
#:use-module (ice-9 match)
@@ -35,10 +36,6 @@
;; Helpers from upstream/SSAX.scm.
;;
-(define (ssax:warn port msg . args)
- (format (current-ssax-error-port)
- ";;; SSAX warning: ~a ~a\n" msg args))
-
; ssax:reverse-collect-str LIST-OF-FRAGS -> LIST-OF-FRAGS
; given the list of fragments (some of which are text strings)
; reverse the list and concatenate adjacent text strings.
@@ -65,6 +62,17 @@
(cons (string-concatenate/shared strs) result)))
'())))))))
+(define (read-internal-doctype-as-string port)
+ (string-concatenate/shared
+ (let loop ()
+ (let ((fragment
+ (next-token '() '(#\]) "reading internal DOCTYPE" port)))
+ (if (eqv? #\> (peek-next-char port))
+ (begin
+ (read-char port)
+ (cons fragment '()))
+ (cons* fragment "]" (loop)))))))
+
;; Ideas for the future for this interface:
;;
;; * Allow doctypes to provide parsed entities
@@ -81,7 +89,8 @@
(declare-namespaces? #t)
(trim-whitespace? #f)
(entities '())
- (default-entity-handler #f))
+ (default-entity-handler #f)
+ (doctype-handler #f))
"Use SSAX to parse an XML document into SXML. Takes one optional
argument, @var{string-or-port}, which defaults to the current input
port."
@@ -96,7 +105,7 @@ port."
;; NAMESPACES: list of (DOC-PREFIX . (USER-PREFIX . URI)).
;; A DOC-PREFIX of #f indicates that it comes from the user.
;; Otherwise, prefixes are symbols.
- (define (user-namespaces)
+ (define (munge-namespaces namespaces)
(map (lambda (el)
(match el
((prefix . uri-string)
@@ -105,6 +114,9 @@ port."
(ssax:uri-string->symbol uri-string)))))
namespaces))
+ (define (user-namespaces)
+ (munge-namespaces namespaces))
+
(define (user-entities)
(if (and default-entity-handler
(not (assq '*DEFAULT* entities)))
@@ -117,6 +129,13 @@ port."
(symbol-append prefix (string->symbol ":") local-part))
(_ name)))
+ (define (doctype-continuation seed)
+ (lambda* (#:key (entities '()) (namespaces '()))
+ (values #f
+ (append entities (user-entities))
+ (append (munge-namespaces namespaces) (user-namespaces))
+ seed)))
+
;; The SEED in this parser is the SXML: initialized to '() at each new
;; level by the fdown handlers; built in reverse by the fhere parsers;
;; and reverse-collected by the fup handlers.
@@ -159,18 +178,29 @@ port."
;;
;; SEED builds up the content.
(lambda (port docname systemid internal-subset? seed)
- (when internal-subset?
- (ssax:warn port "Internal DTD subset is not currently handled ")
- (ssax:skip-internal-dtd port))
- (ssax:warn port "DOCTYPE DECL " docname " "
- systemid " found and skipped")
- (values #f (user-entities) (user-namespaces) seed))
+ (call-with-values
+ (lambda ()
+ (cond
+ (doctype-handler
+ (doctype-handler docname systemid
+ (and internal-subset?
+ (read-internal-doctype-as-string port))))
+ (else
+ (when internal-subset?
+ (ssax:skip-internal-dtd port))
+ (values))))
+ (doctype-continuation seed)))
UNDECL-ROOT
;; This is like the DOCTYPE handler, but for documents that do not
;; have a <!DOCTYPE!> entry.
(lambda (elem-gi seed)
- (values #f (user-entities) (user-namespaces) seed))
+ (call-with-values
+ (lambda ()
+ (if doctype-handler
+ (doctype-handler #f #f #f)
+ (values)))
+ (doctype-continuation seed)))
PI
((*DEFAULT*
diff --git a/test-suite/tests/sxml.simple.test b/test-suite/tests/sxml.simple.test
index 623f13e51..e52ba319d 100644
--- a/test-suite/tests/sxml.simple.test
+++ b/test-suite/tests/sxml.simple.test
@@ -1,6 +1,6 @@
;;;; sxml.simple.test --- (sxml simple) -*- mode: scheme; coding: utf-8; -*-
;;;;
-;;;; Copyright (C) 2010 Free Software Foundation, Inc.
+;;;; Copyright (C) 2010, 2013 Free Software Foundation, Inc.
;;;;
;;;; This library is free software; you can redistribute it and/or
;;;; modify it under the terms of the GNU Lesser General Public
@@ -20,6 +20,8 @@
#:use-module (test-suite lib)
#:use-module (sxml simple))
+(define parser-error '(parser-error . ""))
+
(define %xml-sample
;; An XML sample without any space in between tags, to make it easier.
(string-append "<?xml version='1.0' encoding='utf-8'?>"
@@ -50,3 +52,84 @@
(lambda ()
(sxml->xml
(xml->sxml (open-input-string %xml-sample))))))))))
+
+(with-test-prefix "namespaces"
+ (pass-if-equal
+ (xml->sxml "<foo xmlns=\"http://example.org/ns1\">text</foo>")
+ '(*TOP* (http://example.org/ns1:foo "text")))
+
+ (pass-if-equal
+ (xml->sxml "<foo xmlns=\"http://example.org/ns1\">text</foo>"
+ #:namespaces '((ns1 . "http://example.org/ns1")))
+ '(*TOP* (ns1:foo "text")))
+
+ (pass-if-equal
+ (xml->sxml "<foo xmlns:bar=\"http://example.org/ns2\"><bar:baz/></foo>"
+ #:namespaces '((ns2 . "http://example.org/ns2")))
+ '(*TOP* (foo (ns2:baz))))
+
+ (pass-if-equal
+ (xml->sxml "<foo><ns2:baz/></foo>"
+ #:namespaces '((ns2 . "http://example.org/ns2")))
+ '(*TOP* (foo (ns2:baz))))
+
+ (pass-if-exception "namespace undeclared" parser-error
+ (xml->sxml "<foo><ns2:baz/></foo>"
+ #:namespaces '((ns2 . "http://example.org/ns2"))
+ #:declare-namespaces? #f)))
+
+(with-test-prefix "whitespace"
+ (pass-if-equal
+ (xml->sxml "<foo>\n<bar> Alfie the parrot! </bar>\n</foo>")
+ '(*TOP* (foo "\n" (bar " Alfie the parrot! ") "\n")))
+
+ (pass-if-equal
+ (xml->sxml "<foo>\n<bar> Alfie the parrot! </bar>\n</foo>"
+ #:trim-whitespace? #t)
+ '(*TOP* (foo (bar " Alfie the parrot! ")))))
+
+(with-test-prefix "parsed entities"
+ (pass-if-equal
+ '(*TOP* (foo "&"))
+ (xml->sxml "<foo>&amp;</foo>"))
+
+ (pass-if-exception "nbsp undefined" parser-error
+ (xml->sxml "<foo>&nbsp;</foo>"))
+
+ (pass-if-equal
+ '(*TOP* (foo "\xA0"))
+ (xml->sxml "<foo>&nbsp;</foo>"
+ #:entities '((nbsp . "\xA0"))))
+
+ (pass-if-equal
+ '(*TOP* (foo "\xA0"))
+ (xml->sxml "<foo>&#xA0;</foo>"))
+
+ (let ((ents '()))
+ (pass-if-equal
+ (xml->sxml "<foo>&nbsp; &foo;</foo>"
+ #:default-entity-handler
+ (lambda (port name)
+ (case name
+ ((nbsp) "\xa0")
+ (else
+ (set! ents (cons name ents))
+ "qux"))))
+ '(*TOP* (foo "\xa0 qux")))
+
+ (pass-if-equal
+ ents
+ '(foo))))
+
+(with-test-prefix "doctype handlers"
+ (define (handle-foo docname systemid internal-subset)
+ (case docname
+ ((foo)
+ (values #:entities '((greets . "<i>Hello, world!</i>"))))
+ (else
+ (values))))
+
+ (pass-if-equal
+ (xml->sxml "<!DOCTYPE foo><p>&greets;</p>"
+ #:doctype-handler handle-foo)
+ '(*TOP* (p (i "Hello, world!")))))