1 ;;; rng-loc.el --- locate the schema to use for validation
3 ;; Copyright (C) 2003, 2007, 2008 Free Software Foundation, Inc.
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/>.
34 (defvar rng-current-schema-file-name nil
35 "Filename of schema being used for current buffer.
36 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."
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)))
65 (when (not (string= type-id
""))
66 (let ((schema-file (rng-locate-schema-file type-id
)))
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
)
72 (nxml-file-parse-error
73 (nxml-display-file-parse-error err
))))
75 (defun rng-read-type-id ()
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
))
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: ")
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."
109 (rng-set-schema-file-1 nil
)
112 (defun rng-set-schema-file-1 (filename)
113 (setq filename
(and filename
(expand-file-name filename
)))
114 (setq rng-current-schema
116 (rng-load-schema filename
)
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
))))
126 (error "No schema loader available for file extension `%s'"
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."
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."
144 (rng-set-schema-file-1 (rng-locate-schema-file))
146 (nxml-file-parse-error
148 (error "%s at position %s in %s"
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
)
162 (rng-locate-schema-file-using rng-schema-locating-files
)))
164 (while (consp schema
)
165 (setq files rng-schema-locating-files
)
166 (setq type-id
(car schema
))
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
))
173 (rng-locate-schema-file-from-type-id type-id
175 (setq files
(cdr files
))))
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
)
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
194 ;; List of types that override normal order-based
195 ;; priority, most important first
197 ;; Best result found so far; same form as return value.
200 (while (and (not rules
) files
)
201 (setq rules
(rng-get-parsed-schema-locating-file
203 (setq files
(cdr files
)))
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
))
211 (when (and (or (not best-so-far
)
212 (memq rule-type preferred-types
)))
214 (funcall rule-matcher
(cdr rule
)))
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
)))))
223 (not (memq (setq prefer
(intern prefer
))
225 (setq preferred-types
226 (nconc preferred-types
(list prefer
)))))))
227 ((eq rule-type
'include
)
228 (let ((uri (cdr (assq 'rules
(cdr rule
)))))
231 (append (rng-get-parsed-schema-locating-file
232 (rng-uri-file-name uri
))
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
))))
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
)
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
274 (goto-char (point-min))
277 (xmltok-forward-prolog)
279 (when (memq xmltok-type
'(start-tag
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))
290 (while xmltok-namespace-attributes
291 (setq att
(car xmltok-namespace-attributes
))
292 (setq xmltok-namespace-attributes
(cdr xmltok-namespace-attributes
))
294 (and (xmltok-attribute-prefix att
)
295 (string= (xmltok-attribute-local-name att
)
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
))
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)))
309 (setq file-name
(expand-file-name file-name
))
310 (rng-file-name-matches-uri-pattern-p file-name from-pattern
)
315 (rng-uri-pattern-file-name-replace-match to-pattern
))
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)))
329 (setq file-name
(expand-file-name file-name
))
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
)))
342 (rng-file-name-matches-uri-pattern-p file-name
344 (rng-match-default-rule props
))))
346 (defun rng-file-name-matches-uri-pattern-p (file-name pattern
)
348 (and (let ((case-fold-search nxml-file-name-ignore-case
))
349 (string-match (rng-uri-pattern-file-name-regexp pattern
)
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
))))
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
))
364 (setq rule
(car rules
))
365 (setq rules
(cdr rules
))
366 (cond ((eq (car rule
) 'typeId
)
367 (let ((id (cdr (assq 'id
(cdr rule
)))))
370 (cons (rng-collapse-space id
)
372 ((eq (car rule
) 'include
)
373 (let ((uri (cdr (assq 'rules
(cdr rule
)))))
376 (rng-possible-type-ids-using
377 (rng-get-parsed-schema-locating-file
378 (rng-uri-file-name uri
))
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
386 (let ((rules (rng-get-parsed-schema-locating-file file
))
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
))))
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
)))))
400 (rng-locate-schema-file-from-type-id
402 (rng-uri-file-name uri
))))))))
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
)))
415 (setq rng-schema-locating-file-alist
416 (delq cached rng-schema-locating-file-alist
)))
418 ((and cached
(equal (nth 1 cached
) mtime
))
421 (setq parsed
(rng-parse-schema-locating-file file
))
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
)))
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
)))
444 (if rng-schema-locating-file-schema
445 (rng-parse-validate-file rng-schema-locating-file-schema
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"))
454 (setq child
(car children
))
455 (setq children
(cdr children
))
457 (setq name
(car child
))
458 (when (eq (car name
) rng-locate-namespace-uri
)
459 (setq atts
(cadr child
))
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
))
468 (rng-uri-resolve prop-value base-uri
)))
469 (setq props
(cons (cons prop-name prop-value
)
471 (setq atts
(cdr atts
)))
473 (cons (cons (intern (cdr name
)) (nreverse props
))
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'."
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
)
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
))))
499 (error "No writable schema locating file configured")))
500 ((not document-file-name
)
503 (error "Buffer does not have a filename")))
505 (not (y-or-n-p (format "Save %s to %s "
512 (set-buffer (find-file-noselect file
))
513 (let ((modified (buffer-modified-p)))
514 (if (> (buffer-size) 0)
516 (goto-char (point-min))
518 (xmltok-forward-prolog)
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
)
527 (insert "\n</locatingRules>\n")
530 (insert (let ((locating-file-uri (rng-file-name-uri file
)))
531 (format "<uri resource=\"%s\" %s=\"%s\"/>"
534 (rng-file-name-uri document-file-name
)
536 (if type-id
"typeId" "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))))
550 ;; arch-tag: 725cf968-37a2-418b-b47b-d5209871a9ab
551 ;;; rng-loc.el ends here