Mercurial > emacs
annotate lisp/nxml/rng-loc.el @ 101922:8074f7b69818
Avoid messing up font-lock-global-modes.
author | Glenn Morris <rgm@gnu.org> |
---|---|
date | Tue, 10 Feb 2009 05:23:35 +0000 |
parents | a9dc0e7c3f2b |
children | 3367f0022cf2 |
rev | line source |
---|---|
86361 | 1 ;;; rng-loc.el --- locate the schema to use for validation |
2 | |
100908 | 3 ;; Copyright (C) 2003, 2007, 2008, 2009 Free Software Foundation, Inc. |
86361 | 4 |
5 ;; Author: James Clark | |
6 ;; Keywords: XML, RelaxNG | |
7 | |
86547 | 8 ;; This file is part of GNU Emacs. |
9 | |
94666
d495d4d5452f
Switch to recommended form of GPLv3 permissions notice.
Glenn Morris <rgm@gnu.org>
parents:
87665
diff
changeset
|
10 ;; GNU Emacs is free software: you can redistribute it and/or modify |
86547 | 11 ;; it under the terms of the GNU General Public License as published by |
94666
d495d4d5452f
Switch to recommended form of GPLv3 permissions notice.
Glenn Morris <rgm@gnu.org>
parents:
87665
diff
changeset
|
12 ;; the Free Software Foundation, either version 3 of the License, or |
d495d4d5452f
Switch to recommended form of GPLv3 permissions notice.
Glenn Morris <rgm@gnu.org>
parents:
87665
diff
changeset
|
13 ;; (at your option) any later version. |
86361 | 14 |
86547 | 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. | |
86361 | 19 |
86547 | 20 ;; You should have received a copy of the GNU General Public License |
94666
d495d4d5452f
Switch to recommended form of GPLv3 permissions notice.
Glenn Morris <rgm@gnu.org>
parents:
87665
diff
changeset
|
21 ;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>. |
86361 | 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. | |
96496
e374c747704b
Fix typos, and general docstring cleanup.
Juanma Barranquero <lekktu@gmail.com>
parents:
94666
diff
changeset
|
36 It is nil if using a vacuous schema.") |
86361 | 37 (make-variable-buffer-local 'rng-current-schema-file-name) |
38 | |
87324
c2d365f73e14
(rng-schema-locating-files-default)
Jason Rumney <jasonr@gnu.org>
parents:
86547
diff
changeset
|
39 (defvar rng-schema-locating-files-default |
87328
9c863134ecd3
(rng-schema-locating-file-schema-file): Fix last change.
Jason Rumney <jasonr@gnu.org>
parents:
87324
diff
changeset
|
40 (list "schemas.xml" (expand-file-name "schema/schemas.xml" data-directory)) |
86361 | 41 "Default value for variable `rng-schema-locating-files'.") |
42 | |
87324
c2d365f73e14
(rng-schema-locating-files-default)
Jason Rumney <jasonr@gnu.org>
parents:
86547
diff
changeset
|
43 (defvar rng-schema-locating-file-schema-file |
87328
9c863134ecd3
(rng-schema-locating-file-schema-file): Fix last change.
Jason Rumney <jasonr@gnu.org>
parents:
87324
diff
changeset
|
44 (expand-file-name "schema/locate.rnc" data-directory) |
86361 | 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 | |
87324
c2d365f73e14
(rng-schema-locating-files-default)
Jason Rumney <jasonr@gnu.org>
parents:
86547
diff
changeset
|
55 (defvar rng-schema-loader-alist '(("rnc" . rng-c-load-schema)) |
86361 | 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 | |
96496
e374c747704b
Fix typos, and general docstring cleanup.
Juanma Barranquero <lekktu@gmail.com>
parents:
94666
diff
changeset
|
94 extensions to schema loader functions. The function |
86361 | 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)) | |
96496
e374c747704b
Fix typos, and general docstring cleanup.
Juanma Barranquero <lekktu@gmail.com>
parents:
94666
diff
changeset
|
120 |
86361 | 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 | |
96496
e374c747704b
Fix typos, and general docstring cleanup.
Juanma Barranquero <lekktu@gmail.com>
parents:
94666
diff
changeset
|
135 (message "Using schema %s" |
86361 | 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. | |
96496
e374c747704b
Fix typos, and general docstring cleanup.
Juanma Barranquero <lekktu@gmail.com>
parents:
94666
diff
changeset
|
191 Return either a URI, a list (TYPE-ID) where TYPE-ID is a string, |
86361 | 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. | |
96496
e374c747704b
Fix typos, and general docstring cleanup.
Juanma Barranquero <lekktu@gmail.com>
parents:
94666
diff
changeset
|
384 Return either a URI, a list (TYPE-ID) where TYPE-ID is a string, |
86361 | 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)))) | |
96496
e374c747704b
Fix typos, and general docstring cleanup.
Juanma Barranquero <lekktu@gmail.com>
parents:
94666
diff
changeset
|
428 |
86361 | 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 (save-excursion | |
512 (set-buffer (find-file-noselect file)) | |
513 (let ((modified (buffer-modified-p))) | |
514 (if (> (buffer-size) 0) | |
515 (let (xmltok-dtd) | |
516 (goto-char (point-min)) | |
517 (xmltok-save | |
518 (xmltok-forward-prolog) | |
519 (xmltok-forward) | |
520 (unless (eq xmltok-type 'start-tag) | |
521 (error "Locating file `%s' invalid" file)))) | |
522 (insert "<?xml version=\"1.0\"?>\n" | |
523 "<locatingRules xmlns=\"" | |
524 (nxml-namespace-name rng-locate-namespace-uri) | |
525 "\">") | |
526 (let ((pos (point))) | |
527 (insert "\n</locatingRules>\n") | |
528 (goto-char pos))) | |
529 (insert "\n") | |
530 (insert (let ((locating-file-uri (rng-file-name-uri file))) | |
531 (format "<uri resource=\"%s\" %s=\"%s\"/>" | |
532 (rng-escape-string | |
533 (rng-relative-uri | |
534 (rng-file-name-uri document-file-name) | |
535 locating-file-uri)) | |
536 (if type-id "typeId" "uri") | |
537 (rng-escape-string | |
538 (or type-id | |
539 (rng-relative-uri | |
540 (rng-file-name-uri schema-file-name) | |
541 locating-file-uri)))))) | |
542 (indent-according-to-mode) | |
543 (when (or (not modified) | |
544 (y-or-n-p (format "Save file %s " | |
545 (buffer-file-name)))) | |
546 (save-buffer)))))))) | |
547 | |
548 (provide 'rng-loc) | |
549 | |
86379 | 550 ;; arch-tag: 725cf968-37a2-418b-b47b-d5209871a9ab |
86361 | 551 ;;; rng-loc.el ends here |