quick fix to ssax.scm

[bpt/guile.git] / module / sxml / ssax.scm

diff --git a/module/sxml/ssax.scm b/module/sxml/ssax.scm
index 8794927..f750c93 100644 (file)
--- a/module/sxml/ssax.scm
+++ b/module/sxml/ssax.scm
@@ -1,6 +1,6 @@
 ;;;; (sxml ssax) -- the SSAX parser
 ;;;;
-;;;;   Copyright (C) 2009  Free Software Foundation, Inc.
+;;;;   Copyright (C) 2009, 2010,2012,2013  Free Software Foundation, Inc.
 ;;;;    Modified 2004 by Andy Wingo <wingo at pobox dot com>.
 ;;;;    Written 2001,2002,2003,2004 by Oleg Kiselyov <oleg at pobox dot com> as SSAX.scm.
 ;;;; 
@@ -147,6 +147,8 @@
                 attlist-null?
                 attlist-remove-top
                 attlist->alist attlist-fold
+                define-parsed-entity!
+                reset-parsed-entity-definitions!
                 ssax:uri-string->symbol
                 ssax:skip-internal-dtd
                 ssax:read-pi-body-as-string
@@ -168,17 +170,22 @@
 (define ascii->char integer->char)
 (define char->ascii char->integer)
 
-(define *current-ssax-error-port* (make-fluid))
-(define (current-ssax-error-port)
-  (fluid-ref *current-ssax-error-port*))
+(define current-ssax-error-port
+  (make-parameter (current-error-port)))
+
+(define *current-ssax-error-port*
+  (parameter-fluid current-ssax-error-port))
 
 (define (with-ssax-error-to-port port thunk)
-  (with-fluids ((*current-ssax-error-port* port))
+  (parameterize ((current-ssax-error-port port))
     (thunk)))
 
-(define (ssax:warn port msg . args)
-  (format (current-ssax-error-port)
-          ";;; SSAX warning: ~a ~a\n" msg args))
+(define (ssax:warn port . args)
+  (with-output-to-port (current-ssax-error-port)
+    (lambda ()
+      (display ";;; SSAX warning: ")
+      (for-each display args)
+      (newline))))
 
 (define (ucscode->string codepoint)
   (string (integer->char codepoint)))
@@ -188,12 +195,24 @@
 (define char-tab #\tab)
 (define nl "\n")
 
-;; if condition is true, execute stmts in turn and return the result of
-;; the last statement otherwise, return #f
-(define-syntax when
-  (syntax-rules ()
-    ((when condition . stmts)
-      (and condition (begin . stmts)))))
+;; This isn't a great API, but a more proper fix will involve hacking
+;; SSAX.
+(define (reset-parsed-entity-definitions!)
+  "Restore the set of parsed entity definitions to its initial state."
+  (set! ssax:predefined-parsed-entities
+        '((amp . "&")
+          (lt . "<")
+          (gt . ">")
+          (apos . "'")
+          (quot . "\""))))
+
+(define (define-parsed-entity! entity str)
+  "Define a new parsed entity. @var{entity} should be a symbol.
+
+Instances of &@var{entity}; in XML text will be replaced with the
+string @var{str}, which will then be parsed."
+  (set! ssax:predefined-parsed-entities
+        (acons entity str ssax:predefined-parsed-entities)))
 
 ;; Execute a sequence of forms and return the result of the _first_ one.
 ;; Like PROG1 in Lisp. Typically used to evaluate one or more forms with