src/xml/dom-impl.lisp

   1 (defpackage :dom-impl
   2   (:use :glisp))
   3
   4 (in-package :dom-impl)
   5
   6 ;; Classes
   7
   8 (defclass node ()
   9   ((parent      :initarg :parent        :initform nil)
  10    (children    :initarg :children      :initform nil)
  11    (owner       :initarg :owner         :initform nil)))
  12
  13 (defclass document (node)
  14   ((doc-type    :initarg :doc-type     :reader dom:doctype)))
  15
  16 (defclass document-fragment (node)
  17   ())
  18
  19 (defclass character-data (node)
  20   ((data        :initarg :data          :reader dom:data)))
  21
  22 (defclass attribute (node)
  23   ((name        :initarg :name          :reader dom:name)
  24    (value       :initarg :value         :reader dom:value)
  25    (specified-p :initarg :specified-p   :reader dom:specified)))
  26
  27 (defclass element (node)
  28   ((tag-name    :initarg :tag-name      :reader dom:tag-name)
  29    (attributes  :initarg :attributes    :reader dom:attributes
  30                 :initform (make-instance 'named-node-map))))
  31
  32 (defclass text (character-data)
  33   ())
  34
  35 (defclass comment (character-data)
  36   ())
  37
  38 (defclass cdata-section (text)
  39   ())
  40
  41 (defclass document-type (node)
  42   ((name          :initarg :name          :reader dom:name)
  43    (entities      :initarg :entities      :reader dom:entities)
  44    (notations     :initarg :notations     :reader dom:notations)))
  45
  46 (defclass notation (node)
  47   ((name          :initarg :name          :reader dom:name)
  48    (public-id     :initarg :public-id     :reader dom:public-id)
  49    (system-id     :initarg :system-id     :reader dom:system-id)))
  50
  51 (defclass entity (node)
  52   ((name          :initarg :name          :reader dom:name)
  53    (public-id     :initarg :public-id     :reader dom:public-id)
  54    (system-id     :initarg :system-id     :reader dom:system-id)
  55    (notation-name :initarg :notation-name :reader dom:notation-name)))
  56
  57 (defclass entity-reference (node)
  58   ((name          :initarg :name          :reader dom:name)))
  59
  60 (defclass processing-instruction (node)
  61   ((target        :initarg :target        :reader dom:target)
  62    (data          :initarg :data          :reader dom:data)))
  63
  64 (defclass named-node-map ()
  65   ((items         :initarg :items         :reader dom:items
  66                   :initform nil) ))
  67
  68
  69 ;;; Implementation
  70
  71 ;; document-fragment protocol
  72 ;; document protocol
  73
  74 (defmethod dom:implementation ((document document))
  75   'implementation)
  76
  77 (defmethod dom:document-element ((document document))
  78   (dolist (k (dom:child-nodes document))
  79     (cond ((typep k 'element)
  80            (return k)))))
  81
  82 (defmethod dom:create-element ((document document) tag-name)
  83   (setf tag-name (rod tag-name))
  84   (make-instance 'element
  85     :tag-name tag-name
  86     :owner document))
  87
  88 (defmethod dom:create-document-fragment ((document document))
  89   (make-instance 'document-fragment
  90     :owner document))
  91
  92 (defmethod dom:create-text-node ((document document) data)
  93   (setf data (rod data))
  94   (make-instance 'text
  95     :data data
  96     :owner document))
  97
  98 (defmethod dom:create-comment ((document document) data)
  99   (setf data (rod data))
 100   (make-instance 'comment
 101     :data data
 102     :owner document))
 103
 104 (defmethod dom:create-cdata-section ((document document) data)
 105   (setf data (rod data))
 106   (make-instance 'cdata-section
 107     :data data
 108     :owner document))
 109
 110 (defmethod dom:create-processing-instruction ((document document) target data)
 111   (setf target (rod target))
 112   (setf data (rod data))
 113   (make-instance 'processing-instruction
 114     :owner document
 115     :target target
 116     :data data))
 117
 118 (defmethod dom:create-attribute ((document document) name)
 119   (setf name (rod name))
 120   (make-instance 'attribute
 121     :name name
 122     :specified-p nil                    ;???
 123     :owner document))
 124
 125 (defmethod dom:create-entity-reference ((document document) name)
 126   (setf name (rod name))
 127   (make-instance 'entity-reference
 128     :name name
 129     :owner document))
 130
 131 (defmethod dom:get-elements-by-tag-name ((document document) tag-name)
 132   (setf tag-name (rod tag-name))
 133   (let ((result nil))
 134     (setf tag-name (rod tag-name))
 135     (let ((wild-p (rod= tag-name '#.(string-rod "*"))))
 136       (labels ((walk (n)
 137                  (when (and (dom:element-p n)
 138                             (or wild-p (tag-name-eq tag-name (dom:node-name n))))
 139                    (push n result))
 140                  (mapc #'walk (dom:child-nodes n))))
 141         (walk document)
 142         (reverse result)))))
 143
 144 ;;; Node
 145
 146 (defmethod dom:parent-node ((node node))
 147   (slot-value node 'parent))
 148
 149 (defmethod dom:child-nodes ((node node))
 150   (slot-value node 'children))
 151
 152 (defmethod dom:first-child ((node node))
 153   (car (slot-value node 'children)))
 154
 155 (defmethod dom:last-child ((node node))
 156   (car (last (slot-value node 'children))))
 157
 158 (defmethod dom:previous-sibling ((node node))
 159   (with-slots (parent) node
 160     (when parent
 161       (with-slots (children) parent
 162         (do ((q children (cdr q)))
 163             ((null (cdr q)) niL)
 164           (cond ((eq (cadr q) node)
 165                  (return (car q)))))))))
 166
 167 (defmethod dom:next-sibling ((node node))
 168   (with-slots (parent) node
 169     (when parent
 170       (with-slots (children) parent
 171         (do ((q children (cdr q)))
 172             ((null (cdr q)) niL)
 173           (cond ((eq (car q) node)
 174                  (return (cadr q)))))))))
 175
 176 (defmethod dom:owner-document ((node node))
 177   (slot-value node 'owner))
 178
 179 (defun ensure-valid-insertion-request (node new-child)
 180   (unless (can-adopt-p node new-child)
 181     ;; HIERARCHY_REQUEST_ERR
 182     (error "~S cannot adopt ~S." node new-child))
 183   (unless (eq (dom:owner-document node)
 184               (dom:owner-document new-child))
 185     ;; WRONG_DOCUMENT_ERR
 186     (error "~S cannot adopt ~S, since it was created by a different document."
 187            node new-child))
 188   (with-slots (children) node
 189     (unless (null (slot-value new-child 'parent))
 190       (cond ((eq (slot-value new-child 'parent)
 191                  node)
 192              ;; remove it first
 193              (setf children (delete new-child children)))
 194             (t
 195              ;; otherwise it is an error.
 196              ;; GB_INTEGRITY_ERR
 197              (error "~S is already adopted." new-child)))) ))
 198
 199 (defmethod dom:insert-before ((node node) (new-child node) (ref-child t))
 200   (ensure-valid-insertion-request node new-child)
 201   (with-slots (children) node
 202     (cond ((eq (car children) ref-child)
 203            (setf (slot-value new-child 'parent) node)
 204            (setf children (cons new-child children)))
 205           (t
 206            (do ((q children (cdr q)))
 207                ((null (cdr q))
 208                 (cond ((null ref-child)
 209                        (setf (slot-value new-child 'parent) node)
 210                        (setf (cdr q) (cons new-child nil)))
 211                       (t
 212                        ;; NOT_FOUND_ERR
 213                        (error "~S is no child of ~S." ref-child node))))
 214              (cond ((eq (cadr q) ref-child)
 215                     (setf (slot-value new-child 'parent) node)
 216                     (setf (cdr q) (cons new-child (cdr q)))
 217                     (return))))))
 218     new-child))
 219
 220 (defmethod dom:insert-before ((node node) (fragment document-fragment) ref-child)
 221   (dolist (child (dom:child-nodes fragment))
 222     (dom:insert-before node child ref-child))
 223   fragment)
 224
 225 (defmethod dom:replace-child ((node node) (new-child node) (old-child node))
 226   (ensure-valid-insertion-request node new-child)
 227   (with-slots (children) node
 228     (do ((q children (cdr q)))
 229         ((null q)
 230          ;; NOT_FOUND_ERR
 231          (error "~S is no child of ~S." old-child node))
 232       (cond ((eq (car q) old-child)
 233              (setf (car q) new-child)
 234              (setf (slot-value new-child 'parent) node)
 235              (setf (slot-value old-child 'parent) nil)
 236              (return))))
 237     old-child))
 238
 239 (defmethod dom:append-child ((node node) (new-child node))
 240   (ensure-valid-insertion-request node new-child)
 241   (with-slots (children) node
 242     (setf children (nconc children (list new-child)))
 243     (setf (slot-value new-child 'parent) node)
 244     new-child))
 245
 246 (defmethod dom:has-child-nodes ((node node))
 247   (not (null (slot-value node 'children))))
 248
 249 (defmethod dom:append-child ((node node) (new-child document-fragment))
 250   (dolist (child (dom:child-nodes new-child))
 251     (dom:append-child node child))
 252   new-child)
 253
 254 ;; was auf node noch implemetiert werden muss:
 255 ;; - node-type
 256 ;; - can-adopt-p
 257 ;; - ggf attributes
 258 ;; - node-name
 259 ;; - node-value
 260
 261 ;; node-name
 262
 263 (defmethod dom:node-name ((self document))
 264   '#.(string-rod "#document"))
 265
 266 (defmethod dom:node-name ((self document-fragment))
 267   '#.(string-rod "#document-fragment"))
 268
 269 (defmethod dom:node-name ((self text))
 270   '#.(string-rod "#text"))
 271
 272 (defmethod dom:node-name ((self cdata-section))
 273   '#.(string-rod "#cdata-section"))
 274
 275 (defmethod dom:node-name ((self comment))
 276   '#.(string-rod "#comment"))
 277
 278 (defmethod dom:node-name ((self attribute))
 279   (dom:name self))
 280
 281 (defmethod dom:node-name ((self element))
 282   (dom:tag-name self))
 283
 284 (defmethod dom:node-name ((self document-type))
 285   (dom:name self))
 286
 287 (defmethod dom:node-name ((self notation))
 288   (dom:name self))
 289
 290 (defmethod dom:node-name ((self entity))
 291   (dom:name self))
 292
 293 (defmethod dom:node-name ((self entity-reference))
 294   (dom:name self))
 295
 296 (defmethod dom:node-name ((self processing-instruction))
 297   (dom:target self))
 298
 299 ;; node-type
 300
 301 (defmethod dom:node-type ((self document)) :document)
 302 (defmethod dom:node-type ((self document-fragment)) :document-fragment)
 303 (defmethod dom:node-type ((self text)) :text)
 304 (defmethod dom:node-type ((self comment)) :comment)
 305 (defmethod dom:node-type ((self cdata-section)) :cdata-section)
 306 (defmethod dom:node-type ((self attribute)) :attribute)
 307 (defmethod dom:node-type ((self element)) :element)
 308 (defmethod dom:node-type ((self document-type)) :document-type)
 309 (defmethod dom:node-type ((self notation)) :notation)
 310 (defmethod dom:node-type ((self entity)) :entity)
 311 (defmethod dom:node-type ((self entity-reference)) :entity-reference)
 312 (defmethod dom:node-type ((self processing-instruction)) :processing-instruction)
 313
 314 ;; node-value
 315
 316 (defmethod dom:node-value ((self document)) nil)
 317 (defmethod dom:node-value ((self document-fragment)) nil)
 318 (defmethod dom:node-value ((self character-data)) (dom:data self))
 319 (defmethod dom:node-value ((self attribute)) (dom:name self))
 320 (defmethod dom:node-value ((self element)) nil)
 321 (defmethod dom:node-value ((self document-type)) nil)
 322 (defmethod dom:node-value ((self notation)) nil)
 323 (defmethod dom:node-value ((self entity)) nil)
 324 (defmethod dom:node-value ((self entity-reference)) nil)
 325 (defmethod dom:node-value ((self processing-instruction)) (dom:data self))
 326
 327 ;; attributes
 328
 329 ;; (gibt es nur auf element)
 330
 331 (defmethod dom:attributes ((self node))
 332   nil)
 333
 334 ;; dann fehlt noch can-adopt und attribute conventions fuer adoption
 335
 336 ;;; NAMED-NODE-MAP
 337
 338 (defmethod dom:get-named-item ((self named-node-map) name)
 339   (setf name (rod name))
 340   (with-slots (items) self
 341     (dolist (k items nil)
 342       (cond ((rod= name (dom:node-name k))
 343              (return k))))))
 344
 345 (defmethod dom:set-named-item ((self named-node-map) arg)
 346   (let ((name (dom:node-name arg)))
 347     (with-slots (items) self
 348       (dolist (k items (progn (setf items (cons arg items))nil))
 349         (cond ((rod= name (dom:node-name k))
 350                (setf items (cons arg (delete k items)))
 351                (return k)))))))
 352
 353 (defmethod dom:remove-named-item ((self named-node-map) name)
 354   (setf name (rod name))
 355   (with-slots (items) self
 356     (dolist (k items nil)
 357       (cond ((rod= name (dom:node-name k))
 358              (setf items (delete k items))
 359              (return k))))))
 360
 361 (defmethod dom:length ((self named-node-map))
 362   (with-slots (items) self
 363     (length items)))
 364
 365 (defmethod dom:item ((self named-node-map) index)
 366   (with-slots (items) self
 367     (elt items index)))
 368
 369 ;;; CHARACTER-DATA
 370
 371 (defmethod dom:length ((node character-data))
 372   (length (slot-value node 'value)))
 373
 374 (defmethod dom:substring-data ((node character-data) offset count)
 375   (subseq (slot-value node 'value) offset (+ offset count)))
 376
 377 (defmethod dom:append-data ((node character-data) arg)
 378   (setq arg (rod arg))
 379   (with-slots (value) node
 380     (setf value (concatenate (type-of value) value arg)))
 381   (values))
 382
 383 (defmethod dom:delete-data ((node character-data) offset count)
 384   (with-slots (value) node
 385     (let ((new (make-array (- (length value) count) :element-type (type-of value))))
 386       (replace new value
 387                :start1 0 :end1 offset
 388                :start2 0 :end2 offset)
 389       (replace new value
 390                :start1 offset :end1 (length new)
 391                :start2 (+ offset count) :end2 (length value))
 392       (setf value new)))
 393   (values))
 394
 395 (defmethod dom:replace-data ((node character-data) offset count arg)
 396   (setf arg (rod arg))
 397   (with-slots (value) node
 398     (replace value arg
 399              :start1 offset :end1 (+ offset count)
 400              :start2 0 :end2 count))
 401   (values))
 402
 403 ;;; ATTR
 404
 405 ;; hmm... value muss noch entities lesen und text-nodes in die hierarchie hängen.
 406
 407 (defmethod (setf dom:value) (new-value (node attribute))
 408   (setf (slot-value node 'value) (rod new-value)))
 409
 410 ;;; ELEMENT
 411
 412 (defmethod dom:get-attribute-node ((element element) name)
 413   (dom:get-named-item (dom:attributes element) name))
 414
 415 (defmethod dom:set-attribute-node ((element element) (new-attr attribute))
 416   (dom:set-named-item (dom:attributes element) new-attr))
 417
 418 (defmethod dom:get-attribute ((element element) name)
 419   (let ((a (dom:get-attribute-node element name)))
 420     (if a
 421         (dom:value a)
 422       nil)))
 423
 424 (defmethod dom:set-attribute ((element element) name value)
 425   (with-slots (owner) element
 426     (dom:set-attribute-node
 427      element (make-instance 'attribute
 428                :owner owner
 429                :name name
 430                :value value
 431                :specified-p t))
 432     (values)))
 433
 434 (defmethod dom:remove-attribute-node ((element element) (old-attr attribute))
 435   (let ((res (dom:remove-named-item element (dom:name old-attr))))
 436     (if res
 437         res
 438       ;; NOT_FOUND_ERR
 439       (error "Attribute not found."))))
 440
 441 (defmethod dom:get-elements-by-tag-name ((element element) name)
 442   name
 443   (error "Not implemented."))
 444
 445 (defmethod dom:normalize ((element element))
 446   (error "Not implemented.") )
 447
 448 ;;; TEXT
 449
 450 (defmethod dom:split-text ((text text) offset)
 451   offset
 452   (error "Not implemented."))
 453
 454 ;;; COMMENT -- nix
 455 ;;; CDATA-SECTION -- nix
 456
 457 ;;; DOCUMENT-TYPE -- missing
 458 ;;; NOTATION -- nix
 459 ;;; ENTITY -- nix
 460 ;;; ENTITY-REFERENCE -- nix
 461 ;;; PROCESSING-INSTRUCTION -- nix
 462
 463 ;; Notbehelf!
 464 (defun can-adopt-p (x y) x y t)
 465
 466
 467 ;;; predicates
 468
 469 (defmethod dom:node-p ((object node)) t)
 470 (defmethod dom:node-p ((object t)) nil)
 471
 472 (defmethod dom:document-p ((object document)) t)
 473 (defmethod dom:document-p ((object t)) nil)
 474
 475 (defmethod dom:document-fragment-p ((object document-fragment)) t)
 476 (defmethod dom:document-fragment-p ((object t)) nil)
 477
 478 (defmethod dom:character-data-p ((object character-data)) t)
 479 (defmethod dom:character-data-p ((object t)) nil)
 480
 481 (defmethod dom:attribute-p ((object attribute)) t)
 482 (defmethod dom:attribute-p ((object t)) nil)
 483
 484 (defmethod dom:element-p ((object element)) t)
 485 (defmethod dom:element-p ((object t)) nil)
 486
 487 (defmethod dom:text-node-p ((object text)) t)
 488 (defmethod dom:text-node-p ((object t)) nil)
 489
 490 (defmethod dom:comment-p ((object comment)) t)
 491 (defmethod dom:comment-p ((object t)) nil)
 492
 493 (defmethod dom:cdata-section-p ((object cdata-section)) t)
 494 (defmethod dom:cdata-section-p ((object t)) nil)
 495
 496 (defmethod dom:document-type-p ((object document-type)) t)
 497 (defmethod dom:document-type-p ((object t)) nil)
 498
 499 (defmethod dom:notation-p ((object notation)) t)
 500 (defmethod dom:notation-p ((object t)) nil)
 501
 502 (defmethod dom:entity-p ((object entity)) t)
 503 (defmethod dom:entity-p ((object t)) nil)
 504
 505 (defmethod dom:entity-reference-p ((object entity-reference)) t)
 506 (defmethod dom:entity-reference-p ((object t)) nil)
 507
 508 (defmethod dom:processing-instruction-p ((object processing-instruction)) t)
 509 (defmethod dom:processing-instruction-p ((object t)) nil)
 510
 511 (defmethod dom:named-node-map-p ((object named-node-map)) t)
 512 (defmethod dom:named-node-map-p ((object t)) nil)