code.delx.au - gnu-emacs/blob - lisp/nxml/rng-loc.el

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