builder.lisp

   1 ;;; -*- show-trailing-whitespace: t; indent-tabs: nil -*-
   2
   3 ;;; Copyright (c) 2007 David Lichteblau. All rights reserved.
   4
   5 ;;; Redistribution and use in source and binary forms, with or without
   6 ;;; modification, are permitted provided that the following conditions
   7 ;;; are met:
   8 ;;;
   9 ;;;   * Redistributions of source code must retain the above copyright
  10 ;;;     notice, this list of conditions and the following disclaimer.
  11 ;;;
  12 ;;;   * Redistributions in binary form must reproduce the above
  13 ;;;     copyright notice, this list of conditions and the following
  14 ;;;     disclaimer in the documentation and/or other materials
  15 ;;;     provided with the distribution.
  16 ;;;
  17 ;;; THIS SOFTWARE IS PROVIDED BY THE AUTHOR 'AS IS' AND ANY EXPRESSED
  18 ;;; OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED
  19 ;;; WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
  20 ;;; ARE DISCLAIMED.  IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR ANY
  21 ;;; DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
  22 ;;; DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE
  23 ;;; GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
  24 ;;; INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY,
  25 ;;; WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING
  26 ;;; NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS
  27 ;;; SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
  28
  29 (in-package :cxml-stp-impl)
  30
  31 #+sbcl
  32 (declaim (optimize (debug 2)))
  33
  34 (defun make-builder ()
  35   "@return{STP builder, a SAX handler}
  36    @short{This function creates SAX handler that constructs an STP document.}
  37
  38    The builder processes SAX events and can be used with any
  39    function generating such events, in particular with cxml:parse-file.
  40
  41    Examples. Parsing a file:
  42    @begin{pre}(cxml:parse #p\"example.xml\" (stp:make-builder))@end{pre}
  43    Parsing a string:
  44    @begin{pre}(cxml:parse \"<example/>\" (stp:make-builder))@end{pre}
  45
  46    @see{serialize}"
  47   (make-instance 'builder))
  48
  49 (defclass builder (sax:content-handler)
  50   ((nodes :initform nil :accessor builder-nodes)
  51    (doctype :initform nil :accessor builder-doctype)
  52    (namespace-declarations :initform nil :accessor namespace-declarations)
  53    (internal-subset-sink :initform nil
  54                          :accessor builder-internal-subset-sink)))
  55
  56 (defmethod sax:start-document ((builder builder))
  57   (push (make-instance 'document) (builder-nodes builder)))
  58
  59 (defun builder-append (builder x)
  60   (let ((parent (car (builder-nodes builder))))
  61     (%unchecked-insert-child parent x (length (%children parent)))))
  62
  63 (defmethod sax:start-dtd ((builder builder) name publicid systemid)
  64   (setf (builder-doctype builder)
  65         (make-document-type name systemid publicid ""))
  66   (builder-append builder (builder-doctype builder)))
  67
  68 (defmethod sax:start-internal-subset ((builder builder))
  69   (setf (builder-internal-subset-sink builder) (cxml:make-string-sink)))
  70
  71 (macrolet ((def (name &rest args)
  72              `(defmethod ,name ((builder builder) ,@args)
  73                 (let ((sink (builder-internal-subset-sink builder)))
  74                   (when sink (,name sink ,@args))))))
  75   (def sax:unparsed-entity-declaration name public-id system-id notation-name)
  76   (def sax:external-entity-declaration kind name public-id system-id)
  77   (def sax:internal-entity-declaration kind name value)
  78   (def sax:notation-declaration name public-id system-id)
  79   (def sax:element-declaration name model)
  80   (def sax:attribute-declaration element-name attribute-name type default))
  81
  82 (defmethod sax:end-internal-subset ((builder builder))
  83   (setf (internal-subset (builder-doctype builder))
  84         (string-trim "[]"
  85                      (sax:end-document
  86                       (builder-internal-subset-sink builder))))
  87   (setf (builder-internal-subset-sink builder) nil))
  88
  89 (defmethod sax::dtd ((builder builder) dtd)
  90   (when (builder-doctype builder)
  91     (setf (dtd (builder-doctype builder)) dtd)))
  92
  93 (defmethod sax:start-prefix-mapping ((builder builder) prefix uri)
  94   (push (cons (or prefix "") uri) (namespace-declarations builder)))
  95
  96 (defmethod sax:start-element ((builder builder) uri lname qname attrs)
  97   (let ((element (make-element qname uri)))
  98     (setf (%base-uri element) (sax:xml-base builder))
  99     (dolist (a attrs)
 100       (let ((uri (sax:attribute-namespace-uri a)))
 101         (unless (equal uri "http://www.w3.org/2000/xmlns/")
 102           (let ((b (make-attribute (sax:attribute-value a)
 103                                    (sax:attribute-qname a)
 104                                    uri)))
 105             (add-attribute element b)))))
 106     (builder-append builder element)
 107     (loop for (prefix . uri) in (namespace-declarations builder) do
 108          (unless (find-namespace prefix element)
 109            (add-extra-namespace element prefix uri)))
 110     (setf (namespace-declarations builder) nil)
 111     (push element (builder-nodes builder))))
 112
 113 (defmethod sax:end-element ((builder builder) uri lname qname)
 114   (declare (ignore uri lname qname))
 115   (pop (builder-nodes builder)))
 116
 117 ;; zzz normalisieren?
 118 (defmethod sax:characters ((builder builder) data)
 119   (builder-append builder (make-text data)))
 120
 121 (defmethod sax:processing-instruction ((builder builder) target data)
 122   (builder-append builder (make-processing-instruction target data)))
 123
 124 (defmethod sax:comment ((builder builder) data)
 125   (builder-append builder (make-comment data)))
 126
 127 (defmethod sax:end-document ((builder builder))
 128   (pop (builder-nodes builder)))