1 ;;; -*- show-trailing-whitespace: t; indent-tabs: nil -*-
3 ;;; Copyright (c) 2007 David Lichteblau. All rights reserved.
5 ;;; Redistribution and use in source and binary forms, with or without
6 ;;; modification, are permitted provided that the following conditions
9 ;;; * Redistributions of source code must retain the above copyright
10 ;;; notice, this list of conditions and the following disclaimer.
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.
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.
29 (in-package :cxml-stp-impl
)
32 (declaim (optimize (debug 2)))
34 (defvar *check-uri-syntax
* nil
35 "If true (the default), a warning is issued if a string specified
36 as a namespace URI does not have URI syntax.")
37 (defun check-namespace-uri (uri)
38 (when (and *check-uri-syntax
*
39 (not (or (search "://" uri
)
40 (eql 4 (mismatch "uri:" uri
))
41 (eql 4 (mismatch "urn:" uri
)))))
42 (warn "namespace URI does not look like an absolute URL: ~S" uri
)))
44 (define-condition stp-error
(simple-error)
46 (:documentation
"The class of all STP errors."))
48 (defun stp-error (fmt &rest args
)
50 (error 'stp-error
:format-control fmt
:format-arguments args
))
55 (defgeneric string-value
(node)
57 "@arg[node]{an instance of @class{node}}
59 @short{Returns the string value of @code{node} as defined by XPath.}
61 For a document, this is the value of its root element.
63 For an element, the concatenation of the values of those child nodes
64 is returned that are elements or text nodes.
65 (Leaving only the PCDATA content.)
67 For a text, comment, and processing instruction nodes, the node's data
70 For an attribute, the attribute value is returned.
72 The value for document types is not specified."))
74 (defgeneric parent
(node)
76 "@arg[node]{an @class{node}}
77 @return{the parent node, or nil}
78 @short{Returns the node's parent.}"))
80 (defgeneric base-uri
(node)
82 "@arg[node]{an @class{node}}
84 @short{Returns the node's base URI.}"))
86 (defun cxml-stp:document
(node)
87 "@arg[node]{an instance of @class{node}}
88 @return{a @class{document} or nil}
89 @short{Returns the document node ancestor of @code{node}.}
91 Returns the @class{document} node that is the @fun{root} of @code{node}
92 or @code{nil} if the root node is not a document."
93 (check-type node node
)
95 for parent
= node then
(parent parent
)
96 while
(and parent
(not (typep parent
'cxml-stp
:document
)))
97 finally
(return parent
)))
100 "@arg[node]{an instance of @class{node}}
101 @return{a @class{node} or nil}
102 @short{Returns the root of the tree of nodes @code{node} is part of.}
104 In a complete document, this is an instance of @class{document}, but
105 a detached subtree can have any node as its root. In particular, the
106 argument itself is returned if it does not have a @fun{parent}."
107 (check-type node node
)
109 for p
= (parent node
) then
(parent p
)
114 ;; (defgeneric base-uri (node)) ;fixme: hier muessen wir wissen, ob specified
115 ;; (defmethod base-uri ((node node))
116 ;; (let ((parent (parent node)))
121 (defgeneric detach
(node)
123 "@arg[node]{a @class{node}}
124 @short{This function removes a child node or attribute.}
126 In contrast to functions for child nodes, this function can also remove
127 an attribute from its parent.
130 (defmethod detach ((node node
))
132 (delete-child node
(parent node
))))
134 (defgeneric copy
(node)
136 "@arg[node]{a @class{node}}
137 @short{This function copies a node recursively.}
139 The resulting node is of the same class as the argument, and all
140 child nodes and attributes are copied in the same way.
142 Shared structure includes only primitive slot values like strings.
143 (The consequences are undefined if user code mutates such values, whether
144 @code{copy} is used or not.)"))
146 (defgeneric serialize
(node handler
)
148 "@arg[node]{a @class{node}}
149 @short{This function generates SAX events representing @code{node}.}
151 Use this function together with a serialization sink to generate
152 a serialized XML document.
154 Examples. Serializing to a stream:
155 @begin{pre}CL-USER> (stp:serialize (stp:make-document (stp:make-element \"test\"))
156 (cxml:make-character-stream-sink *standard-output*))
157 <?xml version=\"1.0\" encoding=\"UTF-8\"?>
159 #<SWANK-BACKEND::SLIME-OUTPUT-STREAM {10037EA611@}>
161 Examples. Serializing to a string:
162 @begin{pre}CL-USER> (stp:serialize (stp:make-document (stp:make-element \"test\"))
163 (cxml:make-string-sink))
164 \"<?xml version=\\\"1.0\\\" encoding=\\\"UTF-8\\\"?>
168 @see{make-builder}"))
170 ;;; CHILDREN-related convenience functions
172 (defgeneric map-children
(result-type function node
)
174 "@arg[result-type]{a sequence type specifier, or nil}
175 @arg[function]{a designator for a function of one argument}
176 @arg[node]{a @class{node}}
177 @return{an sequence of @code{result-type}, or nil}
178 @short{Applies @code{function} to successive child nodes.}
180 The @code{result-type} specifies the type of the resulting sequence.
181 @code{map-children} returns nil if @code{result-type} is nil. Otherwise
182 it returns a sequence such that element i is the result of applying
183 @code{function} to child i of @class{node}."))
185 (defmacro do-children
((var node
&optional result
) &body body
)
186 "@arg[var]{symbol, a variable name}
187 @arg[node]{a @class{node}}
189 @return{the result of evaluating @code{result}}
190 Executes @code{body} with @code{var} bound to successive child
193 (map-children nil
(lambda (,var
) ,@body
) ,node
)
195 (declare (ignorable ,var
))
198 (defun list-children (node)
199 "@arg[node]{a @class{node}}
200 @return{a list of nodes}
201 Returns a freshly consed list containing the child nodes of @code{node}."
202 (map-children 'list
#'identity node
))
204 (defun nth-child (n parent
)
205 "@arg[n]{a non-negative integer}
206 @arg[parent]{a @class{node}}
207 @return{a @class{node}}
208 @short{Returns child node @code{n} of @code{parent}}, or signals an error
209 if n is negative or as large or larger that the number of child nodes."
210 (elt (%children parent
) n
))
212 (defun first-child (node)
213 "@arg[node]{a @class{node}}
214 @return{a @class{node} or nil}
215 Returns first child of @code{node}, or nil."
216 (let ((c (%children node
))) ;VECTOR or NIL, but not arbitrary list
217 (when (plusp (length c
))
220 (defun last-child (node)
221 "@arg[node]{a @class{node}}
222 @return{a @class{node} or nil}
223 Returns last child of @code{node}, or nil."
224 (let* ((c (%children node
)) ;VECTOR or NIL, but not arbitrary list
229 (defun previous-sibling (node)
230 "@arg[node]{a @class{node}}
231 @return{a @class{node} or nil}
232 @short{Returns the child preceding @code{node} in the child list of its
235 Signals an error if @code{node} has no parent or is the first child of its
237 (let ((p (parent node
)))
239 (stp-error "node has no parent"))
240 (let ((idx (1- (child-position node p
))))
242 (stp-error "node has no previous sibling"))
245 (defun next-sibling (node)
246 "@arg[node]{a @class{node}}
247 @return{a @class{node} or nil}
248 @short{Returns the child following @code{node} in the child list of its
251 Signals an error if @code{node} has no parent or is the last child of its
253 (let ((p (parent node
)))
255 (stp-error "node has no parent"))
256 (let ((idx (1+ (child-position node p
)))
258 (when (eql idx
(length c
))
259 (stp-error "node has no next sibling"))
262 (defun number-of-children (parent)
263 "@arg[parent]{a @class{node}}
264 @return{the number of child nodes}
265 Returns the number of @code{parent}'s child nodes.
266 @see{count-children}"
267 (length (%children parent
)))
269 (defun count-children
270 (value parent
&rest args
&key from-end
(start 0) end key test
)
271 "@arg[value]{an object}
272 @arg[parent]{a @class{node}}
273 @arg[from-end]{a generalized boolead}
274 @arg[start, end]{bounding index designators for @code{parent}'s child list}
275 @arg[key]{a designator for a function of one argument, or nil}
276 @arg[test]{a designator for a function of two arguments, or nil}
277 @return{a non-negative integer less than or equal to the number of
279 Counts (and returns the number of) @code{parent}'s child nodes satisfying
281 @see{number-of-children}
282 @see{count-children-if}"
283 (declare (ignore from-end start end key test
))
284 (apply #'count value
(%children parent
) args
))
286 (defun count-children-if
287 (predicate parent
&rest args
&key from-end
(start 0) end key
)
288 "@arg[predicate]{a designator for a function of one argument that returns
289 a generalized boolean}
290 @arg[parent]{a @class{node}}
291 @arg[from-end]{a generalized boolead}
292 @arg[start, end]{bounding index designators for @code{parent}'s child list}
293 @arg[key]{a designator for a function of one argument, or nil}
294 @return{a non-negative integer less than or equal to the number of
296 Counts (and returns the number of) @code{parent}'s child nodes satisfying
298 @see{number-of-children}
299 @see{count-children}"
300 (declare (ignore from-end start end key
))
301 (apply #'count-if predicate
(%children parent
) args
))
304 (value parent
&rest args
&key from-end
(start 0) end key test
)
305 "@arg[value]{an object}
306 @arg[parent]{a @class{node}}
307 @arg[from-end]{a generalized boolead}
308 @arg[start, end]{bounding index designators for @code{parent}'s child list}
309 @arg[key]{a designator for a function of one argument, or nil}
310 @arg[test]{a designator for a function of two arguments, or nil}
311 @return{a @class{node} or nil}
312 Searches for a child node of @code{parent} that satisfies the @code{test}
316 (declare (ignore from-end start end key test
))
317 (apply #'find value
(%children parent
) args
))
320 (predicate parent
&rest args
&key from-end
(start 0) end key
)
321 "@arg[predicate]{a designator for a function of one argument that returns
322 a generalized boolean}
323 @arg[parent]{a @class{node}}
324 @arg[from-end]{a generalized boolead}
325 @arg[start, end]{bounding index designators for @code{parent}'s child list}
326 @arg[key]{a designator for a function of one argument, or nil}
327 @return{a @class{node} or nil}
328 Searches for a child node of @code{parent} that satisfies @code{predicate}
332 (declare (ignore from-end start end key
))
333 (apply #'find-if predicate
(%children parent
) args
))
335 (defun child-position
336 (value parent
&rest args
&key from-end
(start 0) end key test
)
337 "@arg[value]{an object}
338 @arg[parent]{a @class{node}}
339 @arg[from-end]{a generalized boolead}
340 @arg[start, end]{bounding index designators for @code{parent}'s child list}
341 @arg[key]{a designator for a function of one argument, or nil}
342 @arg[test]{a designator for a function of two arguments, or nil}
343 @return{a @class{node} or nil}
344 Searches for a child node of @code{parent} that satisfies the @code{test}
345 and returns its position.
347 @see{child-position-if}"
348 (declare (ignore from-end start end key test
))
349 (apply #'position value
(%children parent
) args
))
351 (defun child-position-if
352 (predicate parent
&rest args
&key from-end
(start 0) end key
)
353 "@arg[predicate]{a designator for a function of one argument that returns
354 a generalized boolean}
355 @arg[parent]{a @class{node}}
356 @arg[from-end]{a generalized boolead}
357 @arg[start, end]{bounding index designators for @code{parent}'s child list}
358 @arg[key]{a designator for a function of one argument, or nil}
359 @arg[test]{a designator for a function of two arguments, or nil}
360 @return{a @class{node} or nil}
361 Searches for a child node of @code{parent} that satisfies the @code{test}
362 and returns its position.
364 @see{child-position}"
365 (declare (ignore from-end start end key
))
366 (apply #'position-if predicate
(%children parent
) args
))
368 (defun filter-children
369 (predicate parent
&rest args
&key from-end
(start 0) end count key
)
370 "@arg[predicate]{a designator for a function of one argument that returns
371 a generalized boolean}
372 @arg[parent]{a @class{node}}
373 @arg[from-end]{a generalized boolead}
374 @arg[start, end]{bounding index designators for @code{parent}'s child list}
375 @arg[key]{a designator for a function of one argument, or nil}
376 @arg[test]{a designator for a function of two arguments, or nil}
377 @arg[count]{an integer or nil}
378 @return{a sequence containing nodes}
379 @short{Return a list of child nodes of @code{parent} from which nodes that
380 do not satisfy @code{predicate} have been removed.}
382 This function returns the same list as @code{remove-if-not} on the result
383 of @fun{list-children}."
384 (declare (ignore from-end start end count key
))
385 (apply #'remove-if-not predicate
(list-children parent
) args
))
387 (defun map-recursively (fn node
)
388 "@arg[fn]{a designator for a function of one argument}
389 @arg[node]{a @class{node}}
391 Applies @code{fn} to successive descendants of @code{node} in
395 (lambda (c) (map-recursively fn c
))
398 (defmacro do-recursively
((var node
&optional result
) &body body
)
399 "@arg[var]{symbol, a variable name}
400 @arg[node]{a @class{node}}
402 @return{the result of evaluating @code{result}}
403 Executes @code{bode} with @code{var} bound to successive descendants of
404 @code{node} in pre-order."
406 (map-recursively (lambda (,var
) ,@body
) ,node
)
408 (declare (ignorable ,var
))
411 (defun find-recursively (item node
&key key test
)
412 "@arg[item]{an object}
413 @arg[node]{a @class{node}}
414 @arg[key]{a designator for a function of one argument, or nil}
415 @arg[test]{a designator for a function of two arguments, or nil}
416 @return{a @class{node} or nil}
417 Searches in pre-order for the first descendant of @code{node} that
418 satisfies the @code{test} and returns it.
421 (setf key
(or key
#'identity
))
422 (setf test
(or test
#'eql
))
423 (do-recursively (child node
)
424 (when (funcall test item
(funcall key child
))
427 (defun find-recursively-if (predicate node
&key key
)
428 "@arg[test]{a designator for a function of one argument that returns
429 a generalized boolean}
430 @arg[node]{a @class{node}}
431 @arg[key]{a designator for a function of one argument, or nil}
432 @return{a @class{node} or nil}
433 Searches in pre-order for the first descendant of @code{node} that
434 satisfies the @code{test} and returns it.
437 (setf key
(or key
#'identity
))
438 (do-recursively (child node
)
439 (when (funcall predicate
(funcall key child
))
442 (defun filter-recursively (test node
&key key
)
443 "@arg[test]{a designator for a function of one argument that returns
444 a generalized boolean}
445 @arg[node]{a @class{node}}
446 @arg[key]{a designator for a function of one argument, or nil}
447 @arg[test]{a designator for a function of two arguments, or nil}
448 @return{a sequence containing nodes}
449 Return a list of descendant nodes of @code{node} in pre-order, from which
450 nodes that do not satisfy @code{predicate} have been removed."
451 (setf key
(or key
#'identity
))
452 (setf test
(or test
#'eql
))
454 (do-recursively (child node
)
455 (when (funcall test
(funcall key child
))
456 (push child result
)))
462 ;;; (defun query (node xpath)
469 (defgeneric slots-for-print-object
(node)
470 (:method-combination append
))
472 (defun maybe-uri->string
(thing)
473 (if (puri:uri-p thing
)
474 (princ-to-string thing
)
475 (non-empty-string thing
)))
477 (defmethod slots-for-print-object append
((node parent-node
))
478 '((:base-uri %base-uri maybe-uri-
>string
)
479 (:children list-children identity
)))
481 (defmethod print-object ((object node
) stream
)
482 (when (and *print-readably
* (not *read-eval
*))
483 (error "cannot print STP nodes readably without *read-eval*"))
484 ;; zzz pretty printing on clisp introduces spurious closing parens
485 (if (and *print-pretty
* #+clisp nil
)
486 (pretty-print-node object stream
)
487 (ugly-print-node object stream
)))
489 (defun pretty-print-node (node stream
)
490 (let* ((slots (mapcan (lambda (spec)
491 (destructuring-bind (key fn
&optional test
) spec
492 (let ((value (funcall fn node
)))
493 (when (or (null test
) (funcall test value
))
494 (list (list key value
))))))
495 (slots-for-print-object node
)))
497 (intern (symbol-name (class-name (class-of node
))) :cxml-stp-impl
))
498 (level *print-level
*)
499 (length *print-length
*)
501 (*print-length
* nil
))
502 (pprint-logical-block (stream nil
:prefix
"#.(" :suffix
")")
503 (write constructor
:stream stream
)
505 (write-char #\space stream
)
506 (pprint-newline :linear stream
)
508 (format stream
"#| ~S of type ~A |#"
510 (type-of (parent node
))))
511 (let ((remaining-slots slots
))
512 (when remaining-slots
513 (write-char #\space stream
)
514 (pprint-newline :linear stream
)
517 (destructuring-bind (key value
) (pop remaining-slots
)
518 (write key
:stream stream
)
519 (write-char #\space stream
)
520 (pprint-newline :miser stream
)
521 (let ((*print-level
* level
)
522 (*print-length
* length
))
523 (unless (typep value
'(or string null
))
524 (write-char #\' stream
))
525 (write value
:stream stream
))
526 (when (null remaining-slots
)
528 (write-char #\space stream
)
529 (pprint-newline :linear stream
))))))))
531 (defun ugly-print-node (node stream
)
532 (let* ((slots (mapcan (lambda (spec)
533 (destructuring-bind (key fn
&optional test
) spec
534 (let ((value (funcall fn node
)))
535 (when (or (null test
) (funcall test value
))
536 (list (list key value
))))))
537 (slots-for-print-object node
)))
539 (intern (symbol-name (class-name (class-of node
))) :cxml-stp-impl
))
540 (level *print-level
*)
541 (length *print-length
*)
543 (*print-length
* nil
))
544 (write-string "#.(" stream
)
545 (write constructor
:stream stream
)
546 (let ((remaining-slots slots
))
547 (when remaining-slots
548 (write-char #\space stream
)
550 (destructuring-bind (key value
) (pop remaining-slots
)
551 (write key
:stream stream
)
552 (write-char #\space stream
)
553 (let ((*print-level
* level
)
554 (*print-length
* length
))
555 (unless (typep value
'(or string null
))
556 (write-char #\' stream
))
557 (write value
:stream stream
))
558 (when (null remaining-slots
)
560 (write-char #\space stream
)))))
561 (write-string ")" stream
)))
563 (defgeneric reconstruct
(node &key
&allow-other-keys
)
564 (:method-combination progn
))
566 (defmacro defreader
(name (&rest args
) &body body
)
567 (let ((fn (intern (symbol-name name
) :cxml-stp-impl
)))
569 (defun ,fn
(&rest keys
)
571 (let ((result (make-instance ',name
)))
572 (apply #'reconstruct result keys
)
574 (defmethod reconstruct
579 collect
(if (symbolp arg
)
580 `(,arg
(error "slot ~A missing in printed representation"