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