lisp/nxml/rng-xsd.el

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