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