From ec128ad2d08568b0d60bda377cdfd4dd59032ca9 Mon Sep 17 00:00:00 2001
From: Chris Hanson <org/chris-hanson/cph>
Date: Mon, 9 Dec 2002 19:03:38 +0000
Subject: [PATCH] Add ability to specify handlers for processing instructions. 
 These handlers are invoked during parsing, and their results replace the
 processing instructions in the XML output tree.

---
 v7/src/xml/xml-parser.scm | 115 +++++++++++++++++++++++++++-----------
 1 file changed, 82 insertions(+), 33 deletions(-)

diff --git a/v7/src/xml/xml-parser.scm b/v7/src/xml/xml-parser.scm
index bd38d6b1b..a0042e016 100644
--- a/v7/src/xml/xml-parser.scm
+++ b/v7/src/xml/xml-parser.scm
@@ -1,6 +1,6 @@
 ;;; -*-Scheme-*-
 ;;;
-;;; $Id: xml-parser.scm,v 1.14 2002/12/08 17:58:45 cph Exp $
+;;; $Id: xml-parser.scm,v 1.15 2002/12/09 19:03:38 cph Exp $
 ;;;
 ;;; Copyright (c) 2001, 2002 Massachusetts Institute of Technology
 ;;;
@@ -94,41 +94,56 @@
 
 ;;;; Top level
 
-(define (parse-xml-document buffer)	;[1,22]
-  (let ((one-value (lambda (v) (and v (vector-ref v 0)))))
-    (fluid-let ((*general-entities* (predefined-entities))
-		(*standalone?*)
-		(*internal-dtd?* #t))
-      (let ((declaration (one-value (parse-declaration buffer))))
-	(set! *standalone?*
-	      (and declaration
-		   (equal? (xml-declaration-standalone declaration)
-			   "yes")))
-	(let* ((misc-1 (one-value (parse-misc buffer)))
-	       (dtd (one-value (parse-dtd buffer)))
-	       (misc-2 (if dtd (one-value (parse-misc buffer)) '()))
-	       (element
-		(or (one-value (parse-element buffer))
-		    (perror buffer "Missing root element")))
-	       (misc-3 (one-value (parse-misc buffer))))
-	  (if (peek-parser-buffer-char buffer)
-	      (perror buffer "Unparsed content in input"))
-	  (make-xml-document declaration
-			     misc-1
-			     dtd
-			     misc-2
-			     element
-			     misc-3))))))
+(define (parse-xml-document buffer #!optional pi-handlers) ;[1,22]
+  (if (not (parser-buffer? buffer))
+      (error:wrong-type-argument buffer "parser buffer" 'PARSE-XML-DOCUMENT))
+  (let ((pi-handlers (if (default-object? pi-handlers) '() pi-handlers)))
+    (if (not (list-of-type? pi-handlers
+	       (lambda (entry)
+		 (and (pair? entry)
+		      (symbol? (car entry))
+		      (pair? (cdr entry))
+		      (procedure? (cadr entry))
+		      (procedure-arity-valid? (cadr entry) 1)
+		      (null? (cddr entry))))))
+	(error:wrong-type-argument pi-handlers "handler alist"
+				   'PARSE-XML-DOCUMENT))
+    (let ((one-value (lambda (v) (and v (vector-ref v 0)))))
+      (fluid-let ((*general-entities* (predefined-entities))
+		  (*standalone?*)
+		  (*internal-dtd?* #t)
+		  (*pi-handlers* pi-handlers))
+	(let ((declaration (one-value (parse-declaration buffer))))
+	  (set! *standalone?*
+		(and declaration
+		     (equal? (xml-declaration-standalone declaration)
+			     "yes")))
+	  (let* ((misc-1 (one-value (parse-misc buffer)))
+		 (dtd (one-value (parse-dtd buffer)))
+		 (misc-2 (if dtd (one-value (parse-misc buffer)) '()))
+		 (element
+		  (or (one-value (parse-element buffer))
+		      (perror buffer "Missing root element")))
+		 (misc-3 (one-value (parse-misc buffer))))
+	    (if (peek-parser-buffer-char buffer)
+		(perror buffer "Unparsed content in input"))
+	    (make-xml-document declaration
+			       misc-1
+			       dtd
+			       misc-2
+			       element
+			       misc-3)))))))
 
 (define *standalone?*)
 (define *internal-dtd?*)
+(define *pi-handlers*)
 
 (define parse-misc			;[27]
   (*parser
    (encapsulate vector->list
      (* (top-level
 	 (alt parse-comment
-	      parse-processing-instructions
+	      parse-pi:misc
 	      (map normalize-line-endings (match S))))))))
 
 (define (xml-declaration-parser description allow-standalone?)
@@ -262,7 +277,7 @@
 	(* (seq (alt parse-element
 		     parse-reference
 		     parse-cdata-section
-		     parse-processing-instructions
+		     parse-pi:element
 		     parse-comment)
 		parse-char-data)))))
 
@@ -303,18 +318,27 @@
 
 (define parse-cdata-section		;[18,19,20,21]
   (bracketed-region-parser "CDATA section" "<![CDATA[" "]]>"))
+
+;;;; Processing instructions
 
-(define parse-processing-instructions	;[16,17]
+(define (pi-parser valid-content?) ;[16,17]
   (let ((description "processing instructions")
 	(start "<?")
 	(end "?>"))
     (let ((parse-body
 	   (terminated-region-parser description alphabet:xml-char end)))
       (*parser
-       (encapsulate
+       (transform
 	   (lambda (v)
-	     (make-xml-processing-instructions (vector-ref v 0)
-					       (vector-ref v 1)))
+	     (let ((name (vector-ref v 0))
+		   (text (vector-ref v 1)))
+	       (let ((entry (assq name *pi-handlers*)))
+		 (if entry
+		     (let ((content ((cadr entry) text)))
+		       (if (not (list-of-type? content valid-content?))
+			   (error "Illegal output from XML processor:" name))
+		       (list->vector content))
+		     (vector (make-xml-processing-instructions name text))))))
 	 (sbracket description start end
 	   (with-pointer p
 	     (map (lambda (name)
@@ -323,6 +347,31 @@
 		    name)
 		  parse-required-name))
 	   parse-body))))))
+
+(define parse-pi:misc
+  (pi-parser
+   (lambda (object)
+     (or (string? object)
+	 (xml-comment? object)
+	 (xml-processing-instructions? object)))))
+
+(define parse-pi:element
+  (pi-parser
+   (lambda (object)
+     (or (string? object)
+	 (xml-element? object)
+	 (xml-comment? object)
+	 (xml-processing-instructions? object)))))
+
+(define parse-pi:internal-markup-decl
+  (pi-parser
+   (lambda (object)
+     (or (xml-!element? object)
+	 (xml-!attlist? object)
+	 (xml-!entity? object)
+	 (xml-!notation? object)
+	 (xml-comment? object)
+	 (xml-processing-instructions? object)))))
 
 ;;;; Names and references
 
@@ -704,7 +753,7 @@
 	parse-!attlist
 	parse-!entity
 	parse-!notation
-	parse-processing-instructions
+	parse-pi:internal-markup-decl
 	parse-comment)))
 
 (define parse-!element			;[45]
-- 
2.25.1