lisp/nxml/rng-loc.el

   1 ;;; rng-loc.el --- locate the schema to use for validation
   2
   3 ;; Copyright (C) 2003, 2007-2014 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 ;;; Code:
  26
  27 (require 'nxml-util)
  28 (require 'nxml-parse)
  29 (require 'rng-parse)
  30 (require 'rng-uri)
  31 (require 'rng-util)
  32 (require 'xmltok)
  33
  34 (defvar rng-current-schema-file-name nil
  35   "Filename of schema being used for current buffer.
  36 It is nil if using a vacuous schema.")
  37 (make-variable-buffer-local 'rng-current-schema-file-name)
  38
  39 (defvar rng-schema-locating-files-default
  40   (list "schemas.xml" (expand-file-name "schema/schemas.xml" data-directory))
  41   "Default value for variable `rng-schema-locating-files'.")
  42
  43 (defvar rng-schema-locating-file-schema-file
  44   (expand-file-name "schema/locate.rnc" data-directory)
  45   "File containing schema for schema locating files.")
  46
  47 (defvar rng-schema-locating-file-schema nil
  48   "Schema for schema locating files or nil if not yet loaded.")
  49
  50 (defcustom rng-schema-locating-files rng-schema-locating-files-default
  51   "List of schema locating files."
  52   :type '(repeat file)
  53   :group 'relax-ng)
  54
  55 (defvar rng-schema-loader-alist '(("rnc" . rng-c-load-schema))
  56   "Alist of schema extensions vs schema loader functions.")
  57
  58 (defvar rng-cached-document-element nil)
  59
  60 (defvar rng-document-type-history nil)
  61
  62 (defun rng-set-document-type (type-id)
  63   (interactive (list (rng-read-type-id)))
  64   (condition-case err
  65       (when (not (string= type-id ""))
  66         (let ((schema-file (rng-locate-schema-file type-id)))
  67           (unless schema-file
  68             (error "Could not locate schema for type id `%s'" type-id))
  69           (rng-set-schema-file-1 schema-file))
  70         (rng-save-schema-location-1 t type-id)
  71         (rng-what-schema))
  72     (nxml-file-parse-error
  73      (nxml-display-file-parse-error err))))
  74
  75 (defun rng-read-type-id ()
  76   (condition-case err
  77       (let ((type-ids (rng-possible-type-ids))
  78             (completion-ignore-case nil))
  79         (completing-read "Document type id: "
  80                          (mapcar (lambda (x) (cons x nil))
  81                                  type-ids)
  82                          nil
  83                          t
  84                          nil
  85                          'rng-document-type-history))
  86     (nxml-file-parse-error
  87      (nxml-display-file-parse-error err))))
  88
  89 (defun rng-set-schema-file (filename)
  90   "Set the schema for the current buffer to the schema in FILENAME.
  91 FILENAME must be the name of a file containing a schema.
  92 The extension of FILENAME is used to determine what kind of schema it
  93 is.  The variable `rng-schema-loader-alist' maps from schema
  94 extensions to schema loader functions.  The function
  95 `rng-c-load-schema' is the loader for RELAX NG compact syntax.  The
  96 association is between the buffer and the schema: the association is
  97 lost when the buffer is killed."
  98   (interactive "fSchema file: ")
  99   (condition-case err
 100       (progn
 101         (rng-set-schema-file-1 filename)
 102         (rng-save-schema-location-1 t))
 103     (nxml-file-parse-error
 104      (nxml-display-file-parse-error err))))
 105
 106 (defun rng-set-vacuous-schema ()
 107   "Set the schema for the current buffer to allow any well-formed XML."
 108   (interactive)
 109   (rng-set-schema-file-1 nil)
 110   (rng-what-schema))
 111
 112 (defun rng-set-schema-file-1 (filename)
 113   (setq filename (and filename (expand-file-name filename)))
 114   (setq rng-current-schema
 115         (if filename
 116             (rng-load-schema filename)
 117           rng-any-element))
 118   (setq rng-current-schema-file-name filename)
 119   (run-hooks 'rng-schema-change-hook))
 120
 121 (defun rng-load-schema (filename)
 122   (let* ((extension (file-name-extension filename))
 123          (loader (cdr (assoc extension rng-schema-loader-alist))))
 124     (or loader
 125         (if extension
 126             (error "No schema loader available for file extension `%s'"
 127                    extension)
 128           (error "No schema loader available for null file extension")))
 129     (funcall loader filename)))
 130
 131 (defun rng-what-schema ()
 132   "Display a message saying what schema `rng-validate-mode' is using."
 133   (interactive)
 134   (if rng-current-schema-file-name
 135       (message "Using schema %s"
 136                (abbreviate-file-name rng-current-schema-file-name))
 137     (message "Using vacuous schema")))
 138
 139 (defun rng-auto-set-schema (&optional no-display-error)
 140   "Set the schema for this buffer based on the buffer's contents and file-name."
 141   (interactive)
 142   (condition-case err
 143       (progn
 144         (rng-set-schema-file-1 (rng-locate-schema-file))
 145         (rng-what-schema))
 146     (nxml-file-parse-error
 147      (if no-display-error
 148          (error "%s at position %s in %s"
 149                 (nth 3 err)
 150                 (nth 2 err)
 151                 (abbreviate-file-name (nth 1 err)))
 152        (nxml-display-file-parse-error err)))))
 153
 154 (defun rng-locate-schema-file (&optional type-id)
 155   "Return the file-name of the schema to use for the current buffer.
 156 Return nil if no schema could be located.
 157 If TYPE-ID is non-nil, then locate the schema for this TYPE-ID."
 158   (let* ((rng-cached-document-element nil)
 159          (schema
 160           (if type-id
 161               (cons type-id nil)
 162             (rng-locate-schema-file-using rng-schema-locating-files)))
 163          files type-ids)
 164     (while (consp schema)
 165       (setq files rng-schema-locating-files)
 166       (setq type-id (car schema))
 167       (setq schema nil)
 168       (when (member type-id type-ids)
 169         (error "Type-id loop for type-id `%s'" type-id))
 170       (setq type-ids (cons type-id type-ids))
 171       (while (and files (not schema))
 172         (setq schema
 173               (rng-locate-schema-file-from-type-id type-id
 174                                                    (car files)))
 175         (setq files (cdr files))))
 176     (and schema
 177          (rng-uri-file-name schema))))
 178
 179 (defun rng-possible-type-ids ()
 180   "Return a list of the known type IDs."
 181   (let ((files rng-schema-locating-files)
 182         type-ids)
 183     (while files
 184       (setq type-ids (rng-possible-type-ids-using (car files) type-ids))
 185       (setq files (cdr files)))
 186     (rng-uniquify-equal (sort type-ids 'string<))))
 187
 188 (defun rng-locate-schema-file-using (files)
 189   "Locate a schema using the schema locating files FILES.
 190 FILES is a list of file-names.
 191 Return either a URI, a list (TYPE-ID) where TYPE-ID is a string,
 192 or nil."
 193   (let (rules
 194         ;; List of types that override normal order-based
 195         ;; priority, most important first
 196         preferred-types
 197         ;; Best result found so far; same form as return value.
 198         best-so-far)
 199     (while (and (progn
 200                   (while (and (not rules) files)
 201                     (setq rules (rng-get-parsed-schema-locating-file
 202                                  (car files)))
 203                     (setq files (cdr files)))
 204                   rules)
 205                 (or (not best-so-far) preferred-types))
 206       (let* ((rule (car rules))
 207              (rule-type (car rule))
 208              (rule-matcher (get rule-type 'rng-rule-matcher)))
 209         (setq rules (cdr rules))
 210         (cond (rule-matcher
 211                (when (and (or (not best-so-far)
 212                               (memq rule-type preferred-types)))
 213                           (setq best-so-far
 214                                 (funcall rule-matcher (cdr rule)))
 215                           preferred-types)
 216                  (setq preferred-types
 217                        (nbutlast preferred-types
 218                                  (length (memq rule-type preferred-types)))))
 219               ((eq rule-type 'applyFollowingRules)
 220                (when (not best-so-far)
 221                  (let ((prefer (cdr (assq 'ruleType (cdr rule)))))
 222                    (when (and prefer
 223                               (not (memq (setq prefer (intern prefer))
 224                                          preferred-types)))
 225                      (setq preferred-types
 226                            (nconc preferred-types (list prefer)))))))
 227               ((eq rule-type 'include)
 228                (let ((uri (cdr (assq 'rules (cdr rule)))))
 229                  (when uri
 230                    (setq rules
 231                          (append (rng-get-parsed-schema-locating-file
 232                                   (rng-uri-file-name uri))
 233                                  rules))))))))
 234     best-so-far))
 235
 236 (put 'documentElement 'rng-rule-matcher 'rng-match-document-element-rule)
 237 (put 'namespace 'rng-rule-matcher 'rng-match-namespace-rule)
 238 (put 'uri 'rng-rule-matcher 'rng-match-uri-rule)
 239 (put 'transformURI 'rng-rule-matcher 'rng-match-transform-uri-rule)
 240 (put 'default 'rng-rule-matcher 'rng-match-default-rule)
 241
 242 (defun rng-match-document-element-rule (props)
 243   (let ((document-element (rng-document-element))
 244         (prefix (cdr (assq 'prefix props)))
 245         (local-name (cdr (assq 'localName props))))
 246     (and (or (not prefix)
 247              (if (= (length prefix) 0)
 248                  (not (nth 1 document-element))
 249                (string= prefix (nth 1 document-element))))
 250          (or (not local-name)
 251              (string= local-name
 252                       (nth 2 document-element)))
 253          (rng-match-default-rule props))))
 254
 255 (defun rng-match-namespace-rule (props)
 256   (let ((document-element (rng-document-element))
 257         (ns (cdr (assq 'ns props))))
 258     (and document-element
 259          ns
 260          (eq (nth 0 document-element)
 261              (if (string= ns "")
 262                  nil
 263                (nxml-make-namespace ns)))
 264          (rng-match-default-rule props))))
 265
 266 (defun rng-document-element ()
 267   "Return a list (NS PREFIX LOCAL-NAME).
 268 NS is t if the document has a non-nil, but not otherwise known namespace."
 269   (or rng-cached-document-element
 270       (setq rng-cached-document-element
 271             (save-excursion
 272               (save-restriction
 273                 (widen)
 274                 (goto-char (point-min))
 275                 (let (xmltok-dtd)
 276                   (xmltok-save
 277                    (xmltok-forward-prolog)
 278                    (xmltok-forward)
 279                    (when (memq xmltok-type '(start-tag
 280                                              partial-start-tag
 281                                              empty-element
 282                                              partial-empty-element))
 283                      (list (rng-get-start-tag-namespace)
 284                            (xmltok-start-tag-prefix)
 285                            (xmltok-start-tag-local-name))))))))))
 286
 287 (defun rng-get-start-tag-namespace ()
 288   (let ((prefix (xmltok-start-tag-prefix))
 289         namespace att value)
 290     (while xmltok-namespace-attributes
 291       (setq att (car xmltok-namespace-attributes))
 292       (setq xmltok-namespace-attributes (cdr xmltok-namespace-attributes))
 293       (when (if prefix
 294                 (and (xmltok-attribute-prefix att)
 295                      (string= (xmltok-attribute-local-name att)
 296                               prefix))
 297               (not (xmltok-attribute-prefix att)))
 298         (setq value (xmltok-attribute-value att))
 299         (setq namespace (if value (nxml-make-namespace value) t))))
 300     (if (and prefix (not namespace))
 301         t
 302       namespace)))
 303
 304 (defun rng-match-transform-uri-rule (props)
 305   (let ((from-pattern (cdr (assq 'fromPattern props)))
 306         (to-pattern (cdr (assq 'toPattern props)))
 307         (file-name (buffer-file-name)))
 308     (and file-name
 309          (setq file-name (expand-file-name file-name))
 310          (rng-file-name-matches-uri-pattern-p file-name from-pattern)
 311          (condition-case ()
 312              (let ((new-file-name
 313                     (replace-match
 314                      (save-match-data
 315                        (rng-uri-pattern-file-name-replace-match to-pattern))
 316                      t
 317                      nil
 318                      file-name)))
 319                (and (file-name-absolute-p new-file-name)
 320                     (file-exists-p new-file-name)
 321                     (rng-file-name-uri new-file-name)))
 322              (rng-uri-error nil)))))
 323
 324 (defun rng-match-uri-rule (props)
 325   (let ((resource (cdr (assq 'resource props)))
 326         (pattern (cdr (assq 'pattern props)))
 327         (file-name (buffer-file-name)))
 328     (and file-name
 329          (setq file-name (expand-file-name file-name))
 330          (cond (resource
 331                 (condition-case ()
 332                     (eq (compare-strings (rng-uri-file-name resource)
 333                                          0
 334                                          nil
 335                                          (expand-file-name file-name)
 336                                          0
 337                                          nil
 338                                          nxml-file-name-ignore-case)
 339                         t)
 340                   (rng-uri-error nil)))
 341                (pattern
 342                 (rng-file-name-matches-uri-pattern-p file-name
 343                                                      pattern)))
 344          (rng-match-default-rule props))))
 345
 346 (defun rng-file-name-matches-uri-pattern-p (file-name pattern)
 347   (condition-case ()
 348       (and (let ((case-fold-search nxml-file-name-ignore-case))
 349              (string-match (rng-uri-pattern-file-name-regexp pattern)
 350                            file-name))
 351            t)
 352     (rng-uri-error nil)))
 353
 354 (defun rng-match-default-rule (props)
 355   (or (cdr (assq 'uri props))
 356       (let ((type-id (cdr (assq 'typeId props))))
 357         (and type-id
 358              (cons (rng-collapse-space type-id) nil)))))
 359
 360 (defun rng-possible-type-ids-using (file type-ids)
 361   (let ((rules (rng-get-parsed-schema-locating-file file))
 362         rule)
 363     (while rules
 364       (setq rule (car rules))
 365       (setq rules (cdr rules))
 366       (cond ((eq (car rule) 'typeId)
 367              (let ((id (cdr (assq 'id (cdr rule)))))
 368                (when id
 369                  (setq type-ids
 370                        (cons (rng-collapse-space id)
 371                              type-ids)))))
 372             ((eq (car rule) 'include)
 373              (let ((uri (cdr (assq 'rules (cdr rule)))))
 374                (when uri
 375                  (setq type-ids
 376                        (rng-possible-type-ids-using
 377                         (rng-get-parsed-schema-locating-file
 378                          (rng-uri-file-name uri))
 379                         type-ids)))))))
 380     type-ids))
 381
 382 (defun rng-locate-schema-file-from-type-id (type-id file)
 383   "Locate the schema for type id TYPE-ID using schema locating file FILE.
 384 Return either a URI, a list (TYPE-ID) where TYPE-ID is a string,
 385 or nil."
 386   (let ((rules (rng-get-parsed-schema-locating-file file))
 387         schema rule)
 388     (while (and rules (not schema))
 389       (setq rule (car rules))
 390       (setq rules (cdr rules))
 391       (cond ((and (eq (car rule) 'typeId)
 392                   (let ((id (assq 'id (cdr rule))))
 393                     (and id
 394                          (string= (rng-collapse-space (cdr id)) type-id))))
 395              (setq schema (rng-match-default-rule (cdr rule))))
 396             ((eq (car rule) 'include)
 397              (let ((uri (cdr (assq 'rules (cdr rule)))))
 398                (when uri
 399                  (setq schema
 400                        (rng-locate-schema-file-from-type-id
 401                         type-id
 402                         (rng-uri-file-name uri))))))))
 403     schema))
 404
 405 (defvar rng-schema-locating-file-alist nil)
 406
 407 (defun rng-get-parsed-schema-locating-file (file)
 408   "Return a list of rules for the schema locating file FILE."
 409   (setq file (expand-file-name file))
 410   (let ((cached (assoc file rng-schema-locating-file-alist))
 411         (mtime (nth 5 (file-attributes file)))
 412         parsed)
 413     (cond ((not mtime)
 414            (when cached
 415              (setq rng-schema-locating-file-alist
 416                    (delq cached rng-schema-locating-file-alist)))
 417            nil)
 418           ((and cached (equal (nth 1 cached) mtime))
 419            (nth 2 cached))
 420           (t
 421            (setq parsed (rng-parse-schema-locating-file file))
 422            (if cached
 423                (setcdr cached (list mtime parsed))
 424              (setq rng-schema-locating-file-alist
 425                    (cons (list file mtime parsed)
 426                          rng-schema-locating-file-alist)))
 427            parsed))))
 428
 429 (defconst rng-locate-namespace-uri
 430   (nxml-make-namespace "http://thaiopensource.com/ns/locating-rules/1.0"))
 431
 432 (defun rng-parse-schema-locating-file (file)
 433   "Return list of rules.
 434 Each rule has the form (TYPE (ATTR . VAL) ...), where
 435 TYPE is a symbol for the element name, ATTR is a symbol for the attribute
 436 and VAL is a string for the value.
 437 Attribute values representing URIs are made absolute and xml:base
 438 attributes are removed."
 439   (when (and (not rng-schema-locating-file-schema)
 440              rng-schema-locating-file-schema-file)
 441     (setq rng-schema-locating-file-schema
 442           (rng-load-schema rng-schema-locating-file-schema-file)))
 443   (let* ((element
 444           (if rng-schema-locating-file-schema
 445               (rng-parse-validate-file rng-schema-locating-file-schema
 446                                        file)
 447             (nxml-parse-file file)))
 448          (children (cddr element))
 449          (base-uri (rng-file-name-uri file))
 450          child name rules atts att props prop-name prop-value)
 451     (when (equal (car element)
 452                  (cons rng-locate-namespace-uri "locatingRules"))
 453       (while children
 454         (setq child (car children))
 455         (setq children (cdr children))
 456         (when (consp child)
 457           (setq name (car child))
 458           (when (eq (car name) rng-locate-namespace-uri)
 459             (setq atts (cadr child))
 460             (setq props nil)
 461             (while atts
 462               (setq att (car atts))
 463               (when (stringp (car att))
 464                 (setq prop-name (intern (car att)))
 465                 (setq prop-value (cdr att))
 466                 (when (memq prop-name '(uri rules resource))
 467                   (setq prop-value
 468                         (rng-uri-resolve prop-value base-uri)))
 469                 (setq props (cons (cons prop-name prop-value)
 470                                   props)))
 471               (setq atts (cdr atts)))
 472             (setq rules
 473                   (cons (cons (intern (cdr name)) (nreverse props))
 474                         rules))))))
 475     (nreverse rules)))
 476
 477 (defun rng-save-schema-location ()
 478   "Save the association between the buffer's file and the current schema.
 479 This ensures that the schema that is currently being used will be used
 480 if the file is edited in a future session.  The association will be
 481 saved to the first writable file in `rng-schema-locating-files'."
 482   (interactive)
 483   (rng-save-schema-location-1 nil))
 484
 485 (defun rng-save-schema-location-1 (prompt &optional type-id)
 486   (unless (or rng-current-schema-file-name type-id)
 487     (error "Buffer is using a vacuous schema"))
 488   (let ((files rng-schema-locating-files)
 489         (document-file-name (buffer-file-name))
 490         (schema-file-name rng-current-schema-file-name)
 491         file)
 492     (while (and files (not file))
 493       (if (file-writable-p (car files))
 494           (setq file (expand-file-name (car files)))
 495         (setq files (cdr files))))
 496     (cond ((not file)
 497            (if prompt
 498                nil
 499              (error "No writable schema locating file configured")))
 500           ((not document-file-name)
 501            (if prompt
 502                nil
 503              (error "Buffer does not have a filename")))
 504           ((and prompt
 505                 (not (y-or-n-p (format "Save %s to %s "
 506                                        (if type-id
 507                                            "type identifier"
 508                                          "schema location")
 509                                        file)))))
 510           (t
 511            (with-current-buffer (find-file-noselect file)
 512              (let ((modified (buffer-modified-p)))
 513                (if (> (buffer-size) 0)
 514                    (let (xmltok-dtd)
 515                      (goto-char (point-min))
 516                      (xmltok-save
 517                        (xmltok-forward-prolog)
 518                        (xmltok-forward)
 519                        (unless (eq xmltok-type 'start-tag)
 520                          (error "Locating file `%s' invalid" file))))
 521                  (insert "<?xml version=\"1.0\"?>\n"
 522                          "<locatingRules xmlns=\""
 523                          (nxml-namespace-name rng-locate-namespace-uri)
 524                          "\">")
 525                  (let ((pos (point)))
 526                    (insert "\n</locatingRules>\n")
 527                    (goto-char pos)))
 528                (insert "\n")
 529                (insert (let ((locating-file-uri (rng-file-name-uri file)))
 530                          (format "<uri resource=\"%s\" %s=\"%s\"/>"
 531                                  (rng-escape-string
 532                                   (rng-relative-uri
 533                                    (rng-file-name-uri document-file-name)
 534                                    locating-file-uri))
 535                                  (if type-id "typeId" "uri")
 536                                  (rng-escape-string
 537                                   (or type-id
 538                                       (rng-relative-uri
 539                                        (rng-file-name-uri schema-file-name)
 540                                        locating-file-uri))))))
 541                (indent-according-to-mode)
 542                (when (or (not modified)
 543                          (y-or-n-p (format "Save file %s "
 544                                            (buffer-file-name))))
 545                  (save-buffer))))))))
 546
 547 (provide 'rng-loc)
 548
 549 ;;; rng-loc.el ends here