summaryrefslogtreecommitdiff
path: root/lisp/nxml/rng-xsd.el
diff options
context:
space:
mode:
Diffstat (limited to 'lisp/nxml/rng-xsd.el')
-rw-r--r--lisp/nxml/rng-xsd.el858
1 files changed, 858 insertions, 0 deletions
diff --git a/lisp/nxml/rng-xsd.el b/lisp/nxml/rng-xsd.el
new file mode 100644
index 00000000000..65091ef8795
--- /dev/null
+++ b/lisp/nxml/rng-xsd.el
@@ -0,0 +1,858 @@
+;;; rng-xsd.el --- W3C XML Schema datatypes library for RELAX NG
+
+;; Copyright (C) 2003 Free Software Foundation, Inc.
+
+;; Author: James Clark
+;; Keywords: XML, RelaxNG
+
+;; This program is free software; you can redistribute it and/or
+;; modify it under the terms of the GNU General Public License as
+;; published by the Free Software Foundation; either version 2 of
+;; the License, or (at your option) any later version.
+
+;; This program is distributed in the hope that it will be
+;; useful, but WITHOUT ANY WARRANTY; without even the implied
+;; warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR
+;; PURPOSE. See the GNU General Public License for more details.
+
+;; You should have received a copy of the GNU General Public
+;; License along with this program; if not, write to the Free
+;; Software Foundation, Inc., 59 Temple Place, Suite 330, Boston,
+;; MA 02111-1307 USA
+
+;;; Commentary:
+
+;; The main entry point is `rng-xsd-compile'. The validator
+;; knows to use this for the datatype library with URI
+;; http://www.w3.org/2001/XMLSchema-datatypes because it
+;; is the value of the rng-dt-compile property on that URI
+;; as a symbol.
+;;
+;; W3C XML Schema Datatypes are specified by
+;; http://www.w3.org/TR/xmlschema-2/
+;; Guidelines for using them with RELAX NG are described in
+;; http://relaxng.org/xsd.html
+
+;;; Code:
+
+(require 'rng-dt)
+(require 'rng-util)
+(require 'xsd-regexp)
+
+;;;###autoload
+(put 'http://www.w3.org/2001/XMLSchema-datatypes
+ 'rng-dt-compile
+ 'rng-xsd-compile)
+
+;;;###autoload
+(defun rng-xsd-compile (name params)
+ "Provides W3C XML Schema as a RELAX NG datatypes library. NAME is a
+symbol giving the local name of the datatype. PARAMS is a list of
+pairs (PARAM-NAME . PARAM-VALUE) where PARAM-NAME is a symbol giving
+the name of the parameter and PARAM-VALUE is a string giving its
+value. If NAME or PARAMS are invalid, it calls rng-dt-error passing
+it arguments in the same style as format; the value from rng-dt-error
+will be returned. Otherwise, it returns a list. The first member of
+the list is t if any string is a legal value for the datatype and nil
+otherwise. The second argument is a symbol; this symbol will be
+called as a function passing it a string followed by the remaining
+members of the list. The function must return an object representing
+the value of the datatype that was represented by the string, or nil
+if the string is not a representation of any value. The object
+returned can be any convenient non-nil value, provided that, if two
+strings represent the same value, the returned objects must be equal."
+ (let ((convert (get name 'rng-xsd-convert)))
+ (if (not convert)
+ (rng-dt-error "There is no XSD datatype named %s" name)
+ (rng-xsd-compile1 name params convert))))
+
+;;; Parameters
+
+(defun rng-xsd-compile1 (name params convert)
+ (if (null params)
+ (cons (equal convert '(identity))
+ (cond ((eq name 'string) convert)
+ ((eq name 'normalizedString)
+ (cons 'rng-xsd-replace-space convert))
+ ((and (not (eq name 'string))
+ (or (memq 'identity convert)
+ (memq 'rng-xsd-convert-any-uri convert)
+ (memq 'rng-xsd-check-pattern convert)))
+ (cons 'rng-xsd-collapse-space convert))
+ (t convert)))
+ (let* ((param (car params))
+ (param-name (car param))
+ (param-value (cdr param)))
+ (cond ((memq param-name
+ '(minExclusive maxExclusive minInclusive maxInclusive))
+ (let ((limit (apply (car convert)
+ (cons param-value
+ (cdr convert))))
+ (less-than-fun (get name 'rng-xsd-less-than)))
+ (cond ((not limit)
+ (rng-dt-error "Minimum value %s is not valid"
+ param-value))
+ ((not less-than-fun)
+ (rng-dt-error "Values of type %s are not ordered"
+ param-name))
+ (t
+ (rng-xsd-compile1 name
+ (cdr params)
+ (cons (get param-name
+ 'rng-xsd-check)
+ (cons less-than-fun
+ (cons limit convert))))))))
+ ((memq param-name '(length minLength maxLength))
+ (let ((limit (rng-xsd-string-to-non-negative-integer param-value))
+ (length-fun (get name 'rng-xsd-length)))
+ (cond ((not limit)
+ (rng-dt-error "Length %s is not valid" param-value))
+ ((not length-fun)
+ (rng-dt-error "Values of type %s do not have a length"
+ param-name))
+ (t
+ (rng-xsd-compile1 name
+ (cdr params)
+ (cons (get param-name
+ 'rng-xsd-check)
+ (cons length-fun
+ (cons limit convert))))))))
+ ((memq param-name '(fractionDigits totalDigits))
+ (let ((n (rng-xsd-string-to-non-negative-integer param-value)))
+ (cond ((not n)
+ (rng-dt-error "Number of digits %s is not valid"
+ param-value))
+ (t
+ (rng-xsd-compile1 name
+ (cdr params)
+ (cons (get param-name
+ 'rng-xsd-check)
+ (cons n convert)))))))
+ ((eq param-name 'pattern)
+ (condition-case err
+ (rng-xsd-compile1 name
+ (cdr params)
+ (cons 'rng-xsd-check-pattern
+ (cons (concat
+ "\\`"
+ (xsdre-translate param-value)
+ "\\'")
+ convert)))
+ (xsdre-invalid-regexp
+ (rng-dt-error "Invalid regular expression (%s)"
+ (nth 1 err)))))
+ ((memq param-name '(enumeration whiteSpace))
+ (rng-dt-error "Facet %s cannot be used in RELAX NG" param-name))
+ (t (rng-dt-error "Unknown facet %s" param-name))))))
+
+(defun rng-xsd-string-to-non-negative-integer (str)
+ (and (rng-xsd-convert-integer str)
+ (let ((n (string-to-number str)))
+ (and (integerp n)
+ (>= n 0)
+ n))))
+
+(defun rng-xsd-collapse-space (str convert &rest args)
+ (apply convert (cons (mapconcat 'identity (split-string str "[ \t\n\r]+")
+ " ")
+ args)))
+
+(defun rng-xsd-replace-space (str convert &rest args)
+ (apply convert
+ (cons (let ((i 0)
+ copied)
+ (while (and (setq i (string-match "[\r\n\t]" str i))
+ (or copied (setq copied (copy-sequence str)))
+ (aset copied i 32)
+ (setq i (1+ i))))
+ (or copied str))
+ args)))
+
+(put 'minExclusive 'rng-xsd-check 'rng-xsd-check-min-exclusive)
+(put 'minInclusive 'rng-xsd-check 'rng-xsd-check-min-inclusive)
+(put 'maxExclusive 'rng-xsd-check 'rng-xsd-check-max-exclusive)
+(put 'maxInclusive 'rng-xsd-check 'rng-xsd-check-max-inclusive)
+(put 'length 'rng-xsd-check 'rng-xsd-check-length)
+(put 'minLength 'rng-xsd-check 'rng-xsd-check-min-length)
+(put 'maxLength 'rng-xsd-check 'rng-xsd-check-max-length)
+(put 'fractionDigits 'rng-xsd-check 'rng-xsd-check-fraction-digits)
+(put 'totalDigits 'rng-xsd-check 'rng-xsd-check-total-digits)
+
+(defun rng-xsd-check-min-exclusive (str less-than-fun limit convert &rest args)
+ (let ((obj (apply convert (cons str args))))
+ (and obj
+ (funcall less-than-fun limit obj)
+ obj)))
+
+(defun rng-xsd-check-min-inclusive (str less-than-fun limit convert &rest args)
+ (let ((obj (apply convert (cons str args))))
+ (and obj
+ (or (funcall less-than-fun limit obj)
+ (equal limit obj))
+ obj)))
+
+(defun rng-xsd-check-max-exclusive (str less-than-fun limit convert &rest args)
+ (let ((obj (apply convert (cons str args))))
+ (and obj
+ (funcall less-than-fun obj limit)
+ obj)))
+
+(defun rng-xsd-check-max-inclusive (str less-than-fun limit convert &rest args)
+ (let ((obj (apply convert (cons str args))))
+ (and obj
+ (or (funcall less-than-fun obj limit)
+ (equal obj limit))
+ obj)))
+
+(defun rng-xsd-check-min-length (str length-fun limit convert &rest args)
+ (let ((obj (apply convert (cons str args))))
+ (and obj
+ (>= (funcall length-fun obj) limit)
+ obj)))
+
+(defun rng-xsd-check-max-length (str length-fun limit convert &rest args)
+ (let ((obj (apply convert (cons str args))))
+ (and obj
+ (<= (funcall length-fun obj) limit)
+ obj)))
+
+(defun rng-xsd-check-length (str length-fun len convert &rest args)
+ (let ((obj (apply convert (cons str args))))
+ (and obj
+ (= (funcall length-fun obj) len)
+ obj)))
+
+(defun rng-xsd-check-fraction-digits (str n convert &rest args)
+ (let ((obj (apply convert (cons str args))))
+ (and obj
+ (<= (length (aref obj 2)) n)
+ obj)))
+
+(defun rng-xsd-check-total-digits (str n convert &rest args)
+ (let ((obj (apply convert (cons str args))))
+ (and obj
+ (<= (+ (length (aref obj 1))
+ (length (aref obj 2)))
+ n)
+ obj)))
+
+(defun rng-xsd-check-pattern (str regexp convert &rest args)
+ (and (string-match regexp str)
+ (apply convert (cons str args))))
+
+
+(defun rng-xsd-convert-boolean (string)
+ (and (string-match "\\`[ \t\n\r]*\\(?:\\(true\\|1\\)\\|false\\|0\\)[ \t\n\r]*\\'" string)
+ (if (match-beginning 1) 'true 'false)))
+
+(defun rng-xsd-convert-decimal (string)
+ "Convert a string representing a decimal to an object representing
+its values. A decimal value is represented by a vector [SIGN
+INTEGER-DIGITS FRACTION-DIGITS] where SIGN is 1 or -1, INTEGER-DIGITS
+is a string containing zero or more digits, with no leading zero, and
+FRACTION-DIGITS is a string containing zero or more digits with no
+trailing digits. For example, -0021.0430 would be represented by [-1
+\"21\" \"043\"]."
+ (and (string-match "\\`[ \t\n\r]*\\([-+]\\)?\\(0*\\([1-9][0-9]*\\)?\\(\\.\\([0-9]*[1-9]\\)?0*\\)?\\)[ \t\n\r]*\\'" string)
+ (let ((digits (match-string 2 string)))
+ (and (not (string= digits "."))
+ (not (string= digits ""))))
+ (let ((integer-digits (match-string 3 string)))
+ (vector (if (and (equal (match-string 1 string) "-")
+ ;; Normalize -0 to 0
+ integer-digits)
+ -1
+ 1)
+ (or integer-digits "")
+ (or (match-string 5 string) "")))))
+
+(defun rng-xsd-convert-integer (string)
+ (and (string-match "\\`[ \t\n\r]*\\([-+]\\)?\\(?:0*\\([1-9][0-9]*\\)\\|0+\\)[ \t\n\r]*\\'" string)
+ (let ((integer-digits (match-string 2 string)))
+ (vector (if (and (equal (match-string 1 string) "-")
+ ;; Normalize -0 to 0
+ integer-digits)
+ -1
+ 1)
+ (or integer-digits "")
+ ""))))
+
+(defun rng-xsd-decimal< (n1 n2)
+ (< (rng-xsd-compare-decimal n1 n2) 0))
+
+(defun rng-xsd-compare-decimal (n1 n2)
+ "Return a < 0, 0, > 0 according as n1 < n2, n1 = n2 or n1 > n2."
+ (let* ((sign1 (aref n1 0))
+ (sign2 (aref n2 0))
+ (sign (- sign1 sign2)))
+ (if (= sign 0)
+ (* sign1
+ (let* ((int1 (aref n1 1))
+ (int2 (aref n2 1))
+ (len1 (length int1))
+ (len2 (length int2))
+ (lencmp (- len1 len2)))
+ (if (eq lencmp 0)
+ (if (string= int1 int2)
+ (rng-xsd-strcmp (aref n1 2) (aref n2 2))
+ (rng-xsd-strcmp int1 int2))
+ lencmp)))
+ sign)))
+
+(defconst rng-xsd-float-regexp
+ (concat "\\`[ \r\n\t]*\\(?:"
+ "\\("
+ "[-+]?\\(?:[0-9]+\\(?:\\.[0-9]*\\)?\\|\\.[0-9]+\\)"
+ "\\(?:[eE][-+]?[0-9]+\\)?"
+ "\\)"
+ "\\|\\(INF\\)"
+ "\\|\\(-INF\\)"
+ "\\|\\(NaN\\)"
+ "\\)[ \r\n\t]*\\'"))
+
+(defun rng-xsd-convert-float (string)
+ (cond ((not (string-match rng-xsd-float-regexp string)) nil)
+ ((match-beginning 1)
+ (float (string-to-number (match-string 1 string))))
+ ((match-beginning 2) 1.0e+INF)
+ ((match-beginning 3) -1.0e+INF)
+ ;; Don't use a NaN float because we want NaN to be equal to NaN
+ ((match-beginning 4) 'NaN)))
+
+(defun rng-xsd-float< (f1 f2)
+ (and (not (eq f1 'NaN))
+ (not (eq f2 'NaN))
+ (< f1 f2)))
+
+(defun rng-xsd-convert-token (string regexp)
+ (and (string-match regexp string)
+ (match-string 1 string)))
+
+(defun rng-xsd-convert-hex-binary (string)
+ (and (string-match "\\`[ \r\n\t]*\\(\\(?:[0-9A-Fa-f][0-9A-Fa-f]\\)*\\)[ \r\n\t]*\\'"
+ string)
+ (downcase (match-string 1 string))))
+
+(defun rng-xsd-hex-binary-length (obj)
+ (/ (length obj) 2))
+
+(defconst rng-xsd-base64-binary-regexp
+ (let ((S "[ \t\r\n]*")
+ (B04 "[AQgw]")
+ (B16 "[AEIMQUYcgkosw048]")
+ (B64 "[A-Za-z0-9+/]"))
+ (concat "\\`" S "\\(?:\\(?:" B64 S "\\)\\{4\\}\\)*"
+ "\\(?:" B64 S B64 S B16 S "=" S
+ "\\|" B64 S B04 S "=" S "=" S "\\)?\\'")))
+
+(defun rng-xsd-convert-base64-binary (string)
+ (and (string-match rng-xsd-base64-binary-regexp string)
+ (replace-regexp-in-string "[ \t\r\n]+" "" string t t)))
+
+(defun rng-xsd-base64-binary-length (obj)
+ (let ((n (* (/ (length obj) 4) 3)))
+ (if (and (> n 0)
+ (string= (substring obj -1) "="))
+ (- n (if (string= (substring obj -2) "==")
+ 2
+ 1))
+ n)))
+
+(defun rng-xsd-convert-any-uri (string)
+ (and (string-match "\\`\\(?:[^%]\\|%[0-9a-fA-F][0-9a-fA-F]\\)?*\\'" string)
+ (string-match "\\`[^#]*\\(?:#[^#]*\\)?\\'" string)
+ (string-match "\\`\\(?:[a-zA-Z][-+.A-Za-z0-9]*:.+\\|[^:]*\\(?:[#/?].*\\)?\\)\\'" string)
+ string))
+
+(defun rng-xsd-make-date-time-regexp (template)
+ "Returns a regular expression matching a ISO 8601 date/time. The
+template is a string with Y standing for years field, M standing for
+months, D standing for day of month, T standing for a literal T, t
+standing for time and - standing for a literal hyphen. A time zone is
+always allowed at the end. Regardless of the fields appearing in the
+template, the regular expression will have twelve groups matching the
+year sign, year, month, day of month, hours, minutes, integer seconds,
+fractional seconds (including leading period), time zone, time zone
+sign, time zone hours, time zone minutes."
+ (let ((i 0)
+ (len (length template))
+ (parts nil)
+ first last c)
+ (while (< i len)
+ (setq c (aref template i))
+ (setq parts
+ (cons (cond ((eq c ?Y)
+ (setq first 0)
+ (setq last 1)
+ "\\(-\\)?\\(\\(?:[1-9][0-9]*\\)?[0-9]\\{4\\}\\)")
+ ((eq c ?M)
+ (or first
+ (setq first 2))
+ (setq last 2)
+ "\\([0-9][0-9]\\)")
+ ((eq c ?D)
+ (or first
+ (setq first 3))
+ (setq last 3)
+ "\\([0-9][0-9]\\)")
+ ((eq c ?t)
+ (or first
+ (setq first 4))
+ (setq last 7)
+ "\\([0-9][0-9]\\):\\([0-9][0-9]\\):\\([0-9][0-9]\\)\\(\\.[0-9]*\\)?")
+ (t (string c)))
+ parts))
+ (setq i (1+ i)))
+ (while (< last 7)
+ (setq last (1+ last))
+ ;; Add dummy fields that can never much but keep the group
+ ;; numbers uniform.
+ (setq parts (cons "\\(\\'X\\)?" parts)))
+ (setq parts (cons "\\(Z\\|\\([-+]\\)\\([0-9][0-9]\\):\\([0-5][0-9]\\)\\)?[ \t\n\r]*\\'"
+ parts))
+ (setq parts (cons "\\`[ \t\n\r]*" (nreverse parts)))
+ (while (> first 0)
+ (setq first (1- first))
+ (setq parts (cons "\\(X\\)?" parts)))
+ (apply 'concat parts)))
+
+(defconst rng-xsd-seconds-per-day (* 24 60 60))
+(defconst rng-xsd-days-in-month [31 28 31 30 31 30 31 31 30 31 30 31])
+
+(defun rng-xsd-days-in-month (year month)
+ (if (and (= month 2) (rng-xsd-leap-year-p year))
+ 29
+ (aref rng-xsd-days-in-month (1- month))))
+
+(defconst rng-xsd-months-to-days
+ (let ((v (make-vector 12 nil))
+ (total 0)
+ (i 0))
+ (while (< i 12)
+ (setq total (+ total (aref rng-xsd-days-in-month i)))
+ (aset v i total)
+ (setq i (1+ i)))
+ v))
+
+(defun rng-xsd-convert-date-time (string regexp)
+ "Converts an XML Schema date/time to a list. Returns nil if
+invalid. REGEXP is a regexp for parsing the date time as returned by
+`rng-xsd-make-date-time-regexp'. The list has 4 members (HAS-TIME-ZONE
+DAY SECOND SECOND-FRACTION), where HAS-TIME-ZONE is t or nil depending
+on whether a time zone was specified, DAY is an integer giving a day
+number (with Jan 1 1AD being day 1), SECOND is the second within that
+day, and SECOND-FRACTION is a float giving the fractional part of the
+second."
+ (and (string-match regexp string)
+ (let ((year-sign (match-string 1 string))
+ (year (match-string 2 string))
+ (month (match-string 3 string))
+ (day (match-string 4 string))
+ (hour (match-string 5 string))
+ (minute (match-string 6 string))
+ (second (match-string 7 string))
+ (second-fraction (match-string 8 string))
+ (has-time-zone (match-string 9 string))
+ (time-zone-sign (match-string 10 string))
+ (time-zone-hour (match-string 11 string))
+ (time-zone-minute (match-string 12 string)))
+ (setq year-sign (if year-sign -1 1))
+ (setq year
+ (if year
+ (* year-sign
+ (string-to-number year))
+ 2000))
+ (setq month
+ (if month (string-to-number month) 1))
+ (setq day
+ (if day (string-to-number day) 1))
+ (setq hour
+ (if hour (string-to-number hour) 0))
+ (setq minute
+ (if minute (string-to-number minute) 0))
+ (setq second
+ (if second (string-to-number second) 0))
+ (setq second-fraction
+ (if second-fraction
+ (float (string-to-number second-fraction))
+ 0.0))
+ (setq has-time-zone (and has-time-zone t))
+ (setq time-zone-sign
+ (if (equal time-zone-sign "-") -1 1))
+ (setq time-zone-hour
+ (if time-zone-hour (string-to-number time-zone-hour) 0))
+ (setq time-zone-minute
+ (if time-zone-minute (string-to-number time-zone-minute) 0))
+ (and (>= month 1)
+ (<= month 12)
+ (>= day 1)
+ (<= day (rng-xsd-days-in-month year month))
+ (<= hour 23)
+ (<= minute 59)
+ (<= second 60) ; leap second
+ (<= time-zone-hour 23)
+ (<= time-zone-minute 59)
+ (cons has-time-zone
+ (rng-xsd-add-seconds
+ (list (rng-xsd-date-to-days year month day)
+ (rng-xsd-time-to-seconds hour minute second)
+ second-fraction)
+ (* (rng-xsd-time-to-seconds time-zone-hour
+ time-zone-minute
+ 0)
+ (- time-zone-sign))))))))
+
+(defun rng-xsd-leap-year-p (year)
+ (and (= (% year 4) 0)
+ (or (/= (% year 100) 0)
+ (= (% year 400) 0))))
+
+(defun rng-xsd-time-to-seconds (hour minute second)
+ (+ (* (+ (* hour 60)
+ minute)
+ 60)
+ second))
+
+(defconst rng-xsd-max-tz (rng-xsd-time-to-seconds 14 0 0))
+
+(defun rng-xsd-date-time< (dt1 dt2)
+ (cond ((eq (car dt1) (car dt2))
+ (rng-xsd-number-list< (cdr dt1) (cdr dt2)))
+ ((car dt1)
+ (rng-xsd-number-list< (cdr dt1)
+ (rng-xsd-add-seconds (cdr dt2)
+ (- rng-xsd-max-tz))))
+ (t
+ (rng-xsd-number-list< (rng-xsd-add-seconds (cdr dt1)
+ rng-xsd-max-tz)
+ (cdr dt2)))))
+
+(defun rng-xsd-add-seconds (date offset)
+ (let ((day (nth 0 date))
+ (second (+ (nth 1 date) offset))
+ (fraction (nth 2 date)))
+ (cond ((< second 0)
+ (list (1- day)
+ (+ second rng-xsd-seconds-per-day)
+ fraction))
+ ((>= second rng-xsd-seconds-per-day)
+ (list (1+ day)
+ (- second rng-xsd-seconds-per-day)
+ fraction))
+ (t (list day second fraction)))))
+
+(defun rng-xsd-number-list< (numbers1 numbers2)
+ (while (and numbers1 (= (car numbers1) (car numbers2)))
+ (setq numbers1 (cdr numbers1))
+ (setq numbers2 (cdr numbers2)))
+ (and numbers1
+ (< (car numbers1) (car numbers2))))
+
+(defun rng-xsd-date-to-days (year month day)
+ "Return a unique day number where Jan 1 1 AD is day 1"
+ (if (> year 0) ; AD
+ (+ (rng-xsd-days-in-years (- year 1))
+ (rng-xsd-day-number-in-year year month day))
+ (- (+ (- (rng-xsd-days-in-years (- 3 year))
+ (rng-xsd-days-in-years 3))
+ (- (if (rng-xsd-leap-year-p year) 366 365)
+ (rng-xsd-day-number-in-year year month day))))))
+
+(defun rng-xsd-days-in-years (years)
+ "The number of days in YEARS years where the first year is 1AD."
+ (+ (* 365 years)
+ (/ years 4)
+ (- (/ years 100))
+ (/ years 400)))
+
+(defun rng-xsd-day-number-in-year (year month day)
+ (+ (if (= month 1)
+ 0
+ (aref rng-xsd-months-to-days (- month 2)))
+ day
+ (if (and (> month 2)
+ (rng-xsd-leap-year-p year))
+ 1
+ 0)))
+
+(defconst rng-xsd-duration-regexp
+ "\\`[ \t\r\n]*\\(-\\)?P\
+\\([0-9]+Y\\)?\\([0-9]+M\\)?\\([0-9]+D\\)?\
+\\(?:T\\([0-9]+H\\)?\\([0-9]+M\\)?\
+\\(\\([0-9]+\\(?:\\.[0-9]*\\)?\\|\\.[0-9]+\\)S\\)?\\)?\
+[ \t\r\n]*\\'")
+
+
+(defun rng-xsd-convert-duration (string)
+ (and (string-match rng-xsd-duration-regexp string)
+ (let ((last (substring string -1)))
+ (not (or (string= last "P")
+ (string= last "T"))))
+ ;; years months days hours minutes seconds
+ (let ((v (make-vector 6 0))
+ (sign (if (match-beginning 1) -1 1))
+ (i 0))
+ (while (< i 6)
+ (let ((start (match-beginning (+ i 2))))
+ (when start
+ (aset v i (* sign
+ (string-to-number
+ (substring string
+ start
+ (1- (match-end (+ i 2)))))))))
+ (setq i (1+ i)))
+ ;; Force seconds to be float so that equal works properly.
+ (aset v 5 (float (aref v 5)))
+ v)))
+
+(defconst rng-xsd-min-seconds-per-month (* 28 rng-xsd-seconds-per-day))
+
+(defun rng-xsd-duration< (d1 d2)
+ (let* ((months1 (rng-xsd-duration-months d1))
+ (months2 (rng-xsd-duration-months d2))
+ (seconds1 (rng-xsd-duration-seconds d1))
+ (seconds2 (rng-xsd-duration-seconds d2)))
+ (cond ((< months1 months2)
+ (if (< (- seconds1 seconds2) rng-xsd-min-seconds-per-month)
+ t
+ (rng-xsd-months-seconds< months1 seconds1 months2 seconds2)))
+ ((> months1 months2)
+ (if (< (- seconds2 seconds1) rng-xsd-min-seconds-per-month)
+ nil
+ (rng-xsd-months-seconds< months1 seconds1 months2 seconds2)))
+ (t (< seconds1 seconds2)))))
+
+(defconst xsd-duration-reference-dates
+ '((1696 . 9) (1697 . 2) (1903 . 3) (1903 . 7)))
+
+(defun rng-xsd-months-seconds< (months1 seconds1 months2 seconds2)
+ (let ((ret t)
+ (ref-dates xsd-duration-reference-dates))
+ (while (let* ((ref-date (car ref-dates))
+ (ref-year (car ref-date))
+ (ref-month (cdr ref-date)))
+ (unless (< (+ (rng-xsd-month-seconds months1
+ ref-year
+ ref-month)
+ seconds1)
+ (+ (rng-xsd-month-seconds months2
+ ref-year
+ ref-month)
+ seconds2))
+ (setq ret nil))
+ (and ret
+ (setq ref-dates (cdr ref-dates)))))
+ ret))
+
+
+(defun rng-xsd-month-seconds (months ref-year ref-month)
+ "Return the seconds in a number of months starting on a reference date.
+Returns a floating point number."
+ (* (rng-xsd-month-days (abs months) ref-year ref-month)
+ (float rng-xsd-seconds-per-day)
+ (if (< months 0) -1.0 1.0)))
+
+(defconst rng-xsd-years-per-gregorian-cycle 400)
+(defconst rng-xsd-months-per-gregorian-cycle
+ (* rng-xsd-years-per-gregorian-cycle 12))
+(defconst rng-xsd-leap-years-per-gregorian-cycle (- 100 (- 4 1)))
+(defconst rng-xsd-days-per-gregorian-cycle
+ (+ (* 365 rng-xsd-years-per-gregorian-cycle)
+ rng-xsd-leap-years-per-gregorian-cycle))
+
+(defun rng-xsd-month-days (months ref-year ref-month)
+ "Return the days in a number of months starting on a reference date.
+MONTHS must be an integer >= 0."
+ (let ((days 0))
+ (setq months (mod months rng-xsd-months-per-gregorian-cycle))
+ ;; This may be rather slow, but it is highly unlikely
+ ;; ever to be used in real life.
+ (while (> months 0)
+ (setq days
+ (+ (rng-xsd-days-in-month ref-year ref-month)
+ days))
+ (setq ref-month
+ (if (eq ref-month 12)
+ (progn
+ (setq ref-year (1+ ref-year))
+ 1)
+ (1+ ref-month)))
+ (setq months (1- months)))
+ (+ (* (/ months rng-xsd-months-per-gregorian-cycle)
+ rng-xsd-days-per-gregorian-cycle)
+ days)))
+
+(defun rng-xsd-duration-months (d)
+ (+ (* (aref d 0) 12)
+ (aref d 1)))
+
+(defun rng-xsd-duration-seconds (d)
+ (+ (* (+ (* (+ (* (aref d 2)
+ 24.0)
+ (aref d 3))
+ 60.0)
+ (aref d 4))
+ 60.0)
+ (aref d 5)))
+
+(defun rng-xsd-convert-qname (string)
+ (and (string-match "\\`[ \r\n\t]*\\([_[:alpha:]][-._[:alnum:]]*\\(:[_[:alpha:]][-._[:alnum:]]*\\)?\\)[ \r\n\t]*\\'" string)
+ (let ((colon (match-beginning 2))
+ (context (apply (car rng-dt-namespace-context-getter)
+ (cdr rng-dt-namespace-context-getter))))
+ (if colon
+ (let* ((prefix (substring string
+ (match-beginning 1)
+ colon))
+ (binding (assoc prefix (cdr context))))
+ (and binding
+ (cons (cdr binding)
+ (substring string
+ (1+ colon)
+ (match-end 1)))))
+ (cons (car context)
+ (match-string 1 string))))))
+
+(defun rng-xsd-convert-list (string convert &rest args)
+ (let* ((tokens (split-string string "[ \t\n\r]+"))
+ (tem tokens))
+ (while tem
+ (let ((obj (apply convert
+ (cons (car tem) args))))
+ (cond (obj
+ (setcar tem obj)
+ (setq tem (cdr tem)))
+ (t
+ (setq tokens nil)
+ (setq tem nil)))))
+ ;; Fortuitously this returns nil if the list is empty
+ ;; which is what we want since the list types
+ ;; have to have one or more members.
+ tokens))
+
+(defun rng-xsd-strcmp (s1 s2)
+ (cond ((string= s1 s2) 0)
+ ((string< s1 s2) -1)
+ (t 1)))
+
+(put 'string 'rng-xsd-convert '(identity))
+(put 'string 'rng-xsd-length 'length)
+(put 'string 'rng-xsd-matches-anything t)
+
+(put 'normalizedString 'rng-xsd-convert '(identity))
+(put 'normalizedString 'rng-xsd-length 'length)
+(put 'normalizedString 'rng-xsd-matches-anything t)
+
+(put 'token 'rng-xsd-convert '(identity))
+(put 'token 'rng-xsd-length 'length)
+(put 'token 'rng-xsd-matches-anything t)
+
+(put 'hexBinary 'rng-xsd-convert '(rng-xsd-convert-hex-binary))
+(put 'hexBinary 'rng-xsd-length 'rng-xsd-hex-binary-length)
+
+(put 'base64Binary 'rng-xsd-convert '(rng-xsd-convert-base64-binary))
+(put 'base64Binary 'rng-xsd-length 'rng-xsd-base64-binary-length)
+
+(put 'boolean 'rng-xsd-convert '(rng-xsd-convert-boolean))
+
+(put 'float 'rng-xsd-convert '(rng-xsd-convert-float))
+(put 'float 'rng-xsd-less-than 'rng-xsd-float<)
+
+(put 'double 'rng-xsd-convert '(rng-xsd-convert-float))
+(put 'double 'rng-xsd-less-than 'rng-xsd-float<)
+
+(put 'decimal 'rng-xsd-convert '(rng-xsd-convert-decimal))
+(put 'decimal 'rng-xsd-less-than 'rng-xsd-decimal<)
+
+(put 'integer 'rng-xsd-convert '(rng-xsd-convert-integer))
+(put 'integer 'rng-xsd-less-than 'rng-xsd-decimal<)
+
+(defun rng-xsd-def-integer-type (name min max)
+ (put name 'rng-xsd-less-than 'rng-xsd-decimal<)
+ (put name
+ 'rng-xsd-convert
+ (cdr (rng-xsd-compile 'integer
+ (append (and min `((minInclusive . ,min)))
+ (and max `((maxInclusive . ,max))))))))
+
+(defun rng-xsd-def-token-type (name regexp)
+ (put name 'rng-xsd-convert (list 'rng-xsd-convert-token
+ (concat "\\`[\r\n\t ]*\\("
+ regexp
+ "\\)[\r\n\t ]*\\'")))
+ (put name 'rng-xsd-length 'length))
+
+(rng-xsd-def-token-type 'NMTOKEN "[-.:_[:alnum:]]+")
+(rng-xsd-def-token-type 'Name "[:_[:alpha:]][-.:_[:alnum:]]*")
+(rng-xsd-def-token-type 'NCName "[_[:alpha:]][-._[:alnum:]]*")
+(rng-xsd-def-token-type 'language
+ "[a-zA-Z]\\{1,8\\}\\(?:-[a-zA-Z0-9]\\{1,8\\}\\)*")
+
+(put 'ENTITY 'rng-xsd-convert (get 'NCName 'rng-xsd-convert))
+(put 'ENTITY 'rng-xsd-length 'length)
+(put 'ID 'rng-xsd-convert (get 'NCName 'rng-xsd-convert))
+(put 'ID 'rng-xsd-length 'length)
+(put 'IDREF 'rng-xsd-convert (get 'NCName 'rng-xsd-convert))
+(put 'IDREF 'rng-xsd-length 'length)
+
+(defun rng-xsd-def-list-type (name member-name)
+ (put name 'rng-xsd-convert (cons 'rng-xsd-convert-list
+ (get member-name 'rng-xsd-convert)))
+ (put name 'rng-xsd-length 'length))
+
+(rng-xsd-def-list-type 'NMTOKENS 'NMTOKEN)
+(rng-xsd-def-list-type 'IDREFS 'IDREF)
+(rng-xsd-def-list-type 'ENTITIES 'ENTITY)
+
+(put 'anyURI 'rng-xsd-convert '(rng-xsd-convert-any-uri))
+(put 'anyURI 'rng-xsd-length 'length)
+
+(put 'QName 'rng-xsd-convert '(rng-xsd-convert-qname))
+(put 'NOTATION 'rng-xsd-convert '(rng-xsd-convert-qname))
+
+(defconst rng-xsd-long-max "9223372036854775807")
+(defconst rng-xsd-long-min "-9223372036854775808")
+(defconst rng-xsd-int-max "2147483647")
+(defconst rng-xsd-int-min "-2147483648")
+(defconst rng-xsd-short-max "32767")
+(defconst rng-xsd-short-min "-32768")
+(defconst rng-xsd-byte-max "127")
+(defconst rng-xsd-byte-min "-128")
+(defconst rng-xsd-unsigned-long-max "18446744073709551615")
+(defconst rng-xsd-unsigned-int-max "4294967295")
+(defconst rng-xsd-unsigned-short-max "65535")
+(defconst rng-xsd-unsigned-byte-max "255")
+
+(rng-xsd-def-integer-type 'nonNegativeInteger "0" nil)
+(rng-xsd-def-integer-type 'positiveInteger "1" nil)
+(rng-xsd-def-integer-type 'nonPositiveInteger nil "0")
+(rng-xsd-def-integer-type 'negativeInteger nil "-1")
+(rng-xsd-def-integer-type 'long rng-xsd-long-min rng-xsd-long-max)
+(rng-xsd-def-integer-type 'int rng-xsd-int-min rng-xsd-int-max)
+(rng-xsd-def-integer-type 'short rng-xsd-short-min rng-xsd-short-max)
+(rng-xsd-def-integer-type 'byte rng-xsd-byte-min rng-xsd-byte-max)
+(rng-xsd-def-integer-type 'unsignedLong "0" rng-xsd-unsigned-long-max)
+(rng-xsd-def-integer-type 'unsignedInt "0" rng-xsd-unsigned-int-max)
+(rng-xsd-def-integer-type 'unsignedShort "0" rng-xsd-unsigned-short-max)
+(rng-xsd-def-integer-type 'unsignedByte "0" rng-xsd-unsigned-byte-max)
+
+(defun rng-xsd-def-date-time-type (name template)
+ (put name 'rng-xsd-convert (list 'rng-xsd-convert-date-time
+ (rng-xsd-make-date-time-regexp template)))
+ (put name 'rng-xsd-less-than 'rng-xsd-date-time<))
+
+(rng-xsd-def-date-time-type 'dateTime "Y-M-DTt")
+(rng-xsd-def-date-time-type 'time "t")
+(rng-xsd-def-date-time-type 'date "Y-M-D")
+(rng-xsd-def-date-time-type 'gYearMonth "Y-M")
+(rng-xsd-def-date-time-type 'gYear "Y")
+(rng-xsd-def-date-time-type 'gMonthDay "--M-D")
+(rng-xsd-def-date-time-type 'gDay "---D")
+(rng-xsd-def-date-time-type 'gMonth "--M")
+
+(put 'duration 'rng-xsd-convert '(rng-xsd-convert-duration))
+(put 'duration 'rng-xsd-less-than 'rng-xsd-duration<)
+
+(provide 'rng-xsd)
+
+;;; rng-xsd.el ends here
generated by cgit v1.2.3 (git 2.39.1) at 2025-04-06 19:53:12 +0000