document-type.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-TYPE
  36
  37 (defgeneric root-element-name (document-type)
  38   (:documentation
  39    "@arg[document-type]{@class{document-type}}
  40     @return{string, a Name}
  41     @short{Returns the document-type's root-element-name.}"))
  42
  43 (defgeneric (setf root-element-name) (newval document-type)
  44   (:documentation
  45    "@arg[newval]{string, a Name}
  46     @arg[document-type]{@class{document-type}}
  47     @return{the root-element-name}
  48     @short{Sets the document-type's root-element-name.}"))
  49
  50 (defgeneric system-id (document-type)
  51   (:documentation
  52    "@arg[document-type]{@class{document-type}}
  53     @return{string suitable as a system ID}
  54     @short{Returns the document-type's system-id.}"))
  55
  56 (defgeneric (setf system-id) (newval document-type)
  57   (:documentation
  58    "@arg[newval]{string, suitable as a system ID}
  59     @arg[document-type]{@class{document-type}}
  60     @return{the system-id}
  61     @short{Sets the document-type's system-id.}"))
  62
  63 (defgeneric public-id (document-type)
  64   (:documentation
  65    "@arg[document-type]{@class{document-type}}
  66     @return{string suitable as a system ID}
  67     @short{Returns the document-type's public-id.}"))
  68
  69 (defgeneric (setf public-id) (newval document-type)
  70   (:documentation
  71    "@arg[newval]{string, suitable as a system ID}
  72     @arg[document-type]{@class{document-type}}
  73     @return{the public-id}
  74     @short{Sets the document-type's public-id.}"))
  75
  76 (defgeneric internal-subset (document-type)
  77   (:documentation
  78    "@arg[document-type]{@class{document-type}}
  79     @return{string, a well-formed internal subset}
  80     @short{Returns the document-type's internal subset as a string.}"))
  81
  82 (defgeneric (setf internal-subset) (newval document-type)
  83   (:documentation
  84    "@arg[newval]{string, a well-formed internal subset}
  85     @arg[document-type]{@class{document-type}}
  86     @return{the internal-subset}
  87     @short{Sets the document-type's internal subset.}"))
  88
  89
  90 (defun make-document-type
  91     (root-element-name &optional system-id public-id internal-subset)
  92   "@arg[root-element-name]{string, a Name}
  93    @arg[system-id]{a string allowed as a system ID}
  94    @arg[public-id]{a string allowed as a public ID}
  95    @arg[internal-subset]{a well-formed internal subset as a string}
  96    @return{an @class{documen-type}}
  97    @short{This function creates a document-type node.}
  98
  99    @see{document}"
 100   (let ((result (make-instance 'cxml-stp:document-type)))
 101     (setf (root-element-name result) root-element-name)
 102     (setf (system-id result) system-id)
 103     (setf (public-id result) public-id)
 104     (setf (internal-subset result) internal-subset)
 105     result))
 106
 107 (defmethod copy ((node cxml-stp:document-type))
 108   (let ((result (make-instance 'cxml-stp:document-type)))
 109     (setf (root-element-name result) (root-element-name node))
 110     (setf (system-id result) (system-id node))
 111     (setf (public-id result) (public-id node))
 112     (setf (internal-subset result) (internal-subset node))
 113     result))
 114
 115 (defun namep (str)
 116   (and (not (zerop (length str)))
 117        (cxml::name-start-rune-p (elt str 0))
 118        (every #'cxml::name-rune-p str)))
 119
 120 (defun check-xml-name (str)
 121   (unless (namep str)
 122     (stp-error "not a Name: ~S" str)))
 123
 124 (defmethod (setf root-element-name) :before (newval (node cxml-stp:document-type))
 125   (unless (zerop (length newval))
 126     (check-xml-name newval)
 127     (handler-case
 128         (cxml::split-qname newval)
 129       (cxml:well-formedness-violation ()
 130         (stp-error "not a QName: ~A" newval)))))
 131
 132 (defmethod (setf internal-subset) :around (newval (node cxml-stp:document-type))
 133   (setf newval (or newval ""))
 134   (unless (zerop (length newval))
 135     (handler-case
 136         (cxml:parse-rod
 137          (concatenate 'string "<!DOCTYPE dummy [" newval "]><dummy/>")
 138          nil)
 139       (cxml:well-formedness-violation (c)
 140         (stp-error "attempt to set internal subset to a value that is not ~
 141                     well-formed: ~A"
 142                    c))))
 143   (call-next-method newval node))
 144
 145 (defmethod (setf public-id) :around (newval (node cxml-stp:document-type))
 146   (when (equal newval "")
 147     (setf newval nil))
 148   (when (and newval (null (system-id node)))
 149     (stp-error "attempt to set public-id, but no system-id is set"))
 150   ;; zzz hier muss mehr geprueft werden?
 151   ;; was ist mit ' und " gleichzeitig?
 152   (unless (every #'cxml::pubid-char-p newval)
 153     (stp-error "malformed public id: ~S" newval))
 154   (call-next-method newval node))
 155
 156 (defmethod (setf system-id) :around (newval (node cxml-stp:document-type))
 157   (when (equal newval "")
 158     (setf newval nil))
 159   (when (and (public-id node) (null newval))
 160     (stp-error "attempt to remove system-id, but public-id is set"))
 161   (when (position #\# newval)
 162     (stp-error "attempt to use a system id with a fragment identifier"))
 163   (when (some (lambda (c) (> (char-code c) 126)) newval)
 164     (stp-error "non-ASCII characters in system id"))
 165   (when (and (position #\" newval) (position #\' newval))
 166     (stp-error "system id contains both single and double quote"))
 167   (call-next-method newval node))
 168
 169 (defmethod (setf dtd) :before (newval (node cxml-stp:document-type))
 170   (check-type newval (or cxml::dtd null)))
 171
 172 (defmethod string-value ((node cxml-stp:document-type))
 173   "")
 174
 175 ;; for the XML test suite
 176 ;; doesn't actually work, since we don't record those notations anyway
 177 (defvar *serialize-canonical-notations-only-p* nil)
 178
 179 (defclass notation-collector ()
 180   ((collected-notations :initform nil :accessor collected-notations)))
 181
 182 (defmethod sax:notation-declaration
 183     ((handler notation-collector) name public system)
 184   (push (list name public system) (collected-notations handler)))
 185
 186 (defmethod sax:end-document ((handler notation-collector))
 187   (collected-notations handler))
 188
 189 (defmethod serialize ((node cxml-stp:document-type) handler)
 190   (sax:start-dtd handler
 191                  (root-element-name node)
 192                  (public-id node)
 193                  (system-id node))
 194   (unless (zerop (length (internal-subset node)))
 195     (if *serialize-canonical-notations-only-p*
 196         (let ((notations
 197                (cxml:parse-rod
 198                 (concatenate 'string
 199                              "<!DOCTYPE dummy ["
 200                              (internal-subset node)
 201                              "]><dummy/>")
 202                 (make-instance 'notation-collector))))
 203           (when notations
 204             (sax:start-internal-subset handler)
 205             (loop
 206                for (name public system)
 207                in (sort notations #'string< :key #'car)
 208                do
 209                  (sax:notation-declaration handler name public system))
 210             (sax:end-internal-subset handler)))
 211         (sax:unparsed-internal-subset handler (internal-subset node))))
 212   (sax:end-dtd handler))
 213
 214
 215 ;;; printing
 216
 217 (defmethod slots-for-print-object append ((node cxml-stp:document-type))
 218   '((:root-element-name root-element-name)
 219     (:system-id system-id)
 220     (:public-id public-id)
 221     (:internal-subset internal-subset)))
 222
 223 (defreader cxml-stp:document-type
 224     (root-element-name system-id public-id internal-subset)
 225   (setf (root-element-name this) root-element-name)
 226   (setf (system-id this) system-id)
 227   (setf (public-id this) public-id)
 228   (setf (internal-subset this) internal-subset))