<html>
<head>
</head>
<body class='hmmessage'><div dir='ltr'>
<div dir="ltr">
<style><!--
.hmmessage P
{
margin:0px;
padding:0px
}
body.hmmessage
{
font-size: 10pt;
font-family:Tahoma
}
--></style>
<div dir="ltr">I made a small extension to s-xml to make it parse DOCTYPE and ENTITY tags, that seems to work as far as I've tested. I don't know how to make a patch as I sometimes see posted by others (maybe someone can tell me?), so I'll just post the code here. I'm not entirely happy with the read-entity function because of the flags, but since I wanted to use the same coding style (useing the "when" strucutre) and I couldn't think of/wanted to spend more time on a way to do it smarter, this is how it is.</div><div dir="ltr"><br></div><div dir="ltr">Note that the <span style="font-size: 10pt; ">function</span><span style="font-size: 10pt; "> "skip-special-tag" in "xml.lisp" is replaced by the function below.</span></div><div dir="ltr"><div><br></div><div><div>(defun skip-special-tag (stream state)</div><div> "Skip an XML special tag (comments and processing instructions) in</div><div> stream, positioned after the opening '<', unexpected eof is an error"</div><div> ;; opening < has been read, consume ? or !</div><div> (read-char stream)</div><div> (let ((char (read-char stream nil #\Null)))</div><div> (declare (type character char))</div><div> ;; see if we are dealing with a comment</div><div> (when (char= char #\-)</div><div> (setf char (read-char stream nil #\Null))</div><div> (when (char= char #\-)</div><div> <span class="Apple-tab-span" style="white-space:pre"> </span>(skip-comment stream)</div><div> <span class="Apple-tab-span" style="white-space:pre"> </span>(return-from skip-special-tag)))</div><div> ;; maybe we are dealing with CDATA?</div><div> (when (and (char= char #\[)</div><div><span class="Apple-tab-span" style="white-space:pre"> </span> (loop :for pattern :across "CDATA["</div><div><span class="Apple-tab-span" style="white-space:pre"> </span> :for char = (read-char stream nil #\Null)</div><div><span class="Apple-tab-span" style="white-space:pre"> </span> :when (char= char #\Null) :do</div><div><span class="Apple-tab-span" style="white-space:pre"> </span> (error (parser-error "encountered unexpected eof in cdata"))</div><div><span class="Apple-tab-span" style="white-space:pre"> </span> :always (char= char pattern)))</div><div> (read-cdata stream state (get-buffer state))</div><div> (return-from skip-special-tag))</div><div> ;; maybe we are dealing with DOCTYPE?</div><div> (when (and (char= char #\D)</div><div><span class="Apple-tab-span" style="white-space:pre"> </span> (loop :for pattern :across "OCTYPE"</div><div><span class="Apple-tab-span" style="white-space:pre"> </span> :for char = (read-char stream nil #\Null)</div><div><span class="Apple-tab-span" style="white-space:pre"> </span> :when (char= char #\Null) :do</div><div><span class="Apple-tab-span" style="white-space:pre"> </span> (error (parser-error "encountered unexpected eof in DOCTYPE"))</div><div><span class="Apple-tab-span" style="white-space:pre"> </span> :always (char= char pattern)))</div><div> (read-doctype stream state (get-buffer state))</div><div> (return-from skip-special-tag))</div><div> ;; loop over chars, dealing with strings (skipping their content)</div><div> ;; and counting opening and closing < and > chars</div><div> (let ((taglevel 1)</div><div><span class="Apple-tab-span" style="white-space:pre"> </span> (string-delimiter #\Null))</div><div> (declare (type character string-delimiter))</div><div> (loop</div><div> (when (zerop taglevel) (return))</div><div> (setf char (read-char stream nil #\Null))</div><div> (when (char= char #\Null)</div><div><span class="Apple-tab-span" style="white-space:pre"> </span> (error (parser-error "encountered unexpected eof for special (! or ?) tag" nil stream)))</div><div> (if (char/= string-delimiter #\Null)</div><div> <span class="Apple-tab-span" style="white-space:pre"> </span> ;; inside a string we only look for a closing string delimiter</div><div> <span class="Apple-tab-span" style="white-space:pre"> </span> (when (char= char string-delimiter)</div><div> <span class="Apple-tab-span" style="white-space:pre"> </span> (setf string-delimiter #\Null))</div><div> <span class="Apple-tab-span" style="white-space:pre"> </span> ;; outside a string we count < and > and watch out for strings</div><div> <span class="Apple-tab-span" style="white-space:pre"> </span> (cond ((or (char= char #\') (char= char #\")) (setf string-delimiter char))</div><div> <span class="Apple-tab-span" style="white-space:pre"> </span> ((char= char #\<) (incf taglevel))</div><div> <span class="Apple-tab-span" style="white-space:pre"> </span> ((char= char #\>) (decf taglevel))))))))</div><div><br></div><div>(defun read-doctype (stream state string)</div><div> "Reads in the DOCTYPE and calls the callback for ENTITY if it exists"</div><div> ;; we already read the <!DOCTYPE stuff continue to read until we hit ]></div><div> ;; and read in the entities</div><div> (let ((char #\space) (last-2-characters (list #\E #\P)) (pattern (list #\> #\])))</div><div> (declare (type character char))</div><div> (loop</div><div> (setf char (read-char stream nil #\Null))</div><div> (when (char= char #\Null) (error (parser-error "encountered unexpected eof in DOCTYPE content")))</div><div> ;; maybe we are dealing with an ENTITY?</div><div> (when (and (char= char #\<)</div><div><span class="Apple-tab-span" style="white-space:pre"> </span> (loop :for pattern :across "!ENTITY"</div><div> <span class="Apple-tab-span" style="white-space:pre"> </span> :for char = (read-char stream nil #\Null)</div><div> <span class="Apple-tab-span" style="white-space:pre"> </span> :when (char= char #\Null) :do</div><div> <span class="Apple-tab-span" style="white-space:pre"> </span> (error (parser-error "encountered unexpected eof in ENTITY"))</div><div> <span class="Apple-tab-span" style="white-space:pre"> </span> :always (char= char pattern)))</div><div> (read-entity stream state (get-buffer state)))</div><div> ;; Push the new character onto the last-2-characters list</div><div> (push char last-2-characters)</div><div> (setf (cddr last-2-characters) nil)</div><div> (cond</div><div> ((equal last-2-characters pattern)</div><div> <span class="Apple-tab-span" style="white-space:pre"> </span>(setf (fill-pointer string) (- (fill-pointer string) 2))</div><div> <span class="Apple-tab-span" style="white-space:pre"> </span>(setf (get-seed state) (funcall (get-text-hook state)</div><div> <span class="Apple-tab-span" style="white-space:pre"> </span> (copy-seq string)</div><div> <span class="Apple-tab-span" style="white-space:pre"> </span> (get-seed state)))</div><div> <span class="Apple-tab-span" style="white-space:pre"> </span>(return-from read-doctype))</div><div> (t (vector-push-extend char string))))))</div><div><br></div><div><div>(defun read-entity (stream state string)</div><div> "Reads in the ENTITY and adds it to the known entity list"</div><div> ;; we already read the <!ENTITY stuff continue to read until we hit ></div><div> (let ((char (read-char stream nil #\Null)) (ent "") (value "") (ent-flag nil) (value-flag nil))</div><div> (declare (type character char))</div><div> (loop</div><div> (setf char (read-char stream nil #\Null))</div><div> (when (char= char #\Null) (error (parser-error "encountered unexpected eof in entity content")))</div><div> ;; If > is encountered, store the entity in the known entities and return</div><div> (when (char= char #\>) </div><div> (setf (gethash ent (get-entities state)) value)</div><div> (return-from read-entity))</div><div> ;; If char /= space and no space has been encountered yet</div><div> ;; store the characters in ent</div><div> (when (and (char/= char #\space) (not value-flag))</div><div> (setf ent-flag t)</div><div> (setf ent (concatenate 'string ent (string char))))</div><div> ;; If char /= space and a space has been encountered</div><div> ;; store the characters in value</div><div> (when (and (char/= char #\space) value-flag)</div><div> (setf value (concatenate 'string value (string char))))</div><div> ;; If char = space then flag beginning of value</div><div> (when (and (char= char #\space) ent-flag)</div><div> (setf value-flag t)) )))</div></div></div></div>
</div>
</div></body>
</html>