pxml1.cl

   1 ;;
   2 ;; copyright (c) 1986-2000 Franz Inc, Berkeley, CA
   3 ;;
   4 ;; This code is free software; you can redistribute it and/or
   5 ;; modify it under the terms of the version 2.1 of
   6 ;; the GNU Lesser General Public License as published by
   7 ;; the Free Software Foundation, as clarified by the AllegroServe
   8 ;; prequel found in license-allegroserve.txt.
   9 ;;
  10 ;; This code is distributed in the hope that it will be useful,
  11 ;; but without any warranty; without even the implied warranty of
  12 ;; merchantability or fitness for a particular purpose.  See the GNU
  13 ;; Lesser General Public License for more details.
  14 ;;
  15 ;; Version 2.1 of the GNU Lesser General Public License is in the file
  16 ;; license-lgpl.txt that was distributed with this file.
  17 ;; If it is not present, you can access it from
  18 ;; http://www.gnu.org/copyleft/lesser.txt (until superseded by a newer
  19 ;; version) or write to the Free Software Foundation, Inc., 59 Temple Place,
  20 ;; Suite 330, Boston, MA  02111-1307  USA
  21 ;;
  22 ;; Change Log
  23 ;;
  24 ;; 10/14/00 add namespace support; xml-error fix
  25
  26 (in-package :net.xml.parser)
  27
  28 (pxml-dribble-bug-hook "$Id$")
  29
  30 (defparameter *collectors* (list nil nil nil nil nil nil nil nil))
  31
  32 (defun put-back-collector (col)
  33   (declare (optimize (speed 3) (safety 1)))
  34   (without-scheduling
  35     (do ((cols *collectors* (cdr cols)))
  36         ((null cols)
  37          ; toss it away
  38          nil)
  39       (if* (null (car cols))
  40          then (setf (car cols) col)
  41               (return)))))
  42
  43 (defun pub-id-char-p (char)
  44   (declare (optimize (speed 3) (safety 1)))
  45   (let ((code (char-code char)))
  46     (or (= #x20 code) (= #xD code) (= #xA code)
  47         (<= (char-code #\a) code (char-code #\z))
  48         (<= (char-code #\A) code (char-code #\Z))
  49         (<= (char-code #\0) code (char-code #\9))
  50         (member char '( #\- #\' #\( #\) #\+ #\, #\. #\/ #\: #\= #\?
  51                        #\; #\! #\* #\# #\@ #\$ #\_ #\%)))))
  52
  53 (defparameter *keyword-package* (find-package :keyword))
  54
  55 ;; cache of tokenbuf structs
  56 (defparameter *tokenbufs* (list nil nil nil nil))
  57
  58 (defstruct iostruct
  59   unget-char ;; character pushed back
  60   tokenbuf ;; main input tokenbuf
  61   read-sequence-func ;; optional alternative to read-sequence
  62   entity-bufs ;; active entity tokenbufs
  63   entity-names ;; active entity names
  64   parameter-entities
  65   general-entities
  66   do-entity  ;; still substituting entity text
  67   seen-any-dtd
  68   seen-external-dtd
  69   seen-parameter-reference
  70   standalonep
  71   uri-to-package
  72   ns-to-package
  73   ns-scope
  74   )
  75
  76 (defstruct tokenbuf
  77   cur ;; next index to use to grab from tokenbuf
  78   max ;; index one beyond last character
  79   data ;; character array
  80   stream ;; for external sources
  81   )
  82
  83 (defun get-tokenbuf ()
  84   (declare (optimize (speed 3) (safety 1)))
  85   (let (buf)
  86     (without-scheduling
  87       (do* ((bufs *tokenbufs* (cdr bufs))
  88             (this (car bufs) (car bufs)))
  89           ((null bufs))
  90         (if* this
  91            then (setf (car bufs) nil)
  92                 (setq buf this)
  93                 (return))))
  94     (if* buf
  95        then (setf (tokenbuf-cur buf) 0)
  96             (setf (tokenbuf-max buf) 0)
  97             (setf (tokenbuf-stream buf) nil)
  98             buf
  99        else (make-tokenbuf
 100              :cur 0
 101              :max  0
 102              :data (make-array 1024 :element-type 'character)))))
 103
 104 (defstruct collector
 105   next  ; next index to set
 106   max   ; 1+max index to set
 107   data  ; string vector
 108   )
 109
 110 (defun compute-tag (coll &optional (package *keyword-package*) ns-to-package)
 111   (declare (optimize (speed 3) (safety 1)))
 112   ;; compute the symbol named by what's in the collector
 113   (if* (not ns-to-package)
 114      then (excl::intern* (collector-data coll) (collector-next coll) package)
 115      else
 116           (let (new-package (data (collector-data coll)))
 117             (if* (and (eq (schar data 0) #\x)
 118                       (eq (schar data 1) #\m)
 119                       (eq (schar data 2) #\l)
 120                       (eq (schar data 3) #\n)
 121                       (eq (schar data 4) #\s)
 122                       (or (eq (schar data 5) #\:)
 123                           (= (collector-next coll) 5)))
 124                then ;; putting xmlns: in :none namespace
 125                     (setf new-package (assoc :none ns-to-package))
 126                     (when new-package (setf package (rest new-package)))
 127                     (excl::intern* (collector-data coll) (collector-next coll) package)
 128                else
 129                     (let ((colon-index -1)
 130                           (data (collector-data coll)))
 131                       (dotimes (i (collector-next coll))
 132                         (when (eq (schar data i) #\:)
 133                           (setf colon-index i)
 134                           (return)))
 135                       (if* (> colon-index -1) then
 136                               (let ((string1 (make-string colon-index))
 137                                     new-package string2)
 138                                 (dotimes (i colon-index)
 139                                   (setf (schar string1 i) (schar data i)))
 140                                 (setf new-package (assoc string1 ns-to-package :test 'string=))
 141                                 (if* new-package
 142                                    then
 143                                         (setf string2 (make-string (- (collector-next coll)
 144                                                                       (+ 1 colon-index))))
 145                                         (dotimes (i (- (collector-next coll)
 146                                                        (+ 1 colon-index)))
 147                                           (setf (schar string2 i)
 148                                             (schar data (+ colon-index 1 i))))
 149                                         (excl::intern string2 (rest new-package))
 150                                    else
 151                                         (excl::intern* (collector-data coll)
 152                                                        (collector-next coll) package)))
 153                          else
 154                               (let ((new-package (assoc :none ns-to-package)))
 155                                 (when new-package
 156                                   (setf package (rest new-package))))
 157                               (excl::intern* (collector-data coll)
 158                                              (collector-next coll) package)))
 159                     ))
 160           ))
 161
 162 (defun compute-coll-string (coll)
 163   (declare (optimize (speed 3) (safety 1)))
 164   ;; return the string that's in the collection
 165   (let ((str (make-string (collector-next coll)))
 166         (from (collector-data coll)))
 167     (dotimes (i (collector-next coll))
 168       (setf (schar str i) (schar from i)))
 169
 170     str))
 171
 172 (defun grow-and-add (coll ch)
 173   (declare (optimize (speed 3) (safety 1)))
 174   ;; increase the size of the data portion of the collector and then
 175   ;; add the given char at the end
 176   (let* ((odata (collector-data coll))
 177          (ndata (make-string (* 2 (length odata)))))
 178     (dotimes (i (length odata))
 179       (setf (schar ndata i) (schar odata i)))
 180     (setf (collector-data coll) ndata)
 181     (setf (collector-max coll) (length ndata))
 182     (let ((next (collector-next coll)))
 183       (setf (schar ndata next) ch)
 184       (setf (collector-next coll) (1+ next)))))
 185
 186 (defun put-back-tokenbuf (buf)
 187   (declare (optimize (speed 3) (safety 1)))
 188   (without-scheduling
 189     (do ((bufs *tokenbufs* (cdr bufs)))
 190         ((null bufs)
 191          ; toss it away
 192          nil)
 193       (if* (null (car bufs))
 194          then (setf (car bufs) buf)
 195               (return)))))
 196
 197 (defun get-collector ()
 198   (declare (optimize (speed 3) (safety 1)))
 199   (let (col)
 200     (without-scheduling
 201       (do* ((cols *collectors* (cdr cols))
 202             (this (car cols) (car cols)))
 203           ((null cols))
 204         (if* this
 205            then (setf (car cols) nil)
 206                 (setq col this)
 207                 (return))))
 208     (if*  col
 209        then (setf (collector-next col) 0)
 210             col
 211        else (make-collector
 212              :next 0
 213              :max  100
 214              :data (make-string 100)))))
 215
 216 (defmacro next-char (tokenbuf read-sequence-func)
 217   `(let ((cur (tokenbuf-cur ,tokenbuf))
 218          (tb (tokenbuf-data ,tokenbuf)))
 219      (if* (>= cur (tokenbuf-max ,tokenbuf))
 220         then                            ;; fill buffer
 221              (if* (or (not (tokenbuf-stream ,tokenbuf))
 222                       (zerop (setf (tokenbuf-max ,tokenbuf)
 223                                (if* ,read-sequence-func
 224                                   then (funcall ,read-sequence-func tb
 225                                                 (tokenbuf-stream ,tokenbuf))
 226                                   else (read-sequence tb (tokenbuf-stream ,tokenbuf))))))
 227                 then (setq cur nil)     ;; eof
 228                 else (setq cur 0)))
 229      (if* cur
 230         then (prog1
 231                  (let ((cc (schar tb cur)))
 232                    (if (and (tokenbuf-stream ,tokenbuf) (eq #\return cc)) #\newline cc))
 233                (setf (tokenbuf-cur ,tokenbuf) (1+ cur))))))
 234
 235 (defun get-next-char (iostruct)
 236   (declare (optimize (speed 3) (safety 1)))
 237   (let* (from-stream (tmp-char
 238          (let (char)
 239            (if* (iostruct-unget-char iostruct) then
 240                    ;; from-stream is used to do input CR/LF normalization
 241                    (setf from-stream t)
 242                    (setf char (first (iostruct-unget-char iostruct)))
 243                    (setf (iostruct-unget-char iostruct) (rest (iostruct-unget-char iostruct)))
 244                    char
 245             elseif (iostruct-entity-bufs iostruct) then
 246                    (let (entity-buf)
 247                      (loop
 248                        (setf entity-buf (first (iostruct-entity-bufs iostruct)))
 249                        (if* (streamp (tokenbuf-stream entity-buf))
 250                           then (setf from-stream t)
 251                           else (setf from-stream nil))
 252                        (setf char (next-char entity-buf (iostruct-read-sequence-func iostruct)))
 253                        (when char (return))
 254                        (when (streamp (tokenbuf-stream entity-buf))
 255                          (close (tokenbuf-stream entity-buf))
 256                          (put-back-tokenbuf entity-buf))
 257                        (setf (iostruct-entity-bufs iostruct) (rest (iostruct-entity-bufs iostruct)))
 258                        (setf (iostruct-entity-names iostruct) (rest (iostruct-entity-names iostruct)))
 259                        (when (not (iostruct-entity-bufs iostruct)) (return))))
 260                    (if* char then char
 261                       else (next-char (iostruct-tokenbuf iostruct)
 262                                       (iostruct-read-sequence-func iostruct)))
 263               else (setf from-stream t)
 264                    (next-char (iostruct-tokenbuf iostruct)
 265                               (iostruct-read-sequence-func iostruct))))))
 266     (if* (and from-stream (eq tmp-char #\return)) then #\newline else tmp-char)))
 267
 268 (defun unicode-check (p tokenbuf)
 269   #-allegro (return-from unicode-check t)
 270   #+allegro
 271   (declare (ignorable tokenbuf) (optimize (speed 3) (safety 1)))
 272   ;; need no-OO check because external format support isn't completely done yet
 273   #+allegro
 274   (when (not (typep p 'string-input-simple-stream))
 275     #+allegro
 276     (let ((format (ignore-errors (excl:sniff-for-unicode p))))
 277       (if* (eq format (find-external-format :unicode))
 278          then
 279               (setf (stream-external-format p) format)
 280          else
 281               (setf (stream-external-format p) (find-external-format :utf8))))
 282     #-allegro
 283     (let* ((c (read-char p nil)) c2
 284            (c-code (if c (char-code c) nil)))
 285       (if* (eq #xFF c-code) then
 286               (setf c2 (read-char p nil))
 287               (setf c-code (if c (char-code c2) nil))
 288               (if* (eq #xFE c-code) then
 289                       (format t "set unicode~%")
 290                       (setf (stream-external-format p)
 291                         (find-external-format
 292                          #+allegro :unicode
 293                          #-allegro :fat-little))
 294                  else
 295                       (xml-error "stream has incomplete Unicode marker"))
 296          else (setf (stream-external-format p)
 297                 (find-external-format :utf8))
 298               (when c
 299                 (push c (iostruct-unget-char tokenbuf))
 300                 #+ignore (unread-char c p)  ;; bug when there is single ^M in file
 301                 )))))
 302
 303 (defun add-default-values (val attlist-data)
 304   (declare (ignorable old-coll) (optimize (speed 3) (safety 1)))
 305   (if* (symbolp val)
 306      then
 307           (let* ((tag-defaults (assoc val attlist-data)) defaults)
 308             (dolist (def (rest tag-defaults))
 309               (if* (stringp (third def)) then
 310                       (push (first def) defaults)
 311                       (push (if (eq (second def) :CDATA) (third def)
 312                               (normalize-attrib-value (third def))) defaults)
 313                elseif (and (eq (third def) :FIXED) (stringp (fourth def))) then
 314                       (push (first def) defaults)
 315                       (push (if (eq (second def) :CDATA) (fourth def)
 316                               (normalize-attrib-value (fourth def))) defaults)
 317                       ))
 318             (if* defaults then
 319                     (setf val (append (list val) (nreverse defaults)))
 320                else val)
 321             )
 322      else
 323           ;; first make sure there are no errors in given list
 324           (let ((pairs (rest val)))
 325             (loop
 326               (when (null pairs) (return))
 327               (let ((this-one (first pairs)))
 328                 (setf pairs (rest (rest pairs)))
 329                 (when (member this-one pairs)
 330                   (xml-error (concatenate 'string "Entity: "
 331                                           (string (first val))
 332                                           " has multiple "
 333                                           (string this-one)
 334                                           " attribute values"))))))
 335           (let ((tag-defaults (assoc (first val) attlist-data)) defaults)
 336             (dolist (def (rest tag-defaults))
 337               (let ((old (member (first def) (rest val))))
 338                 (if* (not old) then
 339                         (if* (stringp (third def)) then
 340                                 (push (first def) defaults)
 341                                 (push (third def) defaults)
 342                          elseif (and (eq (third def) :FIXED) (stringp (fourth def))) then
 343                                 (push (first def) defaults)
 344                                 (push (fourth def) defaults))
 345                    else
 346                         (push (first old) defaults)
 347                         (push (second old) defaults))))
 348             (if* defaults then
 349                     ;; now look for attributes in original list that weren't in dtd
 350                     (let ((tmp-val (rest val)) att att-val)
 351                       (loop
 352                         (when (null tmp-val) (return))
 353                         (setf att (first tmp-val))
 354                         (setf att-val (second tmp-val))
 355                         (setf tmp-val (rest (rest tmp-val)))
 356                         (when (not (member att defaults))
 357                           (push att defaults)
 358                           (push att-val defaults))))
 359                     (setf val (append (list (first val)) (nreverse defaults)))
 360                else val))
 361           ))
 362
 363 (defun normalize-public-value (public-value)
 364   (setf public-value (string-trim '(#\space) public-value))
 365   (let ((count 0) (stop (length public-value)) (last-ch nil) cch)
 366     (loop
 367       (when (= count stop) (return public-value))
 368       (setf cch (schar public-value count))
 369       (if* (and (eq cch #\space) (eq last-ch #\space)) then
 370               (setf public-value
 371                 (remove #\space public-value :start count :count 1))
 372               (decf stop)
 373          else (incf count)
 374               (setf last-ch cch)))))
 375
 376
 377 (defun normalize-attrib-value (attrib-value &optional first-pass)
 378   (declare (optimize (speed 3) (safety 1)))
 379   (when first-pass
 380     (let ((count 0) (stop (length attrib-value)) (last-ch nil) cch)
 381       (loop
 382         (when (= count stop) (return))
 383         (setf cch (schar attrib-value count))
 384         (if* (or (eq cch #\return) (eq cch #\tab)) then (setf (schar attrib-value count) #\space)
 385          elseif (and (eq cch #\newline) (not (eq last-ch #\return))) then
 386                 (setf (schar attrib-value count) #\space)
 387          elseif (and (eq cch #\newline) (eq last-ch #\return)) then
 388                 (setf attrib-value
 389                   (remove #\space attrib-value :start count :count 1))
 390                 (decf stop))
 391         (incf count)
 392         (setf last-ch cch))))
 393   (setf attrib-value (string-trim '(#\space) attrib-value))
 394   (let ((count 0) (stop (length attrib-value)) (last-ch nil) cch)
 395     (loop
 396       (when (= count stop) (return attrib-value))
 397       (setf cch (schar attrib-value count))
 398       (if* (and (eq cch #\space) (eq last-ch #\space)) then
 399               (setf attrib-value
 400                 (remove #\space attrib-value :start count :count 1))
 401               (decf stop)
 402          else (incf count)
 403               (setf last-ch cch)))))
 404
 405 (defun check-xmldecl (val tokenbuf)
 406   (declare (ignorable old-coll) (optimize (speed 3) (safety 1)))
 407   (when (not (and (symbolp (second val)) (string= "version" (symbol-name (second val)))))
 408     (xml-error "XML declaration tag does not include correct 'version' attribute"))
 409   (when (and (fourth val)
 410              (or (not (symbolp (fourth val)))
 411                  (and (not (string= "standalone" (symbol-name (fourth val))))
 412                       (not (string= "encoding" (symbol-name (fourth val)))))))
 413     (xml-error "XML declaration tag does not include correct 'encoding' or 'standalone' attribute"))
 414   (when (and (fourth val) (string= "standalone" (symbol-name (fourth val))))
 415     (if* (equal (fifth val) "yes") then
 416             (setf (iostruct-standalonep tokenbuf) t)
 417      elseif (not (equal (fifth val) "no")) then
 418             (xml-error "XML declaration tag does not include correct 'standalone' attribute value")))
 419   (dotimes (i (length (third val)))
 420     (let ((c (schar (third val) i)))
 421       (when (and (not (alpha-char-p c))
 422                  (not (digit-char-p c))
 423                  (not (member c '(#\. #\_ #\- #\:)))
 424                  )
 425         (xml-error "XML declaration tag does not include correct 'version' attribute value"))))
 426   (if* (and (fourth val) (eql :encoding (fourth val)))
 427      then (dotimes (i (length (fifth val)))
 428             (let ((c (schar (fifth val) i)))
 429               (when (and (not (alpha-char-p c))
 430                          (if* (> i 0) then
 431                                  (and (not (digit-char-p c))
 432                                       (not (member c '(#\. #\_ #\-))))
 433                             else t))
 434                 (xml-error "XML declaration tag does not include correct 'encoding' attribute value"))))
 435           ;; jkf 3/26/02
 436           ;; if we have a stream we're reading from set its external-format
 437           ;; to the encoding
 438           ;; note - tokenbuf is really an iostruct, not a tokenbuf
 439      #+allegro
 440           (if* (tokenbuf-stream (iostruct-tokenbuf tokenbuf))
 441              then (setf (stream-external-format
 442                          (tokenbuf-stream (iostruct-tokenbuf tokenbuf)))
 443                     (find-external-format (fifth val))))
 444
 445
 446           ))
 447
 448 (defun xml-error (text)
 449   (declare (optimize (speed 3) (safety 1)))
 450   (funcall 'error "~a" (concatenate 'string "XML not well-formed - " text)))