[Emacs-diffs] Changes to lisp/nxml/rng-xsd.el

[Mark A. Hershberger]

CVSROOT:        /sources/emacs
Module name:    emacs
Changes by:     Mark A. Hershberger <hexmode>   07/11/23 06:58:00

Index: lisp/nxml/rng-xsd.el
===================================================================
RCS file: lisp/nxml/rng-xsd.el
diff -N lisp/nxml/rng-xsd.el
--- /dev/null   1 Jan 1970 00:00:00 -0000
+++ lisp/nxml/rng-xsd.el        23 Nov 2007 06:57:51 -0000      1.1
@@ -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