lisp/nxml/rng-loc.el

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