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