Commit 96e5d471 authored by Sven Van Caekenberghe's avatar Sven Van Caekenberghe
Browse files

fixed a bug: in a tag containing whitespace, like <foo> </foo> the parser...

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
parent 3f48764d
;;;; -*- mode: lisp -*-
;;;; $Id: xml.lisp,v 1.3 2004/06/11 11:14:42 scaekenberghe Exp $
;;;; $Id: xml.lisp,v 1.4 2004/08/19 14:55:20 bmastenbrook 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) #\/)
;; 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))))
;; handle child tag and loop, no hooks to call here
(parse-xml-element stream state)))
;; whitespace between child elements is skipped
(setf has-children t)
(parse-xml-element stream state))))
;; no child tag, concatenate text to whitespace in buffer
;; handle text content and loop
;;;; -*- mode: lisp -*-
;;;; $Id: test-xml.lisp,v 1.6 2003/06/05 08:40:40 sven Exp $
;;;; $Id: test-xml.lisp,v 2004/06/07 18:49:59 scaekenberghe Exp $
;;;; Unit and functional tests for xml.lisp
......@@ -51,8 +51,13 @@
(string-equal (with-output-to-string (stream) (print-string-xml "' '" stream))
(string-equal (with-output-to-string (stream) (print-string-xml "' '" stream))
"' '"))
(let ((string (map 'string #'identity '(#\return #\tab #\newline))))
(string-equal (with-output-to-string (stream) (print-string-xml string stream))
(defun simple-echo-xml (in out)
......@@ -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))))
(let ((xml "<FOO ATT1='1' ATT2='2'><B>Text</B><EMPTY></EMPTY>More text!<SUB><SUB></SUB></SUB></FOO>"))
(with-input-from-string (in xml)
(with-output-to-string (out)
(simple-echo-xml in out)))
(equal (simple-echo-xml-string xml)
(let ((xml "<p> </p>"))
(equal (simple-echo-xml-string xml)
;;;; eof
\ No newline at end of file
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment