lisp/nxml/rng-loc.el

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