processing-instruction.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 PROCESSING-INSTRUCTION
  36
  37 (defgeneric target (processing-instruction)
  38   (:documentation
  39    "@arg[processing-instruction]{@class{processing-instruction}}
  40     @return{string, a Name}
  41     @short{Returns the processing-instruction's target.}"))
  42
  43 (defgeneric (setf target) (newval processing-instruction)
  44   (:documentation
  45    "@arg[newval]{string, a Name}
  46     @arg[processing-instruction]{@class{processing-instruction}}
  47     @return{the target}
  48     @short{Sets the processing-instruction's target.}"))
  49
  50 (defun make-processing-instruction (target data)
  51   "@arg[target]{string, an NCName}
  52    @arg[data]{string containing XML characters only}
  53    @return{an @class{processing-instruction}}
  54    @short{This function creates a processing instruction.}
  55
  56    @code{target} must not equal \"xml\".
  57
  58    @code{data} must not contain the substring \"?>\"."
  59   (let ((result (make-instance 'processing-instruction)))
  60     (setf (target result) target)
  61     (setf (data result) data)
  62     result))
  63
  64 (defmethod copy ((node processing-instruction))
  65   (make-instance 'processing-instruction
  66     :target (target node)
  67     :data (data node)))
  68
  69 (defmethod string-value ((node processing-instruction))
  70   (data node))
  71
  72 (defmethod (setf target) :before (newval (node processing-instruction))
  73   (check-nc-name newval)
  74   (when (string-equal newval "xml")
  75     (stp-error "attempt to pretend that a PI is an XMLDecl")))
  76
  77 (defmethod (setf data) :around (newval (node processing-instruction))
  78   (unless newval (setf newval ""))
  79   (unless (xml-characters-p newval)
  80     (stp-error "Processing instruction data includes characters that ~
  81                 cannot be represented in XML at all: ~S"
  82                newval))
  83   (when (search "?>" newval)
  84     (stp-error "forbidden -- in processing-instruction"))
  85   (when (or (alexandria:starts-with 9 newval :key #'char-code)
  86             (alexandria:starts-with 10 newval :key #'char-code)
  87             (alexandria:starts-with 13 newval :key #'char-code)
  88             (alexandria:starts-with 32 newval :key #'char-code))
  89     (stp-error "space at beginning of processing instruction data"))
  90   (call-next-method newval node))
  91
  92 (defmethod serialize ((node processing-instruction) handler)
  93   (sax:processing-instruction handler (target node) (data node)))
  94
  95
  96 ;;; printing
  97
  98 (defmethod slots-for-print-object append ((node processing-instruction))
  99   '((:data data)
 100     (:target target)))
 101
 102 (defreader processing-instruction (data target)
 103   (setf (data this) data)
 104   (setf (target this) target))