document.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
  35 ;;;; Class DOCUMENT
  36
  37 (defun make-document (document-element)
  38   "@arg[document-element]{an @class{element}}
  39    @return{an @class{document}}
  40    @short{This function creates document.}
  41
  42    The given element is used as the document's only initial child."
  43   (check-type document-element element)
  44   (let ((result (make-instance 'document)))
  45     (insert-child result document-element 0)
  46     result))
  47
  48 (defmethod copy ((node document))
  49   (let ((result (make-instance 'document)))
  50     (insert-child result (copy (document-element node)) 0)
  51     ;; zzz das ist doch nicht schoen so
  52     (let ((i 0))
  53       (do-children (child node)
  54         (unless (typep child 'element)
  55           (insert-child result (copy child) i))
  56         (incf i)))
  57     (setf (%base-uri result) (%base-uri node))
  58     result))
  59
  60 (defun assert-orphan (node)
  61   (when (parent node)
  62     (stp-error "node already has a parent: ~A" node)))
  63
  64 (defmethod check-insertion-allowed ((parent document) child i)
  65   (assert-orphan child)
  66   (typecase child
  67     ((or comment processing-instruction))
  68     (cxml-stp:document-type
  69      (when (stp:document-type parent)
  70        (stp-error "attempt to insert multiple document types"))
  71      (let ((j (child-position-if (alexandria:of-type 'element) parent)))
  72        (unless (<= i j)
  73          (stp-error
  74           "attempt to insert document type after document element"))))
  75     (element
  76      (when (some (alexandria:of-type 'element) (%children parent))
  77        (stp-error "attempt to insert multiple document elements")))
  78     (t
  79      (stp-error "not a valid child of a document: ~A" child))))
  80
  81 (defmethod check-deletion-allowed ((parent document) (child node) i)
  82   nil)
  83 (defmethod check-deletion-allowed ((parent document) (child element) i)
  84   (stp-error "attempt to remove document element"))
  85
  86 (defmethod replace-child ((parent document) old-child new-child)
  87   (cond
  88     ((and (eq old-child (document-element parent))
  89           (typep new-child 'element))
  90       (setf (document-element parent) new-child))
  91     ((and (eq old-child (stp:document-type parent))
  92           (typep new-child 'cxml-stp:document-type))
  93       (setf (stp:document-type parent) new-child))
  94     (t
  95       (call-next-method))))
  96
  97 (defun cxml-stp:document-type (document)
  98   "@arg[document]{a @class{document}}
  99    @return{a @class{document-type}, or nil}
 100    This function returns the child node that is a document type, or nil.
 101    @see{document-element}"
 102   (find-if (alexandria:of-type 'cxml-stp:document-type) (%children document)))
 103
 104 ;; zzz gefaellt mir nicht
 105 (defun (setf cxml-stp:document-type) (newval document)
 106   (check-type newval cxml-stp:document-type)
 107   (let ((old (cxml-stp:document-type document)))
 108     (unless (eq newval old)
 109       (assert-orphan newval)
 110       (if old
 111           (let ((pos (position old (%children document))))
 112             (delete-nth-child pos document)
 113             (insert-child document newval pos))
 114           (insert-child document newval 0)))))
 115
 116 (defun document-element (document)
 117   "@arg[document]{a @class{document}}
 118    @return{an @class{element}}
 119    This function returns the child node that is an element.
 120    @see{document-type}"
 121   (find-if (alexandria:of-type 'element) (%children document)))
 122
 123 ;; zzz gefaellt mir nicht
 124 (defun (setf document-element) (newval document)
 125   (check-type newval element)
 126   (let ((old (document-element document)))
 127     (unless (eq newval old)
 128       (assert-orphan newval)
 129       (let ((pos (position old (%children document))))
 130         (%nuke-nth-child document pos)
 131         (insert-child document newval pos)))))
 132
 133 (defmethod base-uri ((document document))
 134   (%base-uri document))
 135
 136 (defmethod (setf base-uri) (newval (document document))
 137   (setf (%base-uri document) newval))
 138
 139 (defmethod string-value ((node document))
 140   (string-value (document-element node)))
 141
 142 (defmethod serialize ((node document) handler)
 143   (sax:start-document handler)
 144   (map nil (lambda (x) (serialize x handler)) (%children node))
 145   (sax:end-document handler))
 146
 147 (defreader document ())