From scaekenberghe at common-lisp.net  Fri Oct 22 10:37:00 2004
From: scaekenberghe at common-lisp.net (Sven Van Caekenberghe)
Date: Fri, 22 Oct 2004 12:37:00 +0200
Subject: [s-xml-cvs] CVS update: s-xml/src/xml.lisp 
Message-ID: <E1CKwn6-0007OR-00@common-lisp.net>

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

Modified Files:
	xml.lisp 
Log Message:
fixed a bug: in a tag containing whitespace, like <foo> </foo> the parser collapsed and ingnored all whitespace and considered the tag to be empty!
this is now fixed and a unit test has been added
cleaned up xml character escaping a bit: single quotes and all normal whitespace (newline, return and tab) is preserved
a unit test for this has been added

Date: Fri Oct 22 12:36:58 2004
Author: scaekenberghe

Index: s-xml/src/xml.lisp
diff -u s-xml/src/xml.lisp:1.4 s-xml/src/xml.lisp:1.5
--- s-xml/src/xml.lisp:1.4	Thu Aug 19 16:55:20 2004
+++ s-xml/src/xml.lisp	Fri Oct 22 12:36:58 2004
@@ -1,6 +1,6 @@
 ;;;; -*- mode: lisp -*-
 ;;;;
-;;;; $Id: xml.lisp,v 1.4 2004/08/19 14:55:20 bmastenbrook Exp $
+;;;; $Id: xml.lisp,v 1.5 2004/10/22 10:36:58 scaekenberghe Exp $
 ;;;;
 ;;;; This is a Common Lisp implementation of a very basic XML parser.
 ;;;; The parser is non-validating and not at all complete (no CDATA).
@@ -88,9 +88,7 @@
 	     (#\< (write-string "&lt;" stream))
 	     (#\> (write-string "&gt;" stream))
 	     (#\" (write-string "&quot;" stream))
-	     #+nil (#\' (write-string "&apos;" stream))
-             (#\' (write-string "'" stream))
-             (#\Newline (write-string (string #\newline) stream))
+             ((#\newline #\return #\tab) (write-char char stream))
 	     (t (if (and (<= 32 (char-code char))
 			 (<= (char-code char) 126))
 		    (write-char char stream)
@@ -355,7 +353,7 @@
   (when (char= (peek-char nil stream nil nil) #\!)
     (skip-special-tag stream)
     (return-from parse-xml-element))
-  (let (char buffer open-tag parent-seed)
+  (let (char buffer open-tag parent-seed has-children)
     (setf parent-seed (get-seed state))
     ;; read tag name (no whitespace between < and name ?)
     (setf open-tag (intern (parse-identifier stream (get-mini-buffer state)) :keyword))
@@ -389,6 +387,10 @@
 	      (if (char= (peek-char nil stream nil nil) #\/)
 		  (progn
 		    ;; handle the matching closing tag </tag> and done
+                    ;; if we read whitespace as this (leaf) element's contents, it is significant
+                    (when (and (not has-children) (plusp (length buffer)))
+                      (setf (get-seed state) (funcall (get-text-hook state)
+                                                      (copy-seq buffer) (get-seed state))))
 		    (read-char stream)
 		    (let ((close-tag (intern (parse-identifier stream (get-mini-buffer state)) :keyword)))
 		      (unless (eq open-tag close-tag)
@@ -400,7 +402,10 @@
 						      open-tag attributes parent-seed (get-seed state))))
 		    (return))
 		;; handle child tag and loop, no hooks to call here
-		(parse-xml-element stream state)))
+                ;; whitespace between child elements is skipped
+                (progn
+                  (setf has-children t)
+                  (parse-xml-element stream state))))
 	     (t
 	      ;; no child tag, concatenate text to whitespace in buffer
 	      ;; handle text content and loop




From scaekenberghe at common-lisp.net  Fri Oct 22 10:37:00 2004
From: scaekenberghe at common-lisp.net (Sven Van Caekenberghe)
Date: Fri, 22 Oct 2004 12:37:00 +0200
Subject: [s-xml-cvs] CVS update: s-xml/test/test-xml.lisp 
Message-ID: <E1CKwn6-0007Od-00@common-lisp.net>

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

Modified Files:
	test-xml.lisp 
Log Message:
fixed a bug: in a tag containing whitespace, like <foo> </foo> the parser collapsed and ingnored all whitespace and considered the tag to be empty!
this is now fixed and a unit test has been added
cleaned up xml character escaping a bit: single quotes and all normal whitespace (newline, return and tab) is preserved
a unit test for this has been added

Date: Fri Oct 22 12:37:00 2004
Author: scaekenberghe

Index: s-xml/test/test-xml.lisp
diff -u s-xml/test/test-xml.lisp:1.1.1.1 s-xml/test/test-xml.lisp:1.2
--- s-xml/test/test-xml.lisp:1.1.1.1	Mon Jun  7 20:49:59 2004
+++ s-xml/test/test-xml.lisp	Fri Oct 22 12:37:00 2004
@@ -1,6 +1,6 @@
 ;;;; -*- mode: lisp -*-
 ;;;;
-;;;; $Id: test-xml.lisp,v 1.1.1.1 2004/06/07 18:49:59 scaekenberghe Exp $
+;;;; $Id: test-xml.lisp,v 1.2 2004/10/22 10:37:00 scaekenberghe Exp $
 ;;;;
 ;;;; Unit and functional tests for xml.lisp
 ;;;;
@@ -51,8 +51,13 @@
 	       "&lt;foo&gt;"))
 
 (assert
- (string-equal (with-output-to-string (stream) (print-string-xml "'	'" stream))
-	       "&apos;&#x9;&apos;"))
+ (string-equal (with-output-to-string (stream) (print-string-xml "' '" stream))
+               "' '"))
+
+(assert
+ (let ((string (map 'string #'identity '(#\return #\tab #\newline))))
+   (string-equal (with-output-to-string (stream) (print-string-xml string stream))
+                 string)))
 
 (defun simple-echo-xml (in out)
   (start-parse-xml
@@ -71,12 +76,19 @@
 				 (declare (ignore seed))
 				 (princ string out)))))
 
+(defun simple-echo-xml-string (string)
+  (with-input-from-string (in string)
+      (with-output-to-string (out)
+	(simple-echo-xml in out))))
+
 (assert
  (let ((xml "<FOO ATT1='1' ATT2='2'><B>Text</B><EMPTY></EMPTY>More text!<SUB><SUB></SUB></SUB></FOO>"))
-   (equal
-    (with-input-from-string (in xml)
-      (with-output-to-string (out)
-	(simple-echo-xml in out)))
-    xml)))
+   (equal (simple-echo-xml-string xml)
+          xml)))
+
+(assert 
+  (let ((xml "<p> </p>"))
+    (equal (simple-echo-xml-string xml)
+           xml)))
 
 ;;;; eof