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)
  30
  31 #+sbcl
  32 (declaim (optimize (debug 2)))
  33
  34
  35 ;;;; Class DOCUMENT
  36
  37 (defclass document (parent-node) ())
  38
  39 (defun make-document (document-element)
  40   (check-type document-element element)
  41   (let ((result (make-instance 'document)))
  42     (insert-child result document-element 0)
  43     result))
  44
  45 (defmethod copy ((node document))
  46   (let ((result (make-instance 'document)))
  47     (insert-child result (copy (document-element node)) 0)
  48     ;; zzz das ist doch nicht schoen so
  49     (let ((i 0))
  50       (do-children (child node)
  51         (unless (typep child 'element)
  52           (insert-child result i (copy child)))
  53         (incf i)))
  54     (setf (%base-uri result) (%base-uri node))
  55     result))
  56
  57 (defun assert-orphan (node)
  58   (when (parent node)
  59     (stp-error "node already has a parent: ~A" node)))
  60
  61 (defmethod check-insertion-allowed ((parent document) child i)
  62   (assert-orphan child)
  63   (typecase child
  64     ((or comment processing-instruction))
  65     (document-type
  66      (when (document-type parent)
  67        (stp-error "attempt to insert multiple document types"))
  68      (let ((j (child-position-if (alexandria:of-type 'element) parent)))
  69        (unless (<= i j)
  70          (stp-error
  71           "attempt to insert document type after document element"))))
  72     (element
  73      (unless (alexandria:emptyp (%children parent))
  74        (stp-error "attempt to insert multiple document elements")))
  75     (t
  76      (stp-error "not a valid child of a document: ~A" child))))
  77
  78 (defmethod check-deletion-allowed ((parent document) (child node) i)
  79   nil)
  80 (defmethod check-deletion-allowed ((parent document) (child element) i)
  81   (stp-error "attempt to remove document element"))
  82
  83 (defmethod check-replacement-allowed ((parent document) children)
  84   (unless children
  85     (stp-error "attempt to remove document element"))
  86   (let ((dt nil)
  87         (de nil))
  88     (loop
  89        for i from 0
  90        for c across children
  91        do
  92          (typecase c
  93            ((or comment processing-instruction))
  94            (element
  95             (when de
  96               (stp-error "attempt to insert multiple document elements"))
  97             (setf de i))
  98            (document-type
  99             (when dt
 100               (stp-error "attempt to insert multiple document types"))
 101             (setf dt i))
 102            (t
 103             (stp-error "not a valid child of a document: ~A" c))))
 104     (when (and dt (> dt de))
 105       (stp-error "attempt to insert document type after document element"))))
 106
 107 (defun document-type (document)
 108   (find-if (alexandria:of-type 'document-type) (%children document)))
 109
 110 ;; zzz gefaellt mir nicht
 111 (defun (setf document-type) (newval document)
 112   (check-type newval document-type)
 113   (let ((old (document-type document)))
 114     (unless (eq newval old)
 115       (assert-orphan newval)
 116       (if old
 117           (let ((pos (position old (%children document))))
 118             (delete-nth-child pos document)
 119             (insert-child document newval pos))
 120           (insert-child document newval 0)))))
 121
 122 (defun document-element (document)
 123   (find-if (alexandria:of-type 'element) (%children document)))
 124
 125 ;; zzz gefaellt mir nicht
 126 (defun (setf document-element) (newval document)
 127   (check-type newval element)
 128   (let ((old (document-element document)))
 129     (unless (eq newval old)
 130       (assert-orphan newval)
 131       (let ((pos (position old (%children document))))
 132         (%nuke-nth-child document pos)
 133         (insert-child document newval pos)))))
 134
 135 (defmethod base-uri ((document document))
 136   (%base-uri document))
 137
 138 (defmethod (setf base-uri) (newval (document document))
 139   (setf (%base-uri document) newval))
 140
 141 (defmethod string-value ((node document))
 142   (string-value (document-element node)))
 143
 144 (defmethod unparse ((node document) handler)
 145   (sax:start-document handler)
 146   (map nil #'unparse (%children node))
 147   (sax:end-document handler))