lisp/nxml/rng-xsd.el

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