[s-xml-cvs] CVS update: s-xml/src/xml.lisp

[Sven Van Caekenberghe]

Update of /project/s-xml/cvsroot/s-xml/src
In directory common-lisp.net:/tmp/cvs-serv17887/src

Modified Files:
	xml.lisp 
Log Message:
added CDATA support (patch contributed by Peter Van Eynde pvaneynd at mailworks.org)

Date: Sun Nov  6 13:44:48 2005
Author: scaekenberghe

Index: s-xml/src/xml.lisp
diff -u s-xml/src/xml.lisp:1.12 s-xml/src/xml.lisp:1.13
--- s-xml/src/xml.lisp:1.12	Thu Sep  8 17:39:29 2005
+++ s-xml/src/xml.lisp	Sun Nov  6 13:44:48 2005
@@ -1,6 +1,6 @@
 ;;;; -*- mode: lisp -*-
 ;;;;
-;;;; $Id: xml.lisp,v 1.12 2005/09/08 15:39:29 scaekenberghe Exp $
+;;;; $Id: xml.lisp,v 1.13 2005/11/06 12:44:48 scaekenberghe Exp $
 ;;;;
 ;;;; This is a Common Lisp implementation of a basic but usable XML parser.
 ;;;; The parser is non-validating and not complete (no CDATA).
@@ -446,7 +446,32 @@
   (if (char/= (read-char stream nil nil) #\>)
       (error (parser-error "expected > ending comment" nil stream))))
 
-(defun skip-special-tag (stream)
+(defun read-cdata (stream state &optional (string (make-extendable-string)))
+  "Reads in the CDATA and calls the callback for CDATA if it exists"
+  ;; we already read the <![CDATA[ stuff
+  ;; continue to read until we hit ]]>
+  (let ((char #\space)
+	(last-3-characters (list #\[ #\A #\T))
+	(pattern (list #\> #\] #\])))
+    (loop
+     (setf char (read-char stream nil nil))
+     (when (null char) (error (parser-error "encountered unexpected eof in text")))
+     (push char last-3-characters)
+     (setf (cdddr last-3-characters) nil)
+     (cond
+       ((equal last-3-characters
+	       pattern)
+	(setf (fill-pointer string)
+	      (- (fill-pointer string) 2))
+	(setf (get-seed state)
+	      (funcall (get-text-hook state)
+		       (copy-seq string)
+		       (get-seed state)))
+	(return-from read-cdata))
+       (t
+	(vector-push-extend char string))))))
+
+(defun skip-special-tag (stream state)
   "Skip an XML special tag (comments and processing instructions) in
   stream, positioned after the opening '<', unexpected eof is an error"
   ;; opening < has been read, consume ? or !
@@ -458,6 +483,15 @@
       (when (char= char #\-)
 	(skip-comment stream)
 	(return-from skip-special-tag)))
+    ;; maybe we are dealing with CDATA?
+    (when (and (char= char #\[)
+	       (loop :for pattern :across "CDATA["
+		     :for char = (read-char stream nil nil)
+		     :when (null char) :do
+		     (error (parser-error "encountered unexpected eof in cdata"))
+		     :always (char= char pattern)))
+      (read-cdata stream state (get-buffer state))
+      (return-from skip-special-tag))
     ;; loop over chars, dealing with strings (skipping their content)
     ;; and counting opening and closing < and > chars
     (let ((taglevel 1)
@@ -510,7 +544,7 @@
   (declare (special *namespaces*))
   ;; opening < has been read
   (when (char= (peek-char nil stream nil nil) #\!)
-    (skip-special-tag stream)
+    (skip-special-tag stream state)
     (return-from parse-xml-element))
   (let (char buffer open-tag parent-seed has-children)
     (setf parent-seed (get-seed state))
@@ -589,7 +623,7 @@
      (setf char (peek-char nil stream nil nil))
      (if (or (char= char #\!) (char= char #\?))
 	 ;; deal with special tags
-	 (skip-special-tag stream)
+	 (skip-special-tag stream state)
        (progn
 	 ;; read the main element
 	 (parse-xml-element stream state)