lisp/nxml/rng-loc.el

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