Preserve point when doing untabify
[emacs.git] / lisp / nxml / rng-loc.el
blobb9e31e0a09ecf186f4718c0b2eaa793686bb5db2
1 ;;; rng-loc.el --- locate the schema to use for validation
3 ;; Copyright (C) 2003, 2007-2011 Free Software Foundation, Inc.
5 ;; Author: James Clark
6 ;; Keywords: XML, RelaxNG
8 ;; This file is part of GNU Emacs.
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.
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.
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/>.
23 ;;; Commentary:
25 ;;; Code:
27 (require 'nxml-util)
28 (require 'nxml-parse)
29 (require 'rng-parse)
30 (require 'rng-uri)
31 (require 'rng-util)
32 (require 'xmltok)
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)
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'.")
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.")
47 (defvar rng-schema-locating-file-schema nil
48 "Schema for schema locating files or nil if not yet loaded.")
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)
55 (defvar rng-schema-loader-alist '(("rnc" . rng-c-load-schema))
56 "Alist of schema extensions vs schema loader functions.")
58 (defvar rng-cached-document-element nil)
60 (defvar rng-document-type-history nil)
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))))
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
84 nil
85 'rng-document-type-history))
86 (nxml-file-parse-error
87 (nxml-display-file-parse-error err))))
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))))
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))
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))
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)))
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")))
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)))))
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))))
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<))))
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))
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)
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))))
255 (defun rng-match-namespace-rule (props)
256 (let ((document-element (rng-document-element))
257 (ns (cdr (assq 'ns props))))
258 (and document-element
260 (eq (nth 0 document-element)
261 (if (string= ns "")
263 (nxml-make-namespace ns)))
264 (rng-match-default-rule props))))
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))))))))))
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))
302 namespace)))
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))
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)))))
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)
335 (expand-file-name file-name)
338 nxml-file-name-ignore-case)
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))))
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))
352 (rng-uri-error nil)))
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)))))
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))
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))
405 (defvar rng-schema-locating-file-alist nil)
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))
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))))
429 (defconst rng-locate-namespace-uri
430 (nxml-make-namespace "http://thaiopensource.com/ns/locating-rules/1.0"))
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)))
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))
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
499 (error "No writable schema locating file configured")))
500 ((not document-file-name)
501 (if prompt
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)))))
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))))))))
547 (provide 'rng-loc)
549 ;;; rng-loc.el ends here