Commit | Line | Data |
---|---|---|
8cd39fb3 MH |
1 | ;;; rng-xsd.el --- W3C XML Schema datatypes library for RELAX NG |
2 | ||
3 | ;; Copyright (C) 2003 Free Software Foundation, Inc. | |
4 | ||
5 | ;; Author: James Clark | |
6 | ;; Keywords: XML, RelaxNG | |
7 | ||
8 | ;; This program is free software; you can redistribute it and/or | |
9 | ;; modify it under the terms of the GNU General Public License as | |
10 | ;; published by the Free Software Foundation; either version 2 of | |
11 | ;; the License, or (at your option) any later version. | |
12 | ||
13 | ;; This program is distributed in the hope that it will be | |
14 | ;; useful, but WITHOUT ANY WARRANTY; without even the implied | |
15 | ;; warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR | |
16 | ;; PURPOSE. See the GNU General Public License for more details. | |
17 | ||
18 | ;; You should have received a copy of the GNU General Public | |
19 | ;; License along with this program; if not, write to the Free | |
20 | ;; Software Foundation, Inc., 59 Temple Place, Suite 330, Boston, | |
21 | ;; MA 02111-1307 USA | |
22 | ||
23 | ;;; Commentary: | |
24 | ||
25 | ;; The main entry point is `rng-xsd-compile'. The validator | |
26 | ;; knows to use this for the datatype library with URI | |
27 | ;; http://www.w3.org/2001/XMLSchema-datatypes because it | |
28 | ;; is the value of the rng-dt-compile property on that URI | |
29 | ;; as a symbol. | |
30 | ;; | |
31 | ;; W3C XML Schema Datatypes are specified by | |
32 | ;; http://www.w3.org/TR/xmlschema-2/ | |
33 | ;; Guidelines for using them with RELAX NG are described in | |
34 | ;; http://relaxng.org/xsd.html | |
35 | ||
36 | ;;; Code: | |
37 | ||
38 | (require 'rng-dt) | |
39 | (require 'rng-util) | |
40 | (require 'xsd-regexp) | |
41 | ||
42 | ;;;###autoload | |
43 | (put 'http://www.w3.org/2001/XMLSchema-datatypes | |
44 | 'rng-dt-compile | |
45 | 'rng-xsd-compile) | |
46 | ||
47 | ;;;###autoload | |
48 | (defun rng-xsd-compile (name params) | |
49 | "Provides W3C XML Schema as a RELAX NG datatypes library. NAME is a | |
50 | symbol giving the local name of the datatype. PARAMS is a list of | |
51 | pairs (PARAM-NAME . PARAM-VALUE) where PARAM-NAME is a symbol giving | |
52 | the name of the parameter and PARAM-VALUE is a string giving its | |
53 | value. If NAME or PARAMS are invalid, it calls rng-dt-error passing | |
54 | it arguments in the same style as format; the value from rng-dt-error | |
55 | will be returned. Otherwise, it returns a list. The first member of | |
56 | the list is t if any string is a legal value for the datatype and nil | |
57 | otherwise. The second argument is a symbol; this symbol will be | |
58 | called as a function passing it a string followed by the remaining | |
59 | members of the list. The function must return an object representing | |
60 | the value of the datatype that was represented by the string, or nil | |
61 | if the string is not a representation of any value. The object | |
62 | returned can be any convenient non-nil value, provided that, if two | |
63 | strings represent the same value, the returned objects must be equal." | |
64 | (let ((convert (get name 'rng-xsd-convert))) | |
65 | (if (not convert) | |
66 | (rng-dt-error "There is no XSD datatype named %s" name) | |
67 | (rng-xsd-compile1 name params convert)))) | |
68 | ||
69 | ;;; Parameters | |
70 | ||
71 | (defun rng-xsd-compile1 (name params convert) | |
72 | (if (null params) | |
73 | (cons (equal convert '(identity)) | |
74 | (cond ((eq name 'string) convert) | |
75 | ((eq name 'normalizedString) | |
76 | (cons 'rng-xsd-replace-space convert)) | |
77 | ((and (not (eq name 'string)) | |
78 | (or (memq 'identity convert) | |
79 | (memq 'rng-xsd-convert-any-uri convert) | |
80 | (memq 'rng-xsd-check-pattern convert))) | |
81 | (cons 'rng-xsd-collapse-space convert)) | |
82 | (t convert))) | |
83 | (let* ((param (car params)) | |
84 | (param-name (car param)) | |
85 | (param-value (cdr param))) | |
86 | (cond ((memq param-name | |
87 | '(minExclusive maxExclusive minInclusive maxInclusive)) | |
88 | (let ((limit (apply (car convert) | |
89 | (cons param-value | |
90 | (cdr convert)))) | |
91 | (less-than-fun (get name 'rng-xsd-less-than))) | |
92 | (cond ((not limit) | |
93 | (rng-dt-error "Minimum value %s is not valid" | |
94 | param-value)) | |
95 | ((not less-than-fun) | |
96 | (rng-dt-error "Values of type %s are not ordered" | |
97 | param-name)) | |
98 | (t | |
99 | (rng-xsd-compile1 name | |
100 | (cdr params) | |
101 | (cons (get param-name | |
102 | 'rng-xsd-check) | |
103 | (cons less-than-fun | |
104 | (cons limit convert)))))))) | |
105 | ((memq param-name '(length minLength maxLength)) | |
106 | (let ((limit (rng-xsd-string-to-non-negative-integer param-value)) | |
107 | (length-fun (get name 'rng-xsd-length))) | |
108 | (cond ((not limit) | |
109 | (rng-dt-error "Length %s is not valid" param-value)) | |
110 | ((not length-fun) | |
111 | (rng-dt-error "Values of type %s do not have a length" | |
112 | param-name)) | |
113 | (t | |
114 | (rng-xsd-compile1 name | |
115 | (cdr params) | |
116 | (cons (get param-name | |
117 | 'rng-xsd-check) | |
118 | (cons length-fun | |
119 | (cons limit convert)))))))) | |
120 | ((memq param-name '(fractionDigits totalDigits)) | |
121 | (let ((n (rng-xsd-string-to-non-negative-integer param-value))) | |
122 | (cond ((not n) | |
123 | (rng-dt-error "Number of digits %s is not valid" | |
124 | param-value)) | |
125 | (t | |
126 | (rng-xsd-compile1 name | |
127 | (cdr params) | |
128 | (cons (get param-name | |
129 | 'rng-xsd-check) | |
130 | (cons n convert))))))) | |
131 | ((eq param-name 'pattern) | |
132 | (condition-case err | |
133 | (rng-xsd-compile1 name | |
134 | (cdr params) | |
135 | (cons 'rng-xsd-check-pattern | |
136 | (cons (concat | |
137 | "\\`" | |
138 | (xsdre-translate param-value) | |
139 | "\\'") | |
140 | convert))) | |
141 | (xsdre-invalid-regexp | |
142 | (rng-dt-error "Invalid regular expression (%s)" | |
143 | (nth 1 err))))) | |
144 | ((memq param-name '(enumeration whiteSpace)) | |
145 | (rng-dt-error "Facet %s cannot be used in RELAX NG" param-name)) | |
146 | (t (rng-dt-error "Unknown facet %s" param-name)))))) | |
147 | ||
148 | (defun rng-xsd-string-to-non-negative-integer (str) | |
149 | (and (rng-xsd-convert-integer str) | |
150 | (let ((n (string-to-number str))) | |
151 | (and (integerp n) | |
152 | (>= n 0) | |
153 | n)))) | |
154 | ||
155 | (defun rng-xsd-collapse-space (str convert &rest args) | |
156 | (apply convert (cons (mapconcat 'identity (split-string str "[ \t\n\r]+") | |
157 | " ") | |
158 | args))) | |
159 | ||
160 | (defun rng-xsd-replace-space (str convert &rest args) | |
161 | (apply convert | |
162 | (cons (let ((i 0) | |
163 | copied) | |
164 | (while (and (setq i (string-match "[\r\n\t]" str i)) | |
165 | (or copied (setq copied (copy-sequence str))) | |
166 | (aset copied i 32) | |
167 | (setq i (1+ i)))) | |
168 | (or copied str)) | |
169 | args))) | |
170 | ||
171 | (put 'minExclusive 'rng-xsd-check 'rng-xsd-check-min-exclusive) | |
172 | (put 'minInclusive 'rng-xsd-check 'rng-xsd-check-min-inclusive) | |
173 | (put 'maxExclusive 'rng-xsd-check 'rng-xsd-check-max-exclusive) | |
174 | (put 'maxInclusive 'rng-xsd-check 'rng-xsd-check-max-inclusive) | |
175 | (put 'length 'rng-xsd-check 'rng-xsd-check-length) | |
176 | (put 'minLength 'rng-xsd-check 'rng-xsd-check-min-length) | |
177 | (put 'maxLength 'rng-xsd-check 'rng-xsd-check-max-length) | |
178 | (put 'fractionDigits 'rng-xsd-check 'rng-xsd-check-fraction-digits) | |
179 | (put 'totalDigits 'rng-xsd-check 'rng-xsd-check-total-digits) | |
180 | ||
181 | (defun rng-xsd-check-min-exclusive (str less-than-fun limit convert &rest args) | |
182 | (let ((obj (apply convert (cons str args)))) | |
183 | (and obj | |
184 | (funcall less-than-fun limit obj) | |
185 | obj))) | |
186 | ||
187 | (defun rng-xsd-check-min-inclusive (str less-than-fun limit convert &rest args) | |
188 | (let ((obj (apply convert (cons str args)))) | |
189 | (and obj | |
190 | (or (funcall less-than-fun limit obj) | |
191 | (equal limit obj)) | |
192 | obj))) | |
193 | ||
194 | (defun rng-xsd-check-max-exclusive (str less-than-fun limit convert &rest args) | |
195 | (let ((obj (apply convert (cons str args)))) | |
196 | (and obj | |
197 | (funcall less-than-fun obj limit) | |
198 | obj))) | |
199 | ||
200 | (defun rng-xsd-check-max-inclusive (str less-than-fun limit convert &rest args) | |
201 | (let ((obj (apply convert (cons str args)))) | |
202 | (and obj | |
203 | (or (funcall less-than-fun obj limit) | |
204 | (equal obj limit)) | |
205 | obj))) | |
206 | ||
207 | (defun rng-xsd-check-min-length (str length-fun limit convert &rest args) | |
208 | (let ((obj (apply convert (cons str args)))) | |
209 | (and obj | |
210 | (>= (funcall length-fun obj) limit) | |
211 | obj))) | |
212 | ||
213 | (defun rng-xsd-check-max-length (str length-fun limit convert &rest args) | |
214 | (let ((obj (apply convert (cons str args)))) | |
215 | (and obj | |
216 | (<= (funcall length-fun obj) limit) | |
217 | obj))) | |
218 | ||
219 | (defun rng-xsd-check-length (str length-fun len convert &rest args) | |
220 | (let ((obj (apply convert (cons str args)))) | |
221 | (and obj | |
222 | (= (funcall length-fun obj) len) | |
223 | obj))) | |
224 | ||
225 | (defun rng-xsd-check-fraction-digits (str n convert &rest args) | |
226 | (let ((obj (apply convert (cons str args)))) | |
227 | (and obj | |
228 | (<= (length (aref obj 2)) n) | |
229 | obj))) | |
230 | ||
231 | (defun rng-xsd-check-total-digits (str n convert &rest args) | |
232 | (let ((obj (apply convert (cons str args)))) | |
233 | (and obj | |
234 | (<= (+ (length (aref obj 1)) | |
235 | (length (aref obj 2))) | |
236 | n) | |
237 | obj))) | |
238 | ||
239 | (defun rng-xsd-check-pattern (str regexp convert &rest args) | |
240 | (and (string-match regexp str) | |
241 | (apply convert (cons str args)))) | |
242 | ||
243 | ||
244 | (defun rng-xsd-convert-boolean (string) | |
245 | (and (string-match "\\`[ \t\n\r]*\\(?:\\(true\\|1\\)\\|false\\|0\\)[ \t\n\r]*\\'" string) | |
246 | (if (match-beginning 1) 'true 'false))) | |
247 | ||
248 | (defun rng-xsd-convert-decimal (string) | |
249 | "Convert a string representing a decimal to an object representing | |
250 | its values. A decimal value is represented by a vector [SIGN | |
251 | INTEGER-DIGITS FRACTION-DIGITS] where SIGN is 1 or -1, INTEGER-DIGITS | |
252 | is a string containing zero or more digits, with no leading zero, and | |
253 | FRACTION-DIGITS is a string containing zero or more digits with no | |
254 | trailing digits. For example, -0021.0430 would be represented by [-1 | |
255 | \"21\" \"043\"]." | |
256 | (and (string-match "\\`[ \t\n\r]*\\([-+]\\)?\\(0*\\([1-9][0-9]*\\)?\\(\\.\\([0-9]*[1-9]\\)?0*\\)?\\)[ \t\n\r]*\\'" string) | |
257 | (let ((digits (match-string 2 string))) | |
258 | (and (not (string= digits ".")) | |
259 | (not (string= digits "")))) | |
260 | (let ((integer-digits (match-string 3 string))) | |
261 | (vector (if (and (equal (match-string 1 string) "-") | |
262 | ;; Normalize -0 to 0 | |
263 | integer-digits) | |
264 | -1 | |
265 | 1) | |
266 | (or integer-digits "") | |
267 | (or (match-string 5 string) ""))))) | |
268 | ||
269 | (defun rng-xsd-convert-integer (string) | |
270 | (and (string-match "\\`[ \t\n\r]*\\([-+]\\)?\\(?:0*\\([1-9][0-9]*\\)\\|0+\\)[ \t\n\r]*\\'" string) | |
271 | (let ((integer-digits (match-string 2 string))) | |
272 | (vector (if (and (equal (match-string 1 string) "-") | |
273 | ;; Normalize -0 to 0 | |
274 | integer-digits) | |
275 | -1 | |
276 | 1) | |
277 | (or integer-digits "") | |
278 | "")))) | |
279 | ||
280 | (defun rng-xsd-decimal< (n1 n2) | |
281 | (< (rng-xsd-compare-decimal n1 n2) 0)) | |
282 | ||
283 | (defun rng-xsd-compare-decimal (n1 n2) | |
284 | "Return a < 0, 0, > 0 according as n1 < n2, n1 = n2 or n1 > n2." | |
285 | (let* ((sign1 (aref n1 0)) | |
286 | (sign2 (aref n2 0)) | |
287 | (sign (- sign1 sign2))) | |
288 | (if (= sign 0) | |
289 | (* sign1 | |
290 | (let* ((int1 (aref n1 1)) | |
291 | (int2 (aref n2 1)) | |
292 | (len1 (length int1)) | |
293 | (len2 (length int2)) | |
294 | (lencmp (- len1 len2))) | |
295 | (if (eq lencmp 0) | |
296 | (if (string= int1 int2) | |
297 | (rng-xsd-strcmp (aref n1 2) (aref n2 2)) | |
298 | (rng-xsd-strcmp int1 int2)) | |
299 | lencmp))) | |
300 | sign))) | |
301 | ||
302 | (defconst rng-xsd-float-regexp | |
303 | (concat "\\`[ \r\n\t]*\\(?:" | |
304 | "\\(" | |
305 | "[-+]?\\(?:[0-9]+\\(?:\\.[0-9]*\\)?\\|\\.[0-9]+\\)" | |
306 | "\\(?:[eE][-+]?[0-9]+\\)?" | |
307 | "\\)" | |
308 | "\\|\\(INF\\)" | |
309 | "\\|\\(-INF\\)" | |
310 | "\\|\\(NaN\\)" | |
311 | "\\)[ \r\n\t]*\\'")) | |
312 | ||
313 | (defun rng-xsd-convert-float (string) | |
314 | (cond ((not (string-match rng-xsd-float-regexp string)) nil) | |
315 | ((match-beginning 1) | |
316 | (float (string-to-number (match-string 1 string)))) | |
317 | ((match-beginning 2) 1.0e+INF) | |
318 | ((match-beginning 3) -1.0e+INF) | |
319 | ;; Don't use a NaN float because we want NaN to be equal to NaN | |
320 | ((match-beginning 4) 'NaN))) | |
321 | ||
322 | (defun rng-xsd-float< (f1 f2) | |
323 | (and (not (eq f1 'NaN)) | |
324 | (not (eq f2 'NaN)) | |
325 | (< f1 f2))) | |
326 | ||
327 | (defun rng-xsd-convert-token (string regexp) | |
328 | (and (string-match regexp string) | |
329 | (match-string 1 string))) | |
330 | ||
331 | (defun rng-xsd-convert-hex-binary (string) | |
332 | (and (string-match "\\`[ \r\n\t]*\\(\\(?:[0-9A-Fa-f][0-9A-Fa-f]\\)*\\)[ \r\n\t]*\\'" | |
333 | string) | |
334 | (downcase (match-string 1 string)))) | |
335 | ||
336 | (defun rng-xsd-hex-binary-length (obj) | |
337 | (/ (length obj) 2)) | |
338 | ||
339 | (defconst rng-xsd-base64-binary-regexp | |
340 | (let ((S "[ \t\r\n]*") | |
341 | (B04 "[AQgw]") | |
342 | (B16 "[AEIMQUYcgkosw048]") | |
343 | (B64 "[A-Za-z0-9+/]")) | |
344 | (concat "\\`" S "\\(?:\\(?:" B64 S "\\)\\{4\\}\\)*" | |
345 | "\\(?:" B64 S B64 S B16 S "=" S | |
346 | "\\|" B64 S B04 S "=" S "=" S "\\)?\\'"))) | |
347 | ||
348 | (defun rng-xsd-convert-base64-binary (string) | |
349 | (and (string-match rng-xsd-base64-binary-regexp string) | |
350 | (replace-regexp-in-string "[ \t\r\n]+" "" string t t))) | |
351 | ||
352 | (defun rng-xsd-base64-binary-length (obj) | |
353 | (let ((n (* (/ (length obj) 4) 3))) | |
354 | (if (and (> n 0) | |
355 | (string= (substring obj -1) "=")) | |
356 | (- n (if (string= (substring obj -2) "==") | |
357 | 2 | |
358 | 1)) | |
359 | n))) | |
360 | ||
361 | (defun rng-xsd-convert-any-uri (string) | |
362 | (and (string-match "\\`\\(?:[^%]\\|%[0-9a-fA-F][0-9a-fA-F]\\)?*\\'" string) | |
363 | (string-match "\\`[^#]*\\(?:#[^#]*\\)?\\'" string) | |
364 | (string-match "\\`\\(?:[a-zA-Z][-+.A-Za-z0-9]*:.+\\|[^:]*\\(?:[#/?].*\\)?\\)\\'" string) | |
365 | string)) | |
366 | ||
367 | (defun rng-xsd-make-date-time-regexp (template) | |
368 | "Returns a regular expression matching a ISO 8601 date/time. The | |
369 | template is a string with Y standing for years field, M standing for | |
370 | months, D standing for day of month, T standing for a literal T, t | |
371 | standing for time and - standing for a literal hyphen. A time zone is | |
372 | always allowed at the end. Regardless of the fields appearing in the | |
373 | template, the regular expression will have twelve groups matching the | |
374 | year sign, year, month, day of month, hours, minutes, integer seconds, | |
375 | fractional seconds (including leading period), time zone, time zone | |
376 | sign, time zone hours, time zone minutes." | |
377 | (let ((i 0) | |
378 | (len (length template)) | |
379 | (parts nil) | |
380 | first last c) | |
381 | (while (< i len) | |
382 | (setq c (aref template i)) | |
383 | (setq parts | |
384 | (cons (cond ((eq c ?Y) | |
385 | (setq first 0) | |
386 | (setq last 1) | |
387 | "\\(-\\)?\\(\\(?:[1-9][0-9]*\\)?[0-9]\\{4\\}\\)") | |
388 | ((eq c ?M) | |
389 | (or first | |
390 | (setq first 2)) | |
391 | (setq last 2) | |
392 | "\\([0-9][0-9]\\)") | |
393 | ((eq c ?D) | |
394 | (or first | |
395 | (setq first 3)) | |
396 | (setq last 3) | |
397 | "\\([0-9][0-9]\\)") | |
398 | ((eq c ?t) | |
399 | (or first | |
400 | (setq first 4)) | |
401 | (setq last 7) | |
402 | "\\([0-9][0-9]\\):\\([0-9][0-9]\\):\\([0-9][0-9]\\)\\(\\.[0-9]*\\)?") | |
403 | (t (string c))) | |
404 | parts)) | |
405 | (setq i (1+ i))) | |
406 | (while (< last 7) | |
407 | (setq last (1+ last)) | |
408 | ;; Add dummy fields that can never much but keep the group | |
409 | ;; numbers uniform. | |
410 | (setq parts (cons "\\(\\'X\\)?" parts))) | |
411 | (setq parts (cons "\\(Z\\|\\([-+]\\)\\([0-9][0-9]\\):\\([0-5][0-9]\\)\\)?[ \t\n\r]*\\'" | |
412 | parts)) | |
413 | (setq parts (cons "\\`[ \t\n\r]*" (nreverse parts))) | |
414 | (while (> first 0) | |
415 | (setq first (1- first)) | |
416 | (setq parts (cons "\\(X\\)?" parts))) | |
417 | (apply 'concat parts))) | |
418 | ||
419 | (defconst rng-xsd-seconds-per-day (* 24 60 60)) | |
420 | (defconst rng-xsd-days-in-month [31 28 31 30 31 30 31 31 30 31 30 31]) | |
421 | ||
422 | (defun rng-xsd-days-in-month (year month) | |
423 | (if (and (= month 2) (rng-xsd-leap-year-p year)) | |
424 | 29 | |
425 | (aref rng-xsd-days-in-month (1- month)))) | |
426 | ||
427 | (defconst rng-xsd-months-to-days | |
428 | (let ((v (make-vector 12 nil)) | |
429 | (total 0) | |
430 | (i 0)) | |
431 | (while (< i 12) | |
432 | (setq total (+ total (aref rng-xsd-days-in-month i))) | |
433 | (aset v i total) | |
434 | (setq i (1+ i))) | |
435 | v)) | |
436 | ||
437 | (defun rng-xsd-convert-date-time (string regexp) | |
438 | "Converts an XML Schema date/time to a list. Returns nil if | |
439 | invalid. REGEXP is a regexp for parsing the date time as returned by | |
440 | `rng-xsd-make-date-time-regexp'. The list has 4 members (HAS-TIME-ZONE | |
441 | DAY SECOND SECOND-FRACTION), where HAS-TIME-ZONE is t or nil depending | |
442 | on whether a time zone was specified, DAY is an integer giving a day | |
443 | number (with Jan 1 1AD being day 1), SECOND is the second within that | |
444 | day, and SECOND-FRACTION is a float giving the fractional part of the | |
445 | second." | |
446 | (and (string-match regexp string) | |
447 | (let ((year-sign (match-string 1 string)) | |
448 | (year (match-string 2 string)) | |
449 | (month (match-string 3 string)) | |
450 | (day (match-string 4 string)) | |
451 | (hour (match-string 5 string)) | |
452 | (minute (match-string 6 string)) | |
453 | (second (match-string 7 string)) | |
454 | (second-fraction (match-string 8 string)) | |
455 | (has-time-zone (match-string 9 string)) | |
456 | (time-zone-sign (match-string 10 string)) | |
457 | (time-zone-hour (match-string 11 string)) | |
458 | (time-zone-minute (match-string 12 string))) | |
459 | (setq year-sign (if year-sign -1 1)) | |
460 | (setq year | |
461 | (if year | |
462 | (* year-sign | |
463 | (string-to-number year)) | |
464 | 2000)) | |
465 | (setq month | |
466 | (if month (string-to-number month) 1)) | |
467 | (setq day | |
468 | (if day (string-to-number day) 1)) | |
469 | (setq hour | |
470 | (if hour (string-to-number hour) 0)) | |
471 | (setq minute | |
472 | (if minute (string-to-number minute) 0)) | |
473 | (setq second | |
474 | (if second (string-to-number second) 0)) | |
475 | (setq second-fraction | |
476 | (if second-fraction | |
477 | (float (string-to-number second-fraction)) | |
478 | 0.0)) | |
479 | (setq has-time-zone (and has-time-zone t)) | |
480 | (setq time-zone-sign | |
481 | (if (equal time-zone-sign "-") -1 1)) | |
482 | (setq time-zone-hour | |
483 | (if time-zone-hour (string-to-number time-zone-hour) 0)) | |
484 | (setq time-zone-minute | |
485 | (if time-zone-minute (string-to-number time-zone-minute) 0)) | |
486 | (and (>= month 1) | |
487 | (<= month 12) | |
488 | (>= day 1) | |
489 | (<= day (rng-xsd-days-in-month year month)) | |
490 | (<= hour 23) | |
491 | (<= minute 59) | |
492 | (<= second 60) ; leap second | |
493 | (<= time-zone-hour 23) | |
494 | (<= time-zone-minute 59) | |
495 | (cons has-time-zone | |
496 | (rng-xsd-add-seconds | |
497 | (list (rng-xsd-date-to-days year month day) | |
498 | (rng-xsd-time-to-seconds hour minute second) | |
499 | second-fraction) | |
500 | (* (rng-xsd-time-to-seconds time-zone-hour | |
501 | time-zone-minute | |
502 | 0) | |
503 | (- time-zone-sign)))))))) | |
504 | ||
505 | (defun rng-xsd-leap-year-p (year) | |
506 | (and (= (% year 4) 0) | |
507 | (or (/= (% year 100) 0) | |
508 | (= (% year 400) 0)))) | |
509 | ||
510 | (defun rng-xsd-time-to-seconds (hour minute second) | |
511 | (+ (* (+ (* hour 60) | |
512 | minute) | |
513 | 60) | |
514 | second)) | |
515 | ||
516 | (defconst rng-xsd-max-tz (rng-xsd-time-to-seconds 14 0 0)) | |
517 | ||
518 | (defun rng-xsd-date-time< (dt1 dt2) | |
519 | (cond ((eq (car dt1) (car dt2)) | |
520 | (rng-xsd-number-list< (cdr dt1) (cdr dt2))) | |
521 | ((car dt1) | |
522 | (rng-xsd-number-list< (cdr dt1) | |
523 | (rng-xsd-add-seconds (cdr dt2) | |
524 | (- rng-xsd-max-tz)))) | |
525 | (t | |
526 | (rng-xsd-number-list< (rng-xsd-add-seconds (cdr dt1) | |
527 | rng-xsd-max-tz) | |
528 | (cdr dt2))))) | |
529 | ||
530 | (defun rng-xsd-add-seconds (date offset) | |
531 | (let ((day (nth 0 date)) | |
532 | (second (+ (nth 1 date) offset)) | |
533 | (fraction (nth 2 date))) | |
534 | (cond ((< second 0) | |
535 | (list (1- day) | |
536 | (+ second rng-xsd-seconds-per-day) | |
537 | fraction)) | |
538 | ((>= second rng-xsd-seconds-per-day) | |
539 | (list (1+ day) | |
540 | (- second rng-xsd-seconds-per-day) | |
541 | fraction)) | |
542 | (t (list day second fraction))))) | |
543 | ||
544 | (defun rng-xsd-number-list< (numbers1 numbers2) | |
545 | (while (and numbers1 (= (car numbers1) (car numbers2))) | |
546 | (setq numbers1 (cdr numbers1)) | |
547 | (setq numbers2 (cdr numbers2))) | |
548 | (and numbers1 | |
549 | (< (car numbers1) (car numbers2)))) | |
550 | ||
551 | (defun rng-xsd-date-to-days (year month day) | |
552 | "Return a unique day number where Jan 1 1 AD is day 1" | |
553 | (if (> year 0) ; AD | |
554 | (+ (rng-xsd-days-in-years (- year 1)) | |
555 | (rng-xsd-day-number-in-year year month day)) | |
556 | (- (+ (- (rng-xsd-days-in-years (- 3 year)) | |
557 | (rng-xsd-days-in-years 3)) | |
558 | (- (if (rng-xsd-leap-year-p year) 366 365) | |
559 | (rng-xsd-day-number-in-year year month day)))))) | |
560 | ||
561 | (defun rng-xsd-days-in-years (years) | |
562 | "The number of days in YEARS years where the first year is 1AD." | |
563 | (+ (* 365 years) | |
564 | (/ years 4) | |
565 | (- (/ years 100)) | |
566 | (/ years 400))) | |
567 | ||
568 | (defun rng-xsd-day-number-in-year (year month day) | |
569 | (+ (if (= month 1) | |
570 | 0 | |
571 | (aref rng-xsd-months-to-days (- month 2))) | |
572 | day | |
573 | (if (and (> month 2) | |
574 | (rng-xsd-leap-year-p year)) | |
575 | 1 | |
576 | 0))) | |
577 | ||
578 | (defconst rng-xsd-duration-regexp | |
579 | "\\`[ \t\r\n]*\\(-\\)?P\ | |
580 | \\([0-9]+Y\\)?\\([0-9]+M\\)?\\([0-9]+D\\)?\ | |
581 | \\(?:T\\([0-9]+H\\)?\\([0-9]+M\\)?\ | |
582 | \\(\\([0-9]+\\(?:\\.[0-9]*\\)?\\|\\.[0-9]+\\)S\\)?\\)?\ | |
583 | [ \t\r\n]*\\'") | |
584 | ||
585 | ||
586 | (defun rng-xsd-convert-duration (string) | |
587 | (and (string-match rng-xsd-duration-regexp string) | |
588 | (let ((last (substring string -1))) | |
589 | (not (or (string= last "P") | |
590 | (string= last "T")))) | |
591 | ;; years months days hours minutes seconds | |
592 | (let ((v (make-vector 6 0)) | |
593 | (sign (if (match-beginning 1) -1 1)) | |
594 | (i 0)) | |
595 | (while (< i 6) | |
596 | (let ((start (match-beginning (+ i 2)))) | |
597 | (when start | |
598 | (aset v i (* sign | |
599 | (string-to-number | |
600 | (substring string | |
601 | start | |
602 | (1- (match-end (+ i 2))))))))) | |
603 | (setq i (1+ i))) | |
604 | ;; Force seconds to be float so that equal works properly. | |
605 | (aset v 5 (float (aref v 5))) | |
606 | v))) | |
607 | ||
608 | (defconst rng-xsd-min-seconds-per-month (* 28 rng-xsd-seconds-per-day)) | |
609 | ||
610 | (defun rng-xsd-duration< (d1 d2) | |
611 | (let* ((months1 (rng-xsd-duration-months d1)) | |
612 | (months2 (rng-xsd-duration-months d2)) | |
613 | (seconds1 (rng-xsd-duration-seconds d1)) | |
614 | (seconds2 (rng-xsd-duration-seconds d2))) | |
615 | (cond ((< months1 months2) | |
616 | (if (< (- seconds1 seconds2) rng-xsd-min-seconds-per-month) | |
617 | t | |
618 | (rng-xsd-months-seconds< months1 seconds1 months2 seconds2))) | |
619 | ((> months1 months2) | |
620 | (if (< (- seconds2 seconds1) rng-xsd-min-seconds-per-month) | |
621 | nil | |
622 | (rng-xsd-months-seconds< months1 seconds1 months2 seconds2))) | |
623 | (t (< seconds1 seconds2))))) | |
624 | ||
625 | (defconst xsd-duration-reference-dates | |
626 | '((1696 . 9) (1697 . 2) (1903 . 3) (1903 . 7))) | |
627 | ||
628 | (defun rng-xsd-months-seconds< (months1 seconds1 months2 seconds2) | |
629 | (let ((ret t) | |
630 | (ref-dates xsd-duration-reference-dates)) | |
631 | (while (let* ((ref-date (car ref-dates)) | |
632 | (ref-year (car ref-date)) | |
633 | (ref-month (cdr ref-date))) | |
634 | (unless (< (+ (rng-xsd-month-seconds months1 | |
635 | ref-year | |
636 | ref-month) | |
637 | seconds1) | |
638 | (+ (rng-xsd-month-seconds months2 | |
639 | ref-year | |
640 | ref-month) | |
641 | seconds2)) | |
642 | (setq ret nil)) | |
643 | (and ret | |
644 | (setq ref-dates (cdr ref-dates))))) | |
645 | ret)) | |
646 | ||
647 | ||
648 | (defun rng-xsd-month-seconds (months ref-year ref-month) | |
649 | "Return the seconds in a number of months starting on a reference date. | |
650 | Returns a floating point number." | |
651 | (* (rng-xsd-month-days (abs months) ref-year ref-month) | |
652 | (float rng-xsd-seconds-per-day) | |
653 | (if (< months 0) -1.0 1.0))) | |
654 | ||
655 | (defconst rng-xsd-years-per-gregorian-cycle 400) | |
656 | (defconst rng-xsd-months-per-gregorian-cycle | |
657 | (* rng-xsd-years-per-gregorian-cycle 12)) | |
658 | (defconst rng-xsd-leap-years-per-gregorian-cycle (- 100 (- 4 1))) | |
659 | (defconst rng-xsd-days-per-gregorian-cycle | |
660 | (+ (* 365 rng-xsd-years-per-gregorian-cycle) | |
661 | rng-xsd-leap-years-per-gregorian-cycle)) | |
662 | ||
663 | (defun rng-xsd-month-days (months ref-year ref-month) | |
664 | "Return the days in a number of months starting on a reference date. | |
665 | MONTHS must be an integer >= 0." | |
666 | (let ((days 0)) | |
667 | (setq months (mod months rng-xsd-months-per-gregorian-cycle)) | |
668 | ;; This may be rather slow, but it is highly unlikely | |
669 | ;; ever to be used in real life. | |
670 | (while (> months 0) | |
671 | (setq days | |
672 | (+ (rng-xsd-days-in-month ref-year ref-month) | |
673 | days)) | |
674 | (setq ref-month | |
675 | (if (eq ref-month 12) | |
676 | (progn | |
677 | (setq ref-year (1+ ref-year)) | |
678 | 1) | |
679 | (1+ ref-month))) | |
680 | (setq months (1- months))) | |
681 | (+ (* (/ months rng-xsd-months-per-gregorian-cycle) | |
682 | rng-xsd-days-per-gregorian-cycle) | |
683 | days))) | |
684 | ||
685 | (defun rng-xsd-duration-months (d) | |
686 | (+ (* (aref d 0) 12) | |
687 | (aref d 1))) | |
688 | ||
689 | (defun rng-xsd-duration-seconds (d) | |
690 | (+ (* (+ (* (+ (* (aref d 2) | |
691 | 24.0) | |
692 | (aref d 3)) | |
693 | 60.0) | |
694 | (aref d 4)) | |
695 | 60.0) | |
696 | (aref d 5))) | |
697 | ||
698 | (defun rng-xsd-convert-qname (string) | |
699 | (and (string-match "\\`[ \r\n\t]*\\([_[:alpha:]][-._[:alnum:]]*\\(:[_[:alpha:]][-._[:alnum:]]*\\)?\\)[ \r\n\t]*\\'" string) | |
700 | (let ((colon (match-beginning 2)) | |
701 | (context (apply (car rng-dt-namespace-context-getter) | |
702 | (cdr rng-dt-namespace-context-getter)))) | |
703 | (if colon | |
704 | (let* ((prefix (substring string | |
705 | (match-beginning 1) | |
706 | colon)) | |
707 | (binding (assoc prefix (cdr context)))) | |
708 | (and binding | |
709 | (cons (cdr binding) | |
710 | (substring string | |
711 | (1+ colon) | |
712 | (match-end 1))))) | |
713 | (cons (car context) | |
714 | (match-string 1 string)))))) | |
715 | ||
716 | (defun rng-xsd-convert-list (string convert &rest args) | |
717 | (let* ((tokens (split-string string "[ \t\n\r]+")) | |
718 | (tem tokens)) | |
719 | (while tem | |
720 | (let ((obj (apply convert | |
721 | (cons (car tem) args)))) | |
722 | (cond (obj | |
723 | (setcar tem obj) | |
724 | (setq tem (cdr tem))) | |
725 | (t | |
726 | (setq tokens nil) | |
727 | (setq tem nil))))) | |
728 | ;; Fortuitously this returns nil if the list is empty | |
729 | ;; which is what we want since the list types | |
730 | ;; have to have one or more members. | |
731 | tokens)) | |
732 | ||
733 | (defun rng-xsd-strcmp (s1 s2) | |
734 | (cond ((string= s1 s2) 0) | |
735 | ((string< s1 s2) -1) | |
736 | (t 1))) | |
737 | ||
738 | (put 'string 'rng-xsd-convert '(identity)) | |
739 | (put 'string 'rng-xsd-length 'length) | |
740 | (put 'string 'rng-xsd-matches-anything t) | |
741 | ||
742 | (put 'normalizedString 'rng-xsd-convert '(identity)) | |
743 | (put 'normalizedString 'rng-xsd-length 'length) | |
744 | (put 'normalizedString 'rng-xsd-matches-anything t) | |
745 | ||
746 | (put 'token 'rng-xsd-convert '(identity)) | |
747 | (put 'token 'rng-xsd-length 'length) | |
748 | (put 'token 'rng-xsd-matches-anything t) | |
749 | ||
750 | (put 'hexBinary 'rng-xsd-convert '(rng-xsd-convert-hex-binary)) | |
751 | (put 'hexBinary 'rng-xsd-length 'rng-xsd-hex-binary-length) | |
752 | ||
753 | (put 'base64Binary 'rng-xsd-convert '(rng-xsd-convert-base64-binary)) | |
754 | (put 'base64Binary 'rng-xsd-length 'rng-xsd-base64-binary-length) | |
755 | ||
756 | (put 'boolean 'rng-xsd-convert '(rng-xsd-convert-boolean)) | |
757 | ||
758 | (put 'float 'rng-xsd-convert '(rng-xsd-convert-float)) | |
759 | (put 'float 'rng-xsd-less-than 'rng-xsd-float<) | |
760 | ||
761 | (put 'double 'rng-xsd-convert '(rng-xsd-convert-float)) | |
762 | (put 'double 'rng-xsd-less-than 'rng-xsd-float<) | |
763 | ||
764 | (put 'decimal 'rng-xsd-convert '(rng-xsd-convert-decimal)) | |
765 | (put 'decimal 'rng-xsd-less-than 'rng-xsd-decimal<) | |
766 | ||
767 | (put 'integer 'rng-xsd-convert '(rng-xsd-convert-integer)) | |
768 | (put 'integer 'rng-xsd-less-than 'rng-xsd-decimal<) | |
769 | ||
770 | (defun rng-xsd-def-integer-type (name min max) | |
771 | (put name 'rng-xsd-less-than 'rng-xsd-decimal<) | |
772 | (put name | |
773 | 'rng-xsd-convert | |
774 | (cdr (rng-xsd-compile 'integer | |
775 | (append (and min `((minInclusive . ,min))) | |
776 | (and max `((maxInclusive . ,max)))))))) | |
777 | ||
778 | (defun rng-xsd-def-token-type (name regexp) | |
779 | (put name 'rng-xsd-convert (list 'rng-xsd-convert-token | |
780 | (concat "\\`[\r\n\t ]*\\(" | |
781 | regexp | |
782 | "\\)[\r\n\t ]*\\'"))) | |
783 | (put name 'rng-xsd-length 'length)) | |
784 | ||
785 | (rng-xsd-def-token-type 'NMTOKEN "[-.:_[:alnum:]]+") | |
786 | (rng-xsd-def-token-type 'Name "[:_[:alpha:]][-.:_[:alnum:]]*") | |
787 | (rng-xsd-def-token-type 'NCName "[_[:alpha:]][-._[:alnum:]]*") | |
788 | (rng-xsd-def-token-type 'language | |
789 | "[a-zA-Z]\\{1,8\\}\\(?:-[a-zA-Z0-9]\\{1,8\\}\\)*") | |
790 | ||
791 | (put 'ENTITY 'rng-xsd-convert (get 'NCName 'rng-xsd-convert)) | |
792 | (put 'ENTITY 'rng-xsd-length 'length) | |
793 | (put 'ID 'rng-xsd-convert (get 'NCName 'rng-xsd-convert)) | |
794 | (put 'ID 'rng-xsd-length 'length) | |
795 | (put 'IDREF 'rng-xsd-convert (get 'NCName 'rng-xsd-convert)) | |
796 | (put 'IDREF 'rng-xsd-length 'length) | |
797 | ||
798 | (defun rng-xsd-def-list-type (name member-name) | |
799 | (put name 'rng-xsd-convert (cons 'rng-xsd-convert-list | |
800 | (get member-name 'rng-xsd-convert))) | |
801 | (put name 'rng-xsd-length 'length)) | |
802 | ||
803 | (rng-xsd-def-list-type 'NMTOKENS 'NMTOKEN) | |
804 | (rng-xsd-def-list-type 'IDREFS 'IDREF) | |
805 | (rng-xsd-def-list-type 'ENTITIES 'ENTITY) | |
806 | ||
807 | (put 'anyURI 'rng-xsd-convert '(rng-xsd-convert-any-uri)) | |
808 | (put 'anyURI 'rng-xsd-length 'length) | |
809 | ||
810 | (put 'QName 'rng-xsd-convert '(rng-xsd-convert-qname)) | |
811 | (put 'NOTATION 'rng-xsd-convert '(rng-xsd-convert-qname)) | |
812 | ||
813 | (defconst rng-xsd-long-max "9223372036854775807") | |
814 | (defconst rng-xsd-long-min "-9223372036854775808") | |
815 | (defconst rng-xsd-int-max "2147483647") | |
816 | (defconst rng-xsd-int-min "-2147483648") | |
817 | (defconst rng-xsd-short-max "32767") | |
818 | (defconst rng-xsd-short-min "-32768") | |
819 | (defconst rng-xsd-byte-max "127") | |
820 | (defconst rng-xsd-byte-min "-128") | |
821 | (defconst rng-xsd-unsigned-long-max "18446744073709551615") | |
822 | (defconst rng-xsd-unsigned-int-max "4294967295") | |
823 | (defconst rng-xsd-unsigned-short-max "65535") | |
824 | (defconst rng-xsd-unsigned-byte-max "255") | |
825 | ||
826 | (rng-xsd-def-integer-type 'nonNegativeInteger "0" nil) | |
827 | (rng-xsd-def-integer-type 'positiveInteger "1" nil) | |
828 | (rng-xsd-def-integer-type 'nonPositiveInteger nil "0") | |
829 | (rng-xsd-def-integer-type 'negativeInteger nil "-1") | |
830 | (rng-xsd-def-integer-type 'long rng-xsd-long-min rng-xsd-long-max) | |
831 | (rng-xsd-def-integer-type 'int rng-xsd-int-min rng-xsd-int-max) | |
832 | (rng-xsd-def-integer-type 'short rng-xsd-short-min rng-xsd-short-max) | |
833 | (rng-xsd-def-integer-type 'byte rng-xsd-byte-min rng-xsd-byte-max) | |
834 | (rng-xsd-def-integer-type 'unsignedLong "0" rng-xsd-unsigned-long-max) | |
835 | (rng-xsd-def-integer-type 'unsignedInt "0" rng-xsd-unsigned-int-max) | |
836 | (rng-xsd-def-integer-type 'unsignedShort "0" rng-xsd-unsigned-short-max) | |
837 | (rng-xsd-def-integer-type 'unsignedByte "0" rng-xsd-unsigned-byte-max) | |
838 | ||
839 | (defun rng-xsd-def-date-time-type (name template) | |
840 | (put name 'rng-xsd-convert (list 'rng-xsd-convert-date-time | |
841 | (rng-xsd-make-date-time-regexp template))) | |
842 | (put name 'rng-xsd-less-than 'rng-xsd-date-time<)) | |
843 | ||
844 | (rng-xsd-def-date-time-type 'dateTime "Y-M-DTt") | |
845 | (rng-xsd-def-date-time-type 'time "t") | |
846 | (rng-xsd-def-date-time-type 'date "Y-M-D") | |
847 | (rng-xsd-def-date-time-type 'gYearMonth "Y-M") | |
848 | (rng-xsd-def-date-time-type 'gYear "Y") | |
849 | (rng-xsd-def-date-time-type 'gMonthDay "--M-D") | |
850 | (rng-xsd-def-date-time-type 'gDay "---D") | |
851 | (rng-xsd-def-date-time-type 'gMonth "--M") | |
852 | ||
853 | (put 'duration 'rng-xsd-convert '(rng-xsd-convert-duration)) | |
854 | (put 'duration 'rng-xsd-less-than 'rng-xsd-duration<) | |
855 | ||
856 | (provide 'rng-xsd) | |
857 | ||
858 | ;;; rng-xsd.el ends here |