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