dom/dom-sax.lisp

   1 ;;;; dom-sax.lisp -- DOM walker
   2 ;;;;
   3 ;;;; This file is part of the CXML parser, released under Lisp-LGPL.
   4 ;;;; See file COPYING for details.
   5 ;;;;
   6 ;;;; Author: David Lichteblau <david@lichteblau.com>
   7 ;;;; Copyright (c) 2004 knowledgeTools Int. GmbH
   8
   9 (in-package :cxml)
  10
  11 (defun dom:map-document
  12     (handler document
  13      &key (include-xmlns-attributes sax:*include-xmlns-attributes*)
  14           include-doctype
  15           include-default-values
  16           (recode (and #+rune-is-integer (typep document 'utf8-dom::node))))
  17   (declare (ignorable recode))
  18   #+rune-is-integer
  19   (when recode
  20     (setf handler (make-recoder handler #'utf8-string-to-rod)))
  21   (sax:start-document handler)
  22   (when include-doctype
  23     (let ((doctype (dom:doctype document)))
  24       (when doctype
  25         (sax:start-dtd handler
  26                        (dom:name doctype)
  27                        (dom:public-id doctype)
  28                        (dom:system-id doctype))
  29         (ecase include-doctype
  30           (:full-internal-subset
  31             (when (slot-boundp doctype 'dom::%internal-subset)
  32               (sax:start-internal-subset handler)
  33               (dolist (def (dom::%internal-subset doctype))
  34                 (apply (car def) handler (cdr def)))
  35               (sax:end-internal-subset handler)))
  36           (:canonical-notations
  37             ;; need notations for canonical mode 2
  38             (let* ((ns (dom:notations doctype))
  39                    (a (make-array (dom:length ns))))
  40               (when (plusp (dom:length ns))
  41                 (sax:start-internal-subset handler)
  42                 ;; get them
  43                 (dotimes (k (dom:length ns))
  44                   (setf (elt a k) (dom:item ns k)))
  45                 ;; sort them
  46                 (setf a (sort a #'rod< :key #'dom:name))
  47                 (loop for n across a do
  48                       (sax:notation-declaration handler
  49                                                 (dom:name n)
  50                                                 (dom:public-id n)
  51                                                 (dom:system-id n)))
  52                 (sax:end-internal-subset handler)))))
  53         (sax:end-dtd handler))))
  54   (labels ((walk (node)
  55              (dom:do-node-list (child (dom:child-nodes node))
  56                (ecase (dom:node-type child)
  57                  (:element
  58                    (let ((attlist
  59                           (compute-attributes child
  60                                               include-xmlns-attributes
  61                                               include-default-values))
  62                          (uri (dom:namespace-uri child))
  63                          (lname (dom:local-name child))
  64                          (qname (dom:tag-name child)))
  65                      (sax:start-element handler uri lname qname attlist)
  66                      (walk child)
  67                      (sax:end-element handler uri lname qname)))
  68                  (:cdata-section
  69                    (sax:start-cdata handler)
  70                    (sax:characters handler (dom:data child))
  71                    (sax:end-cdata handler))
  72                  (:text
  73                    (sax:characters handler (dom:data child)))
  74                  (:comment
  75                    (sax:comment handler (dom:data child)))
  76                  (:processing-instruction
  77                    (sax:processing-instruction handler
  78                                                (dom:target child)
  79                                                (dom:data child)))))))
  80     (walk document))
  81   (sax:end-document handler))
  82
  83 (defun compute-attributes (element xmlnsp defaultp)
  84   (let ((results '()))
  85     (dom:do-node-list (a (dom:attributes element))
  86       (when (and (or defaultp (dom:specified a))
  87                  (or xmlnsp (not (cxml::xmlns-attr-p (rod (dom:name a))))))
  88         (push
  89          (sax:make-attribute :qname (dom:name a)
  90                              :value (dom:value a)
  91                              :local-name (dom:local-name a)
  92                              :namespace-uri (dom:namespace-uri a)
  93                              :specified-p (dom:specified a))
  94          results)))
  95     (reverse results)))