dom/dom-builder.lisp

   1 ;;;; dom-builder.lisp -- DOM-building SAX handler
   2 ;;;;
   3 ;;;; This file is part of the CXML parser, released under Lisp-LGPL.
   4 ;;;; See file COPYING for details.
   5 ;;;;
   6 ;;;; Author: Gilbert Baumann <unk6@rz.uni-karlsruhe.de>
   7 ;;;; Author: Henrik Motakef <hmot@henrik-motakef.de>
   8 ;;;; Author: David Lichteblau <david@lichteblau.com>
   9 ;;;; Author: knowledgeTools Int. GmbH
  10
  11 #-cxml-system::utf8dom-file
  12 (in-package :rune-dom)
  13
  14 #+cxml-system::utf8dom-file
  15 (in-package :utf8-dom)
  16
  17
  18 (defclass dom-builder (sax:content-handler)
  19   ((document      :initform nil :accessor document)
  20    (element-stack :initform '() :accessor element-stack)
  21    (internal-subset             :accessor internal-subset)
  22    (text-buffer   :initform nil :accessor text-buffer)))
  23
  24 #+(and rune-is-integer (not cxml-system::utf8dom-file))
  25 (defmethod hax:%want-strings-p ((handler dom-builder))
  26   nil)
  27
  28 (defun make-dom-builder ()
  29   (make-instance 'dom-builder))
  30
  31 (defun fast-push (new-element vector)
  32   (vector-push-extend new-element vector (max 1 (array-dimension vector 0))))
  33
  34 (defmethod sax:start-document ((handler dom-builder))
  35   (when (and sax:*namespace-processing*
  36              (not (and sax:*include-xmlns-attributes*
  37                        sax:*use-xmlns-namespace*)))
  38     (error "SAX configuration is incompatible with DOM: *namespace-processing* is activated, but *include-xmlns-attributes* or *use-xmlns-namespace* are not"))
  39   (let ((document (make-instance 'document)))
  40     (setf (slot-value document 'owner) nil
  41           (slot-value document 'doc-type) nil)
  42     (setf (document handler) document)
  43     (push document (element-stack handler))))
  44
  45 ;; fixme
  46 (defmethod sax::dtd ((handler dom-builder) dtd)
  47   (setf (slot-value (document handler) 'dtd) dtd))
  48
  49 (defmethod sax:end-document ((handler dom-builder))
  50   (let ((doctype (dom:doctype (document handler))))
  51     (when doctype
  52       (setf (slot-value (dom:entities doctype) 'read-only-p) t)
  53       (setf (slot-value (dom:notations doctype) 'read-only-p) t)))
  54   (document handler))
  55
  56 (defmethod sax:entity-resolver ((handler dom-builder) resolver)
  57   (setf (slot-value (document handler) 'entity-resolver) resolver))
  58
  59 (defmethod sax:start-dtd ((handler dom-builder) name publicid systemid)
  60   (let* ((document (document handler))
  61          (doctype (%create-document-type name publicid systemid)))
  62     (setf (slot-value doctype 'owner) document
  63           (slot-value (dom:notations doctype) 'owner) document
  64           (slot-value (dom:entities doctype) 'owner) document
  65           (slot-value document 'doc-type) doctype)))
  66
  67 (defmethod sax:start-internal-subset ((handler dom-builder))
  68   (setf (internal-subset handler) nil))
  69
  70 (defmethod sax:end-internal-subset ((handler dom-builder))
  71   (setf (dom::%internal-subset (slot-value (document handler) 'doc-type))
  72         (nreverse (internal-subset handler)))
  73   (slot-makunbound handler 'internal-subset))
  74
  75 (macrolet ((defhandler (name &rest args)
  76              `(defmethod ,name ((handler dom-builder) ,@args)
  77                 (when (slot-boundp handler 'internal-subset)
  78                   (push (list ',name ,@args) (internal-subset handler))))))
  79   (defhandler sax:unparsed-entity-declaration
  80       name public-id system-id notation-name)
  81   (defhandler sax:external-entity-declaration
  82       kind name public-id system-id)
  83   (defhandler sax:internal-entity-declaration
  84       kind name value)
  85   (defhandler sax:notation-declaration
  86       name public-id system-id)
  87   (defhandler sax:element-declaration
  88       name model)
  89   (defhandler sax:attribute-declaration
  90       element-name attribute-name type default))
  91
  92 (defmethod sax:start-element
  93     ((handler dom-builder) namespace-uri local-name qname attributes)
  94   (check-type qname rod)                ;catch recoder/builder mismatch
  95   (flush-characters handler)
  96   (with-slots (document element-stack) handler
  97     (let* ((nsp sax:*namespace-processing*)
  98            (element (make-instance 'element
  99                      :tag-name qname
 100                      :owner document
 101                      :namespace-uri (when nsp namespace-uri)
 102                      :local-name (when nsp local-name)
 103                      :prefix (%rod (when nsp (cxml::split-qname (real-rod qname))))))
 104           (parent (car element-stack))
 105           (anodes '()))
 106       (dolist (attr attributes)
 107         (let ((anode
 108                (if nsp
 109                    (dom:create-attribute-ns document
 110                                             (sax:attribute-namespace-uri attr)
 111                                             (sax:attribute-qname attr))
 112                    (dom:create-attribute document (sax:attribute-qname attr))))
 113               (text
 114                (dom:create-text-node document (sax:attribute-value attr))))
 115           (setf (slot-value anode 'specified-p)
 116                 (sax:attribute-specified-p attr))
 117           (setf (slot-value anode 'owner-element) element)
 118           (dom:append-child anode text)
 119           (push anode anodes)))
 120       (setf (slot-value element 'parent) parent)
 121       (fast-push element (slot-value parent 'children))
 122       (let ((map
 123               (make-instance 'attribute-node-map
 124                 :items anodes
 125                 :element-type :attribute
 126                 :element element
 127                 :owner document)))
 128         (setf (slot-value element 'attributes) map)
 129         (dolist (anode anodes)
 130           (setf (slot-value anode 'map) map)))
 131       (push element element-stack))))
 132
 133 (defmethod sax:end-element ((handler dom-builder) namespace-uri local-name qname)
 134   (declare (ignore namespace-uri local-name qname))
 135   (flush-characters handler)
 136   (pop (element-stack handler)))
 137
 138 (defmethod sax:characters ((handler dom-builder) data)
 139   (with-slots (text-buffer) handler
 140     (cond
 141       ((null text-buffer)
 142        (setf text-buffer data))
 143       (t
 144        (unless (array-has-fill-pointer-p text-buffer)
 145          (setf text-buffer (make-array (length text-buffer)
 146                                        :element-type 'rune
 147                                        :adjustable t
 148                                        :fill-pointer t
 149                                        :initial-contents text-buffer)))
 150        (let ((n (length text-buffer))
 151              (m (length data)))
 152          (adjust-vector-exponentially text-buffer (+ n m) t)
 153          (move data text-buffer 0 n m))))))
 154
 155 (defun flush-characters (handler)
 156   (with-slots (document element-stack text-buffer) handler
 157     (let ((data text-buffer))
 158       (when data
 159         (when (array-has-fill-pointer-p data)
 160           (setf data
 161                 (make-array (length data)
 162                             :element-type 'rune
 163                             :initial-contents data)))
 164         (let ((parent (car element-stack)))
 165           (if (eq (dom:node-type parent) :cdata-section)
 166               (setf (dom:data parent) data)
 167               (let ((node (dom:create-text-node document data)))
 168                 (setf (slot-value node 'parent) parent)
 169                 (fast-push node (slot-value (car element-stack) 'children)))))
 170         (setf text-buffer nil)))))
 171
 172 (defmethod sax:start-cdata ((handler dom-builder))
 173   (flush-characters handler)
 174   (with-slots (document element-stack) handler
 175     (let ((node (dom:create-cdata-section document #""))
 176           (parent (car element-stack)))
 177       (setf (slot-value node 'parent) parent)
 178       (fast-push node (slot-value parent 'children))
 179       (push node element-stack))))
 180
 181 (defmethod sax:end-cdata ((handler dom-builder))
 182   (flush-characters handler)
 183   (let ((node (pop (slot-value handler 'element-stack))))
 184     (assert (eq (dom:node-type node) :cdata-section))))
 185
 186 (defmethod sax:processing-instruction ((handler dom-builder) target data)
 187   (flush-characters handler)
 188   (with-slots (document element-stack) handler
 189     (let ((node (dom:create-processing-instruction document target data))
 190           (parent (car element-stack)))
 191       (setf (slot-value node 'parent) parent)
 192       (fast-push node (slot-value (car element-stack) 'children)))))
 193
 194 (defmethod sax:comment ((handler dom-builder) data)
 195   (flush-characters handler)
 196   (with-slots (document element-stack) handler
 197     (let ((node (dom:create-comment document data))
 198           (parent (car element-stack)))
 199       (setf (slot-value node 'parent) parent)
 200       (fast-push node (slot-value (car element-stack) 'children)))))
 201
 202 (defmethod sax:unparsed-entity-declaration
 203     ((handler dom-builder) name public-id system-id notation-name)
 204   (set-entity handler name public-id system-id notation-name))
 205
 206 (defmethod sax:external-entity-declaration
 207     ((handler dom-builder) kind name public-id system-id)
 208   (ecase kind
 209     (:general (set-entity handler name public-id system-id nil))
 210     (:parameter)))
 211
 212 (defmethod sax:internal-entity-declaration
 213     ((handler dom-builder) kind name value)
 214   (declare (ignore value))
 215   (ecase kind
 216     (:general (set-entity handler name nil nil nil))
 217     (:parameter)))
 218
 219 (defun set-entity (handler name pid sid notation)
 220   (dom:set-named-item (dom:entities (dom:doctype (document handler)))
 221                       (make-instance 'entity
 222                         :owner (document handler)
 223                         :name name
 224                         :public-id pid
 225                         :system-id sid
 226                         :notation-name notation)))
 227
 228 (defmethod sax:notation-declaration
 229     ((handler dom-builder) name public-id system-id)
 230   (dom:set-named-item (dom:notations (dom:doctype (document handler)))
 231                       (make-instance 'notation
 232                         :owner (document handler)
 233                         :name name
 234                         :public-id public-id
 235                         :system-id system-id)))