(defpackage :dom-impl (:use :glisp) (:alias (:cdom :dom))) (in-package :dom-impl) ;; Classes (defclass node () ((parent :initarg :parent :initform nil) (children :initarg :children :initform nil) (owner :initarg :owner :initform nil))) (defclass document (node) ((doc-type :initarg :doc-type :reader dom:doctype))) (defclass document-fragment (node) ()) (defclass character-data (node) ((data :initarg :data :reader dom:data))) (defclass attribute (node) ((name :initarg :name :reader dom:name) (value :initarg :value :reader dom:value) (specified-p :initarg :specified-p :reader dom:specified))) (defclass element (node) ((tag-name :initarg :tag-name :reader dom:tag-name) (attributes :initarg :attributes :reader dom:attributes :initform (make-instance 'named-node-map)))) (defclass text (character-data) ()) (defclass comment (character-data) ()) (defclass cdata-section (text) ()) (defclass document-type (node) ((name :initarg :name :reader dom:name) (entities :initarg :entities :reader dom:entities) (notations :initarg :notations :reader dom:notations))) (defclass notation (node) ((name :initarg :name :reader dom:name) (public-id :initarg :public-id :reader dom:public-id) (system-id :initarg :system-id :reader dom:system-id))) (defclass entity (node) ((name :initarg :name :reader dom:name) (public-id :initarg :public-id :reader dom:public-id) (system-id :initarg :system-id :reader dom:system-id) (notation-name :initarg :notation-name :reader dom:notation-name))) (defclass entity-reference (node) ((name :initarg :name :reader dom:name))) (defclass processing-instruction (node) ((target :initarg :target :reader dom:target) (data :initarg :data :reader dom:data))) (defclass named-node-map () ((items :initarg :items :reader dom:items :initform nil) )) ;;; Implementation ;; document-fragment protocol ;; document protocol (defmethod dom:implementation ((document document)) 'implementation) (defmethod dom:document-element ((document document)) (dolist (k (dom:child-nodes document)) (cond ((typep k 'element) (return k))))) (defmethod dom:create-element ((document document) tag-name) (setf tag-name (rod tag-name)) (make-instance 'element :tag-name tag-name :owner document)) (defmethod dom:create-document-fragment ((document document)) (make-instance 'document-fragment :owner document)) (defmethod dom:create-text-node ((document document) data) (setf data (rod data)) (make-instance 'text :data data :owner document)) (defmethod dom:create-comment ((document document) data) (setf data (rod data)) (make-instance 'comment :data data :owner document)) (defmethod dom:create-cdata-section ((document document) data) (setf data (rod data)) (make-instance 'cdata-section :data data :owner document)) (defmethod dom:create-processing-instruction ((document document) target data) (setf target (rod target)) (setf data (rod data)) (make-instance 'processing-instruction :owner document :target target :data data)) (defmethod dom:create-attribute ((document document) name) (setf name (rod name)) (make-instance 'attribute :name name :specified-p nil ;??? :owner document)) (defmethod dom:create-entity-reference ((document document) name) (setf name (rod name)) (make-instance 'entity-reference :name name :owner document)) (defmethod dom:get-elements-by-tag-name ((document document) tag-name) (setf tag-name (rod tag-name)) (let ((result nil)) (setf tag-name (rod tag-name)) (let ((wild-p (rod= tag-name '#.(string-rod "*")))) (labels ((tag-name-eq (a b) ;; XXX ist das richtig? TAG-NAME-EQ war undefiniert (rod= a b)) (walk (n) (when (and (dom:element-p n) (or wild-p (tag-name-eq tag-name (dom:node-name n)))) (push n result)) (mapc #'walk (dom:child-nodes n)))) (walk document) (reverse result))))) ;;; Node (defmethod dom:parent-node ((node node)) (slot-value node 'parent)) (defmethod dom:child-nodes ((node node)) (slot-value node 'children)) (defmethod dom:first-child ((node node)) (car (slot-value node 'children))) (defmethod dom:last-child ((node node)) (car (last (slot-value node 'children)))) (defmethod dom:previous-sibling ((node node)) (with-slots (parent) node (when parent (with-slots (children) parent (do ((q children (cdr q))) ((null (cdr q)) nil) (cond ((eq (cadr q) node) (return (car q))))))))) (defmethod dom:next-sibling ((node node)) (with-slots (parent) node (when parent (with-slots (children) parent (do ((q children (cdr q))) ((null (cdr q)) nil) (cond ((eq (car q) node) (return (cadr q))))))))) (defmethod dom:owner-document ((node node)) (slot-value node 'owner)) (defun ensure-valid-insertion-request (node new-child) (unless (can-adopt-p node new-child) ;; HIERARCHY_REQUEST_ERR (error "~S cannot adopt ~S." node new-child)) (unless (eq (dom:owner-document node) (dom:owner-document new-child)) ;; WRONG_DOCUMENT_ERR (error "~S cannot adopt ~S, since it was created by a different document." node new-child)) (with-slots (children) node (unless (null (slot-value new-child 'parent)) (cond ((eq (slot-value new-child 'parent) node) ;; remove it first (setf children (delete new-child children))) (t ;; otherwise it is an error. ;; GB_INTEGRITY_ERR (error "~S is already adopted." new-child)))) )) (defmethod dom:insert-before ((node node) (new-child node) (ref-child t)) (ensure-valid-insertion-request node new-child) (with-slots (children) node (cond ((eq (car children) ref-child) (setf (slot-value new-child 'parent) node) (setf children (cons new-child children))) (t (do ((q children (cdr q))) ((null (cdr q)) (cond ((null ref-child) (setf (slot-value new-child 'parent) node) (setf (cdr q) (cons new-child nil))) (t ;; NOT_FOUND_ERR (error "~S is no child of ~S." ref-child node)))) (cond ((eq (cadr q) ref-child) (setf (slot-value new-child 'parent) node) (setf (cdr q) (cons new-child (cdr q))) (return)))))) new-child)) (defmethod dom:insert-before ((node node) (fragment document-fragment) ref-child) (dolist (child (dom:child-nodes fragment)) (dom:insert-before node child ref-child)) fragment) (defmethod dom:replace-child ((node node) (new-child node) (old-child node)) (ensure-valid-insertion-request node new-child) (with-slots (children) node (do ((q children (cdr q))) ((null q) ;; NOT_FOUND_ERR (error "~S is no child of ~S." old-child node)) (cond ((eq (car q) old-child) (setf (car q) new-child) (setf (slot-value new-child 'parent) node) (setf (slot-value old-child 'parent) nil) (return)))) old-child)) (defmethod dom:remove-child ((node node) (old-child node)) (with-slots (children) node (setf children (remove old-child children)) (setf (slot-value old-child 'parent) nil) old-child)) (defmethod dom:append-child ((node node) (new-child node)) (ensure-valid-insertion-request node new-child) (with-slots (children) node (setf children (nconc children (list new-child))) (setf (slot-value new-child 'parent) node) new-child)) (defmethod dom:has-child-nodes ((node node)) (not (null (slot-value node 'children)))) (defmethod dom:append-child ((node node) (new-child document-fragment)) (dolist (child (dom:child-nodes new-child)) (dom:append-child node child)) new-child) ;; was auf node noch implemetiert werden muss: ;; - node-type ;; - can-adopt-p ;; - ggf attributes ;; - node-name ;; - node-value ;; node-name (defmethod dom:node-name ((self document)) '#.(string-rod "#document")) (defmethod dom:node-name ((self document-fragment)) '#.(string-rod "#document-fragment")) (defmethod dom:node-name ((self text)) '#.(string-rod "#text")) (defmethod dom:node-name ((self cdata-section)) '#.(string-rod "#cdata-section")) (defmethod dom:node-name ((self comment)) '#.(string-rod "#comment")) (defmethod dom:node-name ((self attribute)) (dom:name self)) (defmethod dom:node-name ((self element)) (dom:tag-name self)) (defmethod dom:node-name ((self document-type)) (dom:name self)) (defmethod dom:node-name ((self notation)) (dom:name self)) (defmethod dom:node-name ((self entity)) (dom:name self)) (defmethod dom:node-name ((self entity-reference)) (dom:name self)) (defmethod dom:node-name ((self processing-instruction)) (dom:target self)) ;; node-type (defmethod dom:node-type ((self document)) :document) (defmethod dom:node-type ((self document-fragment)) :document-fragment) (defmethod dom:node-type ((self text)) :text) (defmethod dom:node-type ((self comment)) :comment) (defmethod dom:node-type ((self cdata-section)) :cdata-section) (defmethod dom:node-type ((self attribute)) :attribute) (defmethod dom:node-type ((self element)) :element) (defmethod dom:node-type ((self document-type)) :document-type) (defmethod dom:node-type ((self notation)) :notation) (defmethod dom:node-type ((self entity)) :entity) (defmethod dom:node-type ((self entity-reference)) :entity-reference) (defmethod dom:node-type ((self processing-instruction)) :processing-instruction) ;; node-value (defmethod dom:node-value ((self document)) nil) (defmethod dom:node-value ((self document-fragment)) nil) (defmethod dom:node-value ((self character-data)) (dom:data self)) (defmethod dom:node-value ((self attribute)) (dom:name self)) (defmethod dom:node-value ((self element)) nil) (defmethod dom:node-value ((self document-type)) nil) (defmethod dom:node-value ((self notation)) nil) (defmethod dom:node-value ((self entity)) nil) (defmethod dom:node-value ((self entity-reference)) nil) (defmethod dom:node-value ((self processing-instruction)) (dom:data self)) ;; attributes ;; (gibt es nur auf element) (defmethod dom:attributes ((self node)) nil) ;; dann fehlt noch can-adopt und attribute conventions fuer adoption ;;; NAMED-NODE-MAP (defmethod dom:get-named-item ((self named-node-map) name) (setf name (rod name)) (with-slots (items) self (dolist (k items nil) (cond ((rod= name (dom:node-name k)) (return k)))))) (defmethod dom:set-named-item ((self named-node-map) arg) (let ((name (dom:node-name arg))) (with-slots (items) self (dolist (k items (progn (setf items (cons arg items))nil)) (cond ((rod= name (dom:node-name k)) (setf items (cons arg (delete k items))) (return k))))))) (defmethod dom:remove-named-item ((self named-node-map) name) (setf name (rod name)) (with-slots (items) self (dolist (k items nil) (cond ((rod= name (dom:node-name k)) (setf items (delete k items)) (return k)))))) (defmethod dom:length ((self named-node-map)) (with-slots (items) self (length items))) (defmethod dom:item ((self named-node-map) index) (with-slots (items) self (elt items index))) ;;; CHARACTER-DATA (defmethod dom:length ((node character-data)) (length (slot-value node 'value))) (defmethod dom:substring-data ((node character-data) offset count) (subseq (slot-value node 'value) offset (+ offset count))) (defmethod dom:append-data ((node character-data) arg) (setq arg (rod arg)) (with-slots (value) node (setf value (concatenate (type-of value) value arg))) (values)) (defmethod dom:delete-data ((node character-data) offset count) (with-slots (value) node (let ((new (make-array (- (length value) count) :element-type (type-of value)))) (replace new value :start1 0 :end1 offset :start2 0 :end2 offset) (replace new value :start1 offset :end1 (length new) :start2 (+ offset count) :end2 (length value)) (setf value new))) (values)) (defmethod dom:replace-data ((node character-data) offset count arg) (setf arg (rod arg)) (with-slots (value) node (replace value arg :start1 offset :end1 (+ offset count) :start2 0 :end2 count)) (values)) ;;; ATTR ;; hmm... value muss noch entities lesen und text-nodes in die hierarchie hängen. (defmethod (setf dom:value) (new-value (node attribute)) (setf (slot-value node 'value) (rod new-value))) ;;; ELEMENT (defmethod dom:get-attribute-node ((element element) name) (dom:get-named-item (dom:attributes element) name)) (defmethod dom:set-attribute-node ((element element) (new-attr attribute)) (dom:set-named-item (dom:attributes element) new-attr)) (defmethod dom:get-attribute ((element element) name) (let ((a (dom:get-attribute-node element name))) (if a (dom:value a) nil))) (defmethod dom:set-attribute ((element element) name value) (with-slots (owner) element (dom:set-attribute-node element (make-instance 'attribute :owner owner :name name :value value :specified-p t)) (values))) (defmethod dom:remove-attribute-node ((element element) (old-attr attribute)) (let ((res (dom:remove-named-item element (dom:name old-attr)))) (if res res ;; NOT_FOUND_ERR (error "Attribute not found.")))) (defmethod dom:get-elements-by-tag-name ((element element) name) name (error "Not implemented.")) (defmethod dom:normalize ((element element)) (error "Not implemented.") ) ;;; TEXT (defmethod dom:split-text ((text text) offset) offset (error "Not implemented.")) ;;; COMMENT -- nix ;;; CDATA-SECTION -- nix ;;; DOCUMENT-TYPE -- missing ;;; NOTATION -- nix ;;; ENTITY -- nix ;;; ENTITY-REFERENCE -- nix ;;; PROCESSING-INSTRUCTION -- nix ;; Notbehelf! (defun can-adopt-p (x y) x y t) ;;; predicates (defmethod dom:node-p ((object node)) t) (defmethod dom:node-p ((object t)) nil) (defmethod dom:document-p ((object document)) t) (defmethod dom:document-p ((object t)) nil) (defmethod dom:document-fragment-p ((object document-fragment)) t) (defmethod dom:document-fragment-p ((object t)) nil) (defmethod dom:character-data-p ((object character-data)) t) (defmethod dom:character-data-p ((object t)) nil) (defmethod dom:attribute-p ((object attribute)) t) (defmethod dom:attribute-p ((object t)) nil) (defmethod dom:element-p ((object element)) t) (defmethod dom:element-p ((object t)) nil) (defmethod dom:text-node-p ((object text)) t) (defmethod dom:text-node-p ((object t)) nil) (defmethod dom:comment-p ((object comment)) t) (defmethod dom:comment-p ((object t)) nil) (defmethod dom:cdata-section-p ((object cdata-section)) t) (defmethod dom:cdata-section-p ((object t)) nil) (defmethod dom:document-type-p ((object document-type)) t) (defmethod dom:document-type-p ((object t)) nil) (defmethod dom:notation-p ((object notation)) t) (defmethod dom:notation-p ((object t)) nil) (defmethod dom:entity-p ((object entity)) t) (defmethod dom:entity-p ((object t)) nil) (defmethod dom:entity-reference-p ((object entity-reference)) t) (defmethod dom:entity-reference-p ((object t)) nil) (defmethod dom:processing-instruction-p ((object processing-instruction)) t) (defmethod dom:processing-instruction-p ((object t)) nil) (defmethod dom:named-node-map-p ((object named-node-map)) t) (defmethod dom:named-node-map-p ((object t)) nil) ;; importNode (defmethod import-node-internal (class document node deep &rest initargs) (let ((result (apply #'make-instance class :owner document initargs))) (when deep (dolist (child (dom:child-nodes node)) (dom:append-child result (dom:import-node document child t)))) result)) (defmethod dom:import-node ((document document) (node attribute) deep) (declare (ignore deep)) (import-node-internal 'attribute document node t :name (dom:name node) :value (dom:value node))) (defmethod dom:import-node ((document document) (node document-fragment) deep) (import-node-internal 'document-fragment document node deep)) (defmethod dom:import-node ((document document) (node element) deep) (let ((result (import-node-internal 'element document node deep :tag-name (dom:tag-name node)))) (dolist (attribute (dom:items (dom:attributes node))) (when (dom:specified attribute) (dom:set-attribute result (dom:name attribute) (dom:value attribute)))) result)) (defmethod dom:import-node ((document document) (node entity) deep) (import-node-internal 'entity document node deep :public-id (dom:public-id node) :system-id (dom:system-id node) :notation-name (dom:notation-name node))) (defmethod dom:import-node ((document document) (node entity-reference) deep) (declare (ignore deep)) #+(or) (import-node-internal 'entity-reference document node nil :name (dom:name node)) ;; XXX If the document being imported into provides a definition for ;; this entity name, its value is assigned. (error "not implemented")) (defmethod dom:import-node ((document document) (node notation) deep) (import-node-internal 'notation document node deep :name (dom:name node) :public-id (dom:public-id node) :system-id (dom:system-id node))) (defmethod dom:import-node ((document document) (node processing-instruction) deep) (import-node-internal 'notation document node deep :name (dom:name node) :public-id (dom:public-id node) :system-id (dom:system-id node))) ;; TEXT_NODE, CDATA_SECTION_NODE, COMMENT_NODE (defmethod dom:import-node ((document document) (node character-data) deep) (import-node-internal (class-of node) document node deep :data (dom:data node)))