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
10 ;;; * Redistributions of source code must retain the above copyright
11 ;;; notice, this list of conditions and the following disclaimer.
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.
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.
30 (in-package :xuriella
)
32 (define-instruction xsl
:number
(args env
)
33 (destructuring-bind (&key level count from value format lang letter-value
34 grouping-separator grouping-size
)
36 (let ((count (and count
(compile-pattern count env
)))
37 (from (and from
(compile-pattern from env
)))
38 (value (and value
(compile-xpath value env
)))
39 (format (compile-avt (or format
"1") env
))
40 (lang (compile-avt (or lang
"") env
))
41 (letter-value (compile-avt (or letter-value
"foo") env
))
43 (and grouping-separator
(compile-avt grouping-separator env
)))
44 (grouping-size (and grouping-size
(compile-avt grouping-size env
))))
46 (let ((value (when value
49 (funcall value ctx
))))
53 (format (funcall format ctx
))
54 (lang (funcall lang ctx
))
55 (letter-value (funcall letter-value ctx
))
56 (grouping-separator (when grouping-separator
57 (funcall grouping-separator ctx
)))
58 (grouping-size (when grouping-size
60 (funcall grouping-size ctx
)))))
65 (compute-number-list (or level
"single")
66 (xpath::context-node ctx
)
75 (defun compile-pattern (str env
)
79 ,@(mapcar #'naive-pattern-expression
(parse-pattern str
))))
82 (defun pattern-thunk-matches-p (pattern-thunk node
)
84 (xpath:all-nodes
(funcall pattern-thunk
(xpath:make-context node
)))))
86 (defun ancestors-using-count-and-from (node count from
)
89 (funcall (xpath::axis-function
:ancestor-or-self
) node
))))
90 (remove-if-not (lambda (ancestor)
91 (pattern-thunk-matches-p count ancestor
))
95 when
(pattern-thunk-matches-p from a
)
98 finally
(return ancestors
))
101 (defun node-position-among-siblings (node count
)
103 (count-if (lambda (sibling)
104 (pattern-thunk-matches-p count sibling
))
106 (funcall (xpath::axis-function
:preceding-sibling
) node
)))))
108 (defun compute-number-list (level node count from
)
111 (let ((uri (xpath-protocol:namespace-uri node
))
112 (lname (xpath-protocol:local-name node
)))
114 (let ((node (xpath:context-node ctx
)))
115 (xpath-sys:make-node-set
116 (if (and (xpath-protocol:node-type-p node
:element
)
117 (equal (xpath-protocol:namespace-uri node
) uri
)
118 (equal (xpath-protocol:local-name node
) lname
))
122 ((equal level
"single")
123 (let ((ancestor (car (ancestors-using-count-and-from node count from
))))
125 (list (node-position-among-siblings ancestor count
))
127 ((equal level
"multiple")
128 (mapcar (lambda (ancestor)
129 (node-position-among-siblings ancestor count
))
131 (ancestors-using-count-and-from node count from
))))
133 (destructuring-bind (root)
134 (xpath::force
(funcall (xpath::axis-function
:root
) node
))
135 (let ((nodes (xpath::force
137 (xpath::subpipe-before
139 (funcall (xpath::axis-function
:descendant-or-self
) root
))
143 for
(current . rest
) on nodes
144 when
(pattern-thunk-matches-p from current
)
150 count
(pattern-thunk-matches-p count n
))))))
152 (xslt-error "invalid number level: ~A" level
))))
154 (xpath::deflexer
(format-lexer :ignore-whitespace nil
)
155 ;; zzz just enough unicode "support" here to pass the tests
156 (#.
(format nil
"([a-zA-Z0-9~A]+)" (code-char 945)) (x) (values :format x
))
157 (#.
(format nil
"([^a-zA-Z0-9~A]+)" (code-char 945)) (x) (values :text x
)))
159 (defun format-number-token (str n
)
163 ;; zzz just enough unicode "support" here to pass the tests
164 (equal str
#.
(string (code-char 945))))
165 (let ((start (char-code (elt str
0))))
167 (xslt-error "cannot format zero"))
169 (with-output-to-string (r)
172 for
(rest digit
) = (multiple-value-list (truncate m
26))
176 (write-char (code-char (+ start digit
)) r
))
178 (write-char (code-char (+ start digit -
1)) r
)
183 (format nil
"~(~@R~)" n
)))
187 (format nil
"~@R" n
)))
189 (unless (cl-ppcre:all-matches
"^0*1$" str
)
190 ;; unsupported format
192 (format nil
"~v,'0D" (length str
) n
))))
194 (defun group-numbers (str separator size stream
)
197 for i from
(1- (length str
)) downto
0
199 (write-char c stream
)
200 (when (and (zerop (mod i size
)) (plusp i
))
201 (write-string separator stream
))))
203 ;;; fixme: unicode support
204 (defun format-number-list
205 (list format lang letter-value grouping-separator grouping-size
)
206 (declare (ignore lang letter-value
))
207 (if (some #'xpath
::nan-p list
)
209 (multiple-value-bind (prefix pairs suffix
)
210 (parse-number-format format
)
211 (with-output-to-string (s)
212 (write-string prefix s
)
214 for
(separator . subformat
) in pairs
216 for formatted
= (format-number-token subformat n
)
219 (write-string separator s
))
220 (if (and grouping-separator
222 (group-numbers formatted
226 (write-string formatted s
)))
227 (write-string suffix s
)))))
229 (defun parse-number-format (format)
230 (let ((lexer (format-lexer format
))
236 (multiple-value-bind (type str
) (funcall lexer
)
242 (setf current-text str
)
245 (push (cons (if conses
246 (or current-text
".")
250 (setf current-text nil
)))))
252 (setf suffix current-text
))
254 (setf conses
(list (cons nil
"1"))))
255 (let* ((tail-cons (car conses
))
256 (tail (if (car tail-cons
)
258 (push (cons "." (cdr tail-cons
)) conses
))))
259 (setf conses
(nreverse conses
))
260 (setf (cdr tail
) tail
))
261 (values prefix conses suffix
)))