Recover from invalid PI names
[xuriella.git] / space.lisp
blob2ecfdc2415ec245e6533fad5f692dffe747674a8
1 ;;; -*- show-trailing-whitespace: t; indent-tabs-mode: nil -*-
3 ;;; Copyright (c) 2007,2008 David Lichteblau, Ivan Shvedunov.
4 ;;; All rights reserved.
6 ;;; Redistribution and use in source and binary forms, with or without
7 ;;; modification, are permitted provided that the following conditions
8 ;;; are met:
9 ;;;
10 ;;; * Redistributions of source code must retain the above copyright
11 ;;; notice, this list of conditions and the following disclaimer.
12 ;;;
13 ;;; * Redistributions in binary form must reproduce the above
14 ;;; copyright notice, this list of conditions and the following
15 ;;; disclaimer in the documentation and/or other materials
16 ;;; provided with the distribution.
17 ;;;
18 ;;; THIS SOFTWARE IS PROVIDED BY THE AUTHOR 'AS IS' AND ANY EXPRESSED
19 ;;; OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED
20 ;;; WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
21 ;;; ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR ANY
22 ;;; DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
23 ;;; DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE
24 ;;; GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
25 ;;; INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY,
26 ;;; WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING
27 ;;; NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS
28 ;;; SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
31 ;;; This file implements whitespace stripping.
32 ;;;
33 ;;; Although the spec presents a unified algorithm for whitespace stripping
34 ;;; of stylesheets and source documents, we implement them separately.
35 ;;;
36 ;;; For stylesheets, the STP parse tree of the stylesheet is modified
37 ;;; directly according the its xml:space declarations and xsl:text elements.
38 ;;;
39 ;;; For source documents, the strip-space and preserve-space declarations
40 ;;; from the stylesheet are taken into account. To avoid processing
41 ;;; parts of the document that XPath would not otherwise have navigated
42 ;;; to, we do whitespace stripping lazily using a proxy implementation
43 ;;; of the XPath protocol.
45 (in-package :xuriella)
47 #+sbcl
48 (declaim (optimize (debug 2)))
51 ;;;; Helper functions
53 (eval-when (:compile-toplevel :load-toplevel :execute)
54 (defparameter *whitespace*
55 (format nil "~C~C~C~C"
56 (code-char 9)
57 (code-char 32)
58 (code-char 13)
59 (code-char 10))))
61 (defun normalize-whitespace (str)
62 (cl-ppcre:regex-replace-all #.(format nil "[~A]+" *whitespace*)
63 (string-trim *whitespace* str)
64 " "))
66 (defun whitespacep (str)
67 (cl-ppcre:all-matches #.(format nil "^[~A]+$" *whitespace*) str))
69 (defun words (str)
70 (when str
71 (cl-ppcre:split #.(format nil "[~A]+" *whitespace*)
72 (string-trim *whitespace* str))))
75 ;;;; Strip whitespace in stylesheets
77 ;; Also strips comments and PIs.
78 (defun strip-stylesheet (parent &optional preserve)
79 (let ((i 0))
80 (loop while (< i (length (cxml-stp-impl::%children parent))) do
81 (let ((child (stp:nth-child i parent)))
82 (etypecase child
83 (stp:text
84 (if (and (whitespacep (stp:data child))
85 (not preserve))
86 (stp:delete-nth-child i parent)
87 (incf i)))
88 ((or stp:comment stp:processing-instruction)
89 (stp:delete-nth-child i parent))
90 (stp:element
91 (stp:with-attributes ((space "space" *xml*))
92 child
93 (let ((new-preserve
94 (cond
95 ((namep child "text") t)
96 ((not space) preserve)
97 ((equal space "preserve") t)
98 (t nil))))
99 (strip-stylesheet child new-preserve)))
100 (incf i)))))))
103 ;;;; Strip whitespace in source documents
105 (defun make-whitespace-stripper (node strip-thunk)
106 (if strip-thunk
107 (make-stripping-node nil node strip-thunk nil)
108 node))
110 (defstruct (stripping-node (:constructor #:ignore))
111 parent
112 target
113 children)
115 (defstruct (leaf-stripping-node
116 (:constructor make-leaf-stripping-node (parent target))
117 (:include stripping-node)))
119 (defstruct (parent-stripping-node
120 (:constructor make-parent-stripping-node (parent target))
121 (:include stripping-node)))
123 (defmethod print-object ((object stripping-node) stream)
124 (print-unreadable-object (object stream :type t :identity nil)
125 (let ((target (write-to-string (stripping-node-target object))))
126 (if (and (alexandria:starts-with-subseq target "#<")
127 (alexandria:ends-with #\> target))
128 (write-sequence target stream :start 3 :end (1- (length target)))
129 (write-sequence target stream)))))
131 (defun strip-under-qname-p (node strip-thunk)
132 (let* ((strip-test
133 (maximize #'strip-test-<
134 (xpath:matching-values strip-thunk node))))
135 (and strip-test
136 (eq (strip-test-value strip-test) :strip))))
138 (defun strip-test-< (a b)
139 (let ((i (strip-test-priority a))
140 (j (strip-test-priority b)))
141 (cond
142 ((< i j) t)
143 ((> i j) nil)
145 (< (strip-test-position a)
146 (strip-test-position b))))))
148 (defun xpath-protocol/attribute-value (node local-name uri)
149 (do-pipe (a (xpath-protocol:attribute-pipe node))
150 (when (and (equal (xpath-protocol:local-name a) local-name)
151 (equal (xpath-protocol:namespace-uri a) uri))
152 (return (xpath-protocol:node-text a)))))
154 (defun make-stripping-node (parent target strip-thunk force-preserve)
155 (let ((result (make-parent-stripping-node parent target))
156 (xml-space (xpath-protocol/attribute-value target "space" *xml*)))
157 (when xml-space
158 (setf force-preserve (equal xml-space "preserve")))
159 (labels ((recurse (child-node)
160 (if (xpath-protocol:node-type-p child-node :element)
161 (make-stripping-node result child-node strip-thunk force-preserve)
162 (make-leaf-stripping-node result child-node)))
163 (maybe-recurse (child-node)
164 (if (and (xpath-protocol:node-type-p child-node :text)
165 (whitespacep (xpath-protocol:node-text child-node)))
167 (recurse child-node))))
168 (let ((all-children (xpath-protocol:child-pipe target)))
169 (setf (stripping-node-children result)
170 (if (or force-preserve
171 (not (xpath-protocol:node-type-p target :element))
172 (not (strip-under-qname-p target strip-thunk)))
173 (xpath::map-pipe-filtering #'recurse all-children)
174 (xpath::map-pipe-filtering #'maybe-recurse all-children)))))
175 result))
177 (macrolet ((defproxy (name &rest args)
178 `(define-default-method ,name ((node stripping-node) ,@args)
179 (,name (stripping-node-target node) ,@args))))
180 (defproxy xpath-protocol:local-name)
181 (defproxy xpath-protocol:namespace-uri)
182 (defproxy xpath-protocol:namespace-prefix)
183 (defproxy xpath-protocol:qualified-name)
184 (defproxy xpath-protocol:node-type-p type))
186 (define-default-method xpath-protocol:node-equal
187 ((a stripping-node) (b stripping-node))
188 (xpath-protocol:node-equal (stripping-node-target a)
189 (stripping-node-target b)))
191 (define-default-method xpath-protocol:hash-key ((node stripping-node))
192 (xpath-protocol:hash-key (stripping-node-target node)))
194 (define-default-method xpath-protocol:attribute-pipe ((node stripping-node))
195 (xpath::map-pipe (lambda (attribute)
196 (make-leaf-stripping-node node attribute))
197 (xpath-protocol:attribute-pipe
198 (stripping-node-target node))))
200 (define-default-method xpath-protocol:namespace-pipe ((node stripping-node))
201 (xpath::map-pipe (lambda (namespace)
202 (make-leaf-stripping-node node namespace))
203 (xpath-protocol:namespace-pipe
204 (stripping-node-target node))))
206 (define-default-method xpath-protocol:node-p ((node stripping-node))
209 (define-default-method xpath-protocol:child-pipe ((node stripping-node))
210 (stripping-node-children node))
212 (define-default-method xpath-protocol:parent-node ((node stripping-node))
213 (stripping-node-parent node))
215 (define-default-method xpath-protocol:node-text ((node stripping-node))
216 (with-output-to-string (s)
217 (write-string-value node s)))
219 (defmethod write-string-value ((node parent-stripping-node) stream)
220 (do-pipe (child (xpath-protocol:child-pipe node))
221 (unless (or (xpath-protocol:node-type-p child :comment)
222 (xpath-protocol:node-type-p child :processing-instruction))
223 (write-string-value child stream))))
225 (defmethod write-string-value ((node leaf-stripping-node) stream)
226 (write-string-value (stripping-node-target node) stream))
228 (defmethod write-string-value (node stream)
229 (write-string (xpath-protocol:node-text node) stream))
231 (define-default-method xpath-protocol:get-element-by-id
232 ((node stripping-node) id)
233 (let ((target
234 (xpath-protocol:get-element-by-id (stripping-node-target node) id)))
235 (when target
236 (let ((stripping-root
237 (loop
238 for parent = node then next
239 for next = (stripping-node-parent parent)
240 while next
241 finally (return parent)))
242 (target-path nil))
243 (loop
244 for parent = target then next
245 for next = (xpath-protocol:parent-node parent)
246 while next
247 do (push parent target-path))
248 (labels ((find-child (stripping-parent target-child)
249 (xpath::find-in-pipe target-child
250 (xpath-protocol:child-pipe
251 stripping-parent)
252 :key #'stripping-node-target))
253 (resolve-path (stripping-parent target-path)
254 (if target-path
255 (let ((step
256 (find-child stripping-parent (car target-path))))
257 (if step
258 (resolve-path step (cdr target-path))
259 nil))
260 stripping-parent)))
261 (resolve-path stripping-root target-path))))))
263 (define-default-method xpath-protocol:unparsed-entity-uri
264 ((node stripping-node) name)
265 (xpath-protocol:unparsed-entity-uri (stripping-node-target node) name))
268 ;;;; TEXT NORMALIZER, from cxml-rng
270 ;;; FIXME: cxml should do that
272 (defun make-text-normalizer (next)
273 (make-instance 'text-normalizer :chained-handler next))
275 (defclass text-normalizer (cxml:sax-proxy)
276 ((pending-text-node :initform (make-string-output-stream)
277 :accessor pending-text-node)))
279 (defmethod sax:characters ((handler text-normalizer) data)
280 (write-string data (pending-text-node handler)))
282 (defun flush-pending (handler)
283 (let ((str (get-output-stream-string (pending-text-node handler))))
284 (unless (zerop (length str))
285 (sax:characters (cxml:proxy-chained-handler handler) str))))
287 (defmethod sax:start-element :before
288 ((handler text-normalizer) uri lname qname attributes)
289 (declare (ignore uri lname qname attributes))
290 (flush-pending handler))
292 (defmethod sax:end-element :before
293 ((handler text-normalizer) uri lname qname)
294 (declare (ignore uri lname qname))
295 (flush-pending handler))