html5-parser-cxml.lisp

html5-parser-cxml.lisp

;;; -*- mode: lisp; syntax: common-lisp; coding: utf-8-unix; package: html5-parser; -*-

(in-package #:html5-parser)

;;; Change the DOM of the HTML5-PARSER library to work with the CXML DOM
;;; protocol.  It's not particularly efficient, but better then making a
;;; copy every time.

;;; Class definitions are copied and modified.  Using the MOP would be
;;; possible as well.  Also not every single function is implemented, just
;;; enough to get the XPath expressions working.

(defclass node (dom:node)
  ((type :initform :node :allocation :class :reader node-type :reader dom:node-type)
   (name :initarg :name :initform nil :reader node-name :reader dom:local-name)
   (namespace :initarg :namespace :initform nil :reader node-namespace :reader dom:namespace-uri)
   (parent :initform nil :reader node-parent :reader dom:parent-node)
   (value :initform nil :initarg :value :reader node-value :reader dom:value)
   (child-nodes :initform nil :accessor %node-child-nodes)))

(defclass document (dom:document node)
  ((type :initform :document :allocation :class)))

(defclass document-fragment (dom:document-fragment document)
  ((type :initform :fragment :allocation :class)))

(defclass document-type (dom:document-type node)
  ((type :initform :doctype :allocation :class)
   (public-id :initarg :public-id :reader node-public-id)
   (system-id :initarg :system-id :reader node-system-id)))

(defclass text-node (dom:text node)
  ((type :initform :text :allocation :class)))

(defclass element (dom:element node)
  ((type :initform :element :allocation :class)
   (attributes :initform nil :accessor %node-attributes)))

(defclass comment-node (dom:comment node)
  ((type :initform :comment :allocation :class)))

;; attributes mapped from html5-parser representation
(defclass attribute-node-map (dom:named-node-map)
  ((element :initarg :element)))

(defclass attribute (dom:attr node)
  ((owner-element :initarg :owner-element :reader dom:owner-element)))

(defmethod dom:node-value ((attribute attribute))
  (dom:value attribute))

(defmethod dom:node-value ((element element)))

(defmethod dom:node-value ((text-node text-node))
  (dom:value text-node))

(defmethod dom:node-value ((fragment document-fragment)))

(defmethod dom:node-value ((document document)))

(defmethod dom:attributes ((element element))
  (make-instance 'attribute-node-map :element element))

(defmethod dom:items ((attributes attribute-node-map))
  (let ((element (slot-value attributes 'element)))
    (mapcar
     (lambda (node-attribute)
       (make-instance
        'attribute
        :name (caar node-attribute)
        :value (cdr node-attribute)
        :owner-element element))
     (%node-attributes element))))

(defmethod dom:get-attribute-node ((element element) name)
  (let ((attribute (member name (%node-attributes element) :key #'caar :test #'string=)))
    (and attribute
         (make-instance
          'attribute
          :name (caar attribute)
          :value (cdar attribute)
          :owner-element element))))

(defmethod dom:get-attribute ((element element) name)
  (let ((attribute (member name (%node-attributes element) :key #'caar :test #'string=)))
    (if attribute
        (cdar attribute)
        "")))

(defmethod dom:child-nodes ((node node))
  (coerce (%node-child-nodes node) 'vector))

(defmethod dom:document-element ((document document))
  (car (member-if #'dom:element-p (%node-child-nodes document))))

(defmethod dom:node-p ((object node)) t)
(defmethod dom:document-p ((object document)) t)
(defmethod dom:document-fragment-p ((object document-fragment)) t)
;; (defmethod dom:character-data-p ((object character-data)) t)
;; (defmethod dom:attribute-p ((object attribute)) t)
(defmethod dom:element-p ((object element)) t)
(defmethod dom:text-node-p ((object text-node)) t)
(defmethod dom:comment-p ((object comment-node)) t)
;;(defmethod dom:cdata-section-p ((object cdata-section)) t)
(defmethod dom:document-type-p ((object document-type)) t)
;;(defmethod dom:notation-p ((object notation)) t)
;;(defmethod dom:entity-p ((object entity)) t)
;;(defmethod dom:entity-reference-p ((object entity-reference)) t)
;;(defmethod dom:processing-instruction-p ((object processing-instruction)) t)