Update of /project/s-xml/cvsroot/s-xml/src
In directory common-lisp.net:/tmp/cvs-serv32224/src
Modified Files:
xml.lisp
Log Message:
moved echo code into its own file in test/
Date: Wed Aug 17 15:44:29 2005
Author: scaekenberghe
Index: s-xml/src/xml.lisp
diff -u s-xml/src/xml.lisp:1.6 s-xml/src/xml.lisp:1.7
--- s-xml/src/xml.lisp:1.6 Mon Jan 24 11:03:09 2005
+++ s-xml/src/xml.lisp Wed Aug 17 15:44:29 2005
@@ -1,6 +1,6 @@
;;;; -*- mode: lisp -*-
;;;;
-;;;; $Id: xml.lisp,v 1.6 2005/01/24 10:03:09 scaekenberghe Exp $
+;;;; $Id: xml.lisp,v 1.7 2005/08/17 13:44:29 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).
@@ -111,11 +111,10 @@
entities))
(defun resolve-entity (stream extendable-string entities &optional (entity (make-extendable-string)))
- "Read and resolve an XML entity from stream, positioned on the '&'
- entity marker, accepting &name; , &DEC; and &#HEX; formats,
+ "Read and resolve an XML entity from stream, positioned after the '&' entity marker,
+ accepting &name; &#DEC; and &#xHEX; formats,
destructively modifying string, which is also returned,
- destructively modifying entity, incorrect entity formats result in
- errors"
+ destructively modifying entity, incorrect entity formats result in errors"
(loop
(let ((char (read-char stream nil nil)))
(cond ((null char) (error (parser-error "encountered eof before end of entity")))
@@ -123,14 +122,15 @@
(t (vector-push-extend char entity)))))
(if (char= (char entity 0) #\#)
(let ((code (if (char= (char entity 1) #\x)
- (parse-integer entity :start 2 :radix 16)
- (parse-integer entity :start 1 :radix 10))))
- (if (null code) (error (parser-error "encountered incorrect entity &~s;" (list entity) stream)))
+ (parse-integer entity :start 2 :radix 16 :junk-allowed t)
+ (parse-integer entity :start 1 :radix 10 :junk-allowed t))))
+ (when (null code)
+ (error (parser-error "encountered incorrect entity &~s;" (list entity) stream)))
(vector-push-extend (code-char code) extendable-string))
(let ((value (gethash entity entities)))
(if value
- (dotimes (i (length value))
- (vector-push-extend (char value i) extendable-string))
+ (loop :for char :across value
+ :do (vector-push-extend char extendable-string))
(error (parser-error "encountered unknown entity &~s;" (list entity) stream)))))
extendable-string)
@@ -431,56 +431,5 @@
;; read the main element
(parse-xml-element stream state)
(return-from start-parse-xml (get-seed state)))))))
-
-;;; A simple example as well as a useful tool: parse, echo and pretty print XML
-
-(defun indent (stream count)
- (loop :repeat (* count 2) :do (write-char #\space stream)))
-
-(defclass echo-xml-seed ()
- ((stream :initarg :stream)
- (level :initarg :level :initform 0)))
-
-#+NIL
-(defmethod print-object ((seed echo-xml-seed) stream)
- (with-slots (stream level) seed
- (print-unreadable-object (seed stream :type t)
- (format stream "level=~d" level))))
-
-(defun echo-xml-new-element-hook (name attributes seed)
- (with-slots (stream level) seed
- (indent stream level)
- (format stream "<~a" name)
- (dolist (attribute (reverse attributes))
- (format stream " ~a=\'" (car attribute))
- (print-string-xml (cdr attribute) stream)
- (write-char #\' stream))
- (format stream ">~%")
- (incf level)
- seed))
-
-(defun echo-xml-finish-element-hook (name attributes parent-seed seed)
- (declare (ignore attributes parent-seed))
- (with-slots (stream level) seed
- (decf level)
- (indent stream level)
- (format stream "</~a>~%" name)
- seed))
-
-(defun echo-xml-text-hook (string seed)
- (with-slots (stream level) seed
- (indent stream level)
- (print-string-xml string stream)
- (terpri stream)
- seed))
-
-(defun echo-xml (in out)
- "Parse a toplevel XML element from stream in, echoing and pretty printing the result to stream out"
- (start-parse-xml in
- (make-instance 'xml-parser-state
- :seed (make-instance 'echo-xml-seed :stream out)
- :new-element-hook #'echo-xml-new-element-hook
- :finish-element-hook #'echo-xml-finish-element-hook
- :text-hook #'echo-xml-text-hook)))
;;;; eof
