Mercurial > emacs
annotate lisp/nxml/rng-nxml.el @ 93866:1f769203aa6c
*** empty log message ***
author | Juanma Barranquero <lekktu@gmail.com> |
---|---|
date | Tue, 08 Apr 2008 14:57:02 +0000 |
parents | d88d7b016e11 |
children | d495d4d5452f |
rev | line source |
---|---|
86361 | 1 ;;; rng-nxml.el --- make nxml-mode take advantage of rng-validate-mode |
2 | |
87665 | 3 ;; Copyright (C) 2003, 2007, 2008 Free Software Foundation, Inc. |
86361 | 4 |
5 ;; Author: James Clark | |
6 ;; Keywords: XML, RelaxNG | |
7 | |
86550 | 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, or (at your option) | |
13 ;; any later version. | |
86361 | 14 |
86550 | 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 |
86550 | 20 ;; You should have received a copy of the GNU General Public License |
21 ;; along with GNU Emacs; see the file COPYING. If not, write to the | |
22 ;; Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, | |
23 ;; Boston, MA 02110-1301, USA. | |
86361 | 24 |
25 ;;; Commentary: | |
26 | |
27 ;;; Code: | |
28 | |
29 (require 'easymenu) | |
30 (require 'xmltok) | |
31 (require 'nxml-util) | |
32 (require 'nxml-ns) | |
33 (require 'rng-match) | |
34 (require 'rng-util) | |
35 (require 'rng-valid) | |
36 (require 'nxml-mode) | |
37 (require 'rng-loc) | |
38 | |
39 (defcustom rng-nxml-auto-validate-flag t | |
40 "*Non-nil means automatically turn on validation with nxml-mode." | |
41 :type 'boolean | |
42 :group 'relax-ng) | |
43 | |
87717
f13f60e81ce8
(rng-preferred-prefix-alist): Add some defaults.
Jason Rumney <jasonr@gnu.org>
parents:
87665
diff
changeset
|
44 (defcustom rng-preferred-prefix-alist |
f13f60e81ce8
(rng-preferred-prefix-alist): Add some defaults.
Jason Rumney <jasonr@gnu.org>
parents:
87665
diff
changeset
|
45 '(("http://www.w3.org/1999/XSL/Transform" . "xsl") |
f13f60e81ce8
(rng-preferred-prefix-alist): Add some defaults.
Jason Rumney <jasonr@gnu.org>
parents:
87665
diff
changeset
|
46 ("http://www.w3.org/1999/02/22-rdf-syntax-ns#" . "rdf") |
f13f60e81ce8
(rng-preferred-prefix-alist): Add some defaults.
Jason Rumney <jasonr@gnu.org>
parents:
87665
diff
changeset
|
47 ("http://www.w3.org/1999/xlink" . "xlink") |
f13f60e81ce8
(rng-preferred-prefix-alist): Add some defaults.
Jason Rumney <jasonr@gnu.org>
parents:
87665
diff
changeset
|
48 ("http://www.w3.org/2001/XmlSchema" . "xsd") |
92468
d88d7b016e11
(rng-preferred-prefix-alist): Add dublin core namespaces.
Jason Rumney <jasonr@gnu.org>
parents:
87797
diff
changeset
|
49 ("http://www.w3.org/2001/XMLSchema-instance" . "xsi") |
d88d7b016e11
(rng-preferred-prefix-alist): Add dublin core namespaces.
Jason Rumney <jasonr@gnu.org>
parents:
87797
diff
changeset
|
50 ("http://purl.org/dc/elements/1.1/" . "dc") |
d88d7b016e11
(rng-preferred-prefix-alist): Add dublin core namespaces.
Jason Rumney <jasonr@gnu.org>
parents:
87797
diff
changeset
|
51 ("http://purl.org/dc/terms/" . "dcterms")) |
86361 | 52 "*Alist of namespaces vs preferred prefixes." |
53 :type '(repeat (cons :tag "With" | |
54 (string :tag "this namespace URI") | |
55 (string :tag "use this prefix"))) | |
56 :group 'relax-ng) | |
57 | |
58 (defvar rng-complete-end-tags-after-< t | |
59 "*Non-nil means immediately after < complete on end-tag names. | |
60 Complete on start-tag names regardless.") | |
61 | |
62 (defvar rng-nxml-easy-menu | |
63 '("XML" | |
64 ["Show Outline Only" nxml-hide-all-text-content] | |
65 ["Show Everything" nxml-show-all] | |
66 "---" | |
67 ["Validation" rng-validate-mode | |
68 :style toggle | |
69 :selected rng-validate-mode] | |
70 "---" | |
71 ("Set Schema" | |
72 ["Automatically" rng-auto-set-schema] | |
73 ("For Document Type" | |
74 :filter (lambda (menu) | |
75 (mapcar (lambda (type-id) | |
76 (vector type-id | |
77 (list 'rng-set-document-type | |
78 type-id))) | |
79 (rng-possible-type-ids)))) | |
80 ["Any Well-Formed XML" rng-set-vacuous-schema] | |
81 ["File..." rng-set-schema-file]) | |
82 ["Show Schema Location" rng-what-schema] | |
83 ["Save Schema Location" rng-save-schema-location :help | |
84 "Save the location of the schema currently being used for this buffer"] | |
85 "---" | |
86 ["First Error" rng-first-error :active rng-validate-mode] | |
87 ["Next Error" rng-next-error :active rng-validate-mode] | |
88 "---" | |
87347
5d0236f8335b
(rng-nxml-easy-menu): Remove nxml-version.
Jason Rumney <jasonr@gnu.org>
parents:
86550
diff
changeset
|
89 ["Customize nXML" (customize-group 'nxml)])) |
86361 | 90 |
91 ;;;###autoload | |
92 (defun rng-nxml-mode-init () | |
93 "Initialize `nxml-mode' to take advantage of `rng-validate-mode'. | |
94 This is typically called from `nxml-mode-hook'. | |
95 Validation will be enabled if `rng-nxml-auto-validate-flag' is non-nil." | |
96 (interactive) | |
97 (define-key nxml-mode-map "\C-c\C-v" 'rng-validate-mode) | |
98 (define-key nxml-mode-map "\C-c\C-s\C-w" 'rng-what-schema) | |
99 (define-key nxml-mode-map "\C-c\C-s\C-a" 'rng-auto-set-schema-and-validate) | |
100 (define-key nxml-mode-map "\C-c\C-s\C-f" 'rng-set-schema-file-and-validate) | |
101 (define-key nxml-mode-map "\C-c\C-s\C-l" 'rng-save-schema-location) | |
102 (define-key nxml-mode-map "\C-c\C-s\C-t" 'rng-set-document-type-and-validate) | |
103 (define-key nxml-mode-map "\C-c\C-n" 'rng-next-error) | |
104 (easy-menu-define rng-nxml-menu nxml-mode-map | |
105 "Menu for nxml-mode used with rng-validate-mode." | |
106 rng-nxml-easy-menu) | |
87792
c689fd3b9cfd
(rng-nxml-mode-init): Don't overwrite mode-line-process.
Stefan Monnier <monnier@iro.umontreal.ca>
parents:
87717
diff
changeset
|
107 (add-to-list 'mode-line-process |
87797
3305ad06c630
(rng-nxml-mode-init): Add status after the "degraded" indicator.
Stefan Monnier <monnier@iro.umontreal.ca>
parents:
87792
diff
changeset
|
108 '(rng-validate-mode (:eval (rng-compute-mode-line-string))) |
3305ad06c630
(rng-nxml-mode-init): Add status after the "degraded" indicator.
Stefan Monnier <monnier@iro.umontreal.ca>
parents:
87792
diff
changeset
|
109 'append) |
86361 | 110 (cond (rng-nxml-auto-validate-flag |
111 (rng-validate-mode 1) | |
112 (add-hook 'nxml-completion-hook 'rng-complete nil t) | |
113 (add-hook 'nxml-in-mixed-content-hook 'rng-in-mixed-content-p nil t)) | |
114 (t | |
115 (rng-validate-mode 0) | |
116 (remove-hook 'nxml-completion-hook 'rng-complete t) | |
117 (remove-hook 'nxml-in-mixed-content-hook 'rng-in-mixed-content-p t)))) | |
118 | |
119 (defvar rng-tag-history nil) | |
120 (defvar rng-attribute-name-history nil) | |
121 (defvar rng-attribute-value-history nil) | |
122 | |
123 (defvar rng-complete-target-names nil) | |
124 (defvar rng-complete-name-attribute-flag nil) | |
125 (defvar rng-complete-extra-strings nil) | |
126 | |
127 (defun rng-complete () | |
128 "Complete the string before point using the current schema. | |
129 Return non-nil if in a context it understands." | |
130 (interactive) | |
131 (and rng-validate-mode | |
132 (let ((lt-pos (save-excursion (search-backward "<" nil t))) | |
133 xmltok-dtd) | |
134 (and lt-pos | |
135 (= (rng-set-state-after lt-pos) lt-pos) | |
136 (or (rng-complete-tag lt-pos) | |
137 (rng-complete-end-tag lt-pos) | |
138 (rng-complete-attribute-name lt-pos) | |
139 (rng-complete-attribute-value lt-pos)))))) | |
140 | |
141 (defconst rng-in-start-tag-name-regex | |
142 (replace-regexp-in-string | |
143 "w" | |
144 xmltok-ncname-regexp | |
145 "<\\(?:w\\(?::w?\\)?\\)?\\=" | |
146 t | |
147 t)) | |
148 | |
149 (defun rng-complete-tag (lt-pos) | |
150 (let (rng-complete-extra-strings) | |
151 (when (and (= lt-pos (1- (point))) | |
152 rng-complete-end-tags-after-< | |
153 rng-open-elements | |
154 (not (eq (car rng-open-elements) t)) | |
155 (or rng-collecting-text | |
156 (rng-match-save | |
157 (rng-match-end-tag)))) | |
158 (setq rng-complete-extra-strings | |
159 (cons (concat "/" | |
160 (if (caar rng-open-elements) | |
161 (concat (caar rng-open-elements) | |
162 ":" | |
163 (cdar rng-open-elements)) | |
164 (cdar rng-open-elements))) | |
165 rng-complete-extra-strings))) | |
166 (when (save-excursion | |
167 (re-search-backward rng-in-start-tag-name-regex | |
168 lt-pos | |
169 t)) | |
170 (and rng-collecting-text (rng-flush-text)) | |
171 (let ((completion | |
172 (let ((rng-complete-target-names | |
173 (rng-match-possible-start-tag-names)) | |
174 (rng-complete-name-attribute-flag nil)) | |
175 (rng-complete-before-point (1+ lt-pos) | |
176 'rng-complete-qname-function | |
177 "Tag: " | |
178 nil | |
179 'rng-tag-history))) | |
180 name) | |
181 (when completion | |
182 (cond ((rng-qname-p completion) | |
183 (setq name (rng-expand-qname completion | |
184 t | |
185 'rng-start-tag-expand-recover)) | |
186 (when (and name | |
187 (rng-match-start-tag-open name) | |
188 (or (not (rng-match-start-tag-close)) | |
189 ;; need a namespace decl on the root element | |
190 (and (car name) | |
191 (not rng-open-elements)))) | |
192 ;; attributes are required | |
193 (insert " "))) | |
194 ((member completion rng-complete-extra-strings) | |
195 (insert ">"))))) | |
196 t))) | |
197 | |
198 (defconst rng-in-end-tag-name-regex | |
199 (replace-regexp-in-string | |
200 "w" | |
201 xmltok-ncname-regexp | |
202 "</\\(?:w\\(?::w?\\)?\\)?\\=" | |
203 t | |
204 t)) | |
205 | |
206 (defun rng-complete-end-tag (lt-pos) | |
207 (when (save-excursion | |
208 (re-search-backward rng-in-end-tag-name-regex | |
209 lt-pos | |
210 t)) | |
211 (cond ((or (not rng-open-elements) | |
212 (eq (car rng-open-elements) t)) | |
213 (message "No matching start-tag") | |
214 (ding)) | |
215 (t | |
216 (let ((start-tag-name | |
217 (if (caar rng-open-elements) | |
218 (concat (caar rng-open-elements) | |
219 ":" | |
220 (cdar rng-open-elements)) | |
221 (cdar rng-open-elements))) | |
222 (end-tag-name | |
223 (buffer-substring-no-properties (+ (match-beginning 0) 2) | |
224 (point)))) | |
225 (cond ((or (> (length end-tag-name) | |
226 (length start-tag-name)) | |
227 (not (string= (substring start-tag-name | |
228 0 | |
229 (length end-tag-name)) | |
230 end-tag-name))) | |
231 (message "Expected end-tag %s" | |
232 (rng-quote-string | |
233 (concat "</" start-tag-name ">"))) | |
234 (ding)) | |
235 (t | |
236 (delete-region (- (point) (length end-tag-name)) | |
237 (point)) | |
238 (insert start-tag-name ">") | |
239 (when (not (or rng-collecting-text | |
240 (rng-match-end-tag))) | |
241 (message "Element %s is incomplete" | |
242 (rng-quote-string start-tag-name)))))))) | |
243 t)) | |
244 | |
245 (defconst rng-in-attribute-regex | |
246 (replace-regexp-in-string | |
247 "w" | |
248 xmltok-ncname-regexp | |
249 "<w\\(?::w\\)?\ | |
250 \\(?:[ \t\r\n]+w\\(?::w\\)?[ \t\r\n]*=\ | |
251 [ \t\r\n]*\\(?:\"[^\"]*\"\\|'[^']*'\\)\\)*\ | |
252 [ \t\r\n]+\\(\\(?:w\\(?::w?\\)?\\)?\\)\\=" | |
253 t | |
254 t)) | |
255 | |
256 (defvar rng-undeclared-prefixes nil) | |
257 | |
258 (defun rng-complete-attribute-name (lt-pos) | |
259 (when (save-excursion | |
260 (re-search-backward rng-in-attribute-regex lt-pos t)) | |
261 (let ((attribute-start (match-beginning 1)) | |
262 rng-undeclared-prefixes) | |
263 (and (rng-adjust-state-for-attribute lt-pos | |
264 attribute-start) | |
265 (let ((rng-complete-target-names | |
266 (rng-match-possible-attribute-names)) | |
267 (rng-complete-extra-strings | |
268 (mapcar (lambda (prefix) | |
269 (if prefix | |
270 (concat "xmlns:" prefix) | |
271 "xmlns")) | |
272 rng-undeclared-prefixes)) | |
273 (rng-complete-name-attribute-flag t)) | |
274 (rng-complete-before-point attribute-start | |
275 'rng-complete-qname-function | |
276 "Attribute: " | |
277 nil | |
278 'rng-attribute-name-history)) | |
279 (insert "=\""))) | |
280 t)) | |
281 | |
282 (defconst rng-in-attribute-value-regex | |
283 (replace-regexp-in-string | |
284 "w" | |
285 xmltok-ncname-regexp | |
286 "<w\\(?::w\\)?\ | |
287 \\(?:[ \t\r\n]+w\\(?::w\\)?[ \t\r\n]*=\ | |
288 [ \t\r\n]*\\(?:\"[^\"]*\"\\|'[^']*'\\)\\)*\ | |
289 [ \t\r\n]+\\(w\\(:w\\)?\\)[ \t\r\n]*=[ \t\r\n]*\ | |
290 \\(\"[^\"]*\\|'[^']*\\)\\=" | |
291 t | |
292 t)) | |
293 | |
294 (defun rng-complete-attribute-value (lt-pos) | |
295 (when (save-excursion | |
296 (re-search-backward rng-in-attribute-value-regex lt-pos t)) | |
297 (let ((name-start (match-beginning 1)) | |
298 (name-end (match-end 1)) | |
299 (colon (match-beginning 2)) | |
300 (value-start (1+ (match-beginning 3)))) | |
301 (and (rng-adjust-state-for-attribute lt-pos | |
302 name-start) | |
303 (if (string= (buffer-substring-no-properties name-start | |
304 (or colon name-end)) | |
305 "xmlns") | |
306 (rng-complete-before-point | |
307 value-start | |
308 (rng-strings-to-completion-alist | |
309 (rng-possible-namespace-uris | |
310 (and colon | |
311 (buffer-substring-no-properties (1+ colon) name-end)))) | |
312 "Namespace URI: " | |
313 nil | |
314 'rng-namespace-uri-history) | |
315 (rng-adjust-state-for-attribute-value name-start | |
316 colon | |
317 name-end) | |
318 (rng-complete-before-point | |
319 value-start | |
320 (rng-strings-to-completion-alist | |
321 (rng-match-possible-value-strings)) | |
322 "Value: " | |
323 nil | |
324 'rng-attribute-value-history)) | |
325 (insert (char-before value-start)))) | |
326 t)) | |
327 | |
328 (defun rng-possible-namespace-uris (prefix) | |
329 (let ((ns (if prefix (nxml-ns-get-prefix prefix) | |
330 (nxml-ns-get-default)))) | |
331 (if (and ns (memq prefix (nxml-ns-changed-prefixes))) | |
332 (list (nxml-namespace-name ns)) | |
333 (mapcar 'nxml-namespace-name | |
334 (delq nxml-xml-namespace-uri | |
335 (rng-match-possible-namespace-uris)))))) | |
336 | |
337 (defconst rng-qname-regexp | |
338 (concat "\\`" | |
339 xmltok-ncname-regexp | |
340 "\\(?:" ":" xmltok-ncname-regexp "\\)" "?" "\\'")) | |
341 | |
342 (defun rng-qname-p (string) | |
343 (and (string-match rng-qname-regexp string) t)) | |
344 | |
345 (defun rng-expand-qname (qname &optional defaultp recover-fun) | |
346 (setq qname (rng-split-qname qname)) | |
347 (let ((prefix (car qname))) | |
348 (if prefix | |
349 (let ((ns (nxml-ns-get-prefix qname))) | |
350 (cond (ns (cons ns (cdr qname))) | |
351 (recover-fun (funcall recover-fun prefix (cdr qname))))) | |
352 (cons (and defaultp (nxml-ns-get-default)) (cdr qname))))) | |
353 | |
354 (defun rng-start-tag-expand-recover (prefix local-name) | |
355 (let ((ns (rng-match-infer-start-tag-namespace local-name))) | |
356 (and ns | |
357 (cons ns local-name)))) | |
358 | |
359 (defun rng-split-qname (qname) | |
360 (if (string-match ":" qname) | |
361 (cons (substring qname 0 (match-beginning 0)) | |
362 (substring qname (match-end 0))) | |
363 (cons nil qname))) | |
364 | |
365 (defun rng-in-mixed-content-p () | |
366 "Return non-nil if point is in mixed content. | |
367 Return nil only if point is definitely not in mixed content. | |
368 If unsure, return non-nil." | |
369 (if (eq rng-current-schema rng-any-element) | |
370 t | |
371 (rng-set-state-after) | |
372 (rng-match-mixed-text))) | |
373 | |
374 (defun rng-set-state-after (&optional pos) | |
375 "Set the state for after parsing the first token with endpoint >= POS. | |
376 This does not change the xmltok state or point. However, it does | |
377 set `xmltok-dtd'. Returns the position of the end of the token." | |
378 (unless pos (setq pos (point))) | |
379 (when (< rng-validate-up-to-date-end pos) | |
380 (message "Parsing...") | |
381 (while (and (rng-do-some-validation) | |
382 (< rng-validate-up-to-date-end pos)) | |
383 ;; Display percentage validated. | |
384 (force-mode-line-update) | |
385 ;; Force redisplay but don't allow idle timers to run. | |
386 (let ((timer-idle-list nil)) | |
387 (sit-for 0))) | |
388 (message "Parsing...done")) | |
389 (save-excursion | |
390 (save-restriction | |
391 (widen) | |
392 (nxml-with-invisible-motion | |
393 (if (= pos 1) | |
394 (rng-set-initial-state) | |
395 (let ((state (get-text-property (1- pos) 'rng-state))) | |
396 (cond (state | |
397 (rng-restore-state state) | |
398 (goto-char pos)) | |
399 (t | |
400 (let ((start (previous-single-property-change pos | |
401 'rng-state))) | |
402 (cond (start | |
403 (rng-restore-state (get-text-property (1- start) | |
404 'rng-state)) | |
405 (goto-char start)) | |
406 (t (rng-set-initial-state)))))))) | |
407 (xmltok-save | |
408 (if (= (point) 1) | |
409 (xmltok-forward-prolog) | |
410 (setq xmltok-dtd rng-dtd)) | |
411 (cond ((and (< pos (point)) | |
412 ;; This handles the case where the prolog ends | |
413 ;; with a < without any following name-start | |
414 ;; character. This will be treated by the parser | |
415 ;; as part of the prolog, but we want to treat | |
416 ;; it as the start of the instance. | |
417 (eq (char-after pos) ?<) | |
418 (<= (point) | |
419 (save-excursion | |
420 (goto-char (1+ pos)) | |
421 (skip-chars-forward " \t\r\n") | |
422 (point)))) | |
423 pos) | |
424 ((< (point) pos) | |
425 (let ((rng-dt-namespace-context-getter | |
426 '(nxml-ns-get-context)) | |
427 (rng-parsing-for-state t)) | |
428 (rng-forward pos)) | |
429 (point)) | |
430 (t pos))))))) | |
431 | |
432 (defun rng-adjust-state-for-attribute (lt-pos start) | |
433 (xmltok-save | |
434 (save-excursion | |
435 (goto-char lt-pos) | |
436 (when (memq (xmltok-forward) | |
437 '(start-tag | |
438 partial-start-tag | |
439 empty-element | |
440 partial-empty-element)) | |
441 (when (< start (point)) | |
442 (setq xmltok-namespace-attributes | |
443 (rng-prune-attribute-at start | |
444 xmltok-namespace-attributes)) | |
445 (setq xmltok-attributes | |
446 (rng-prune-attribute-at start | |
447 xmltok-attributes))) | |
448 (let ((rng-parsing-for-state t) | |
449 (rng-dt-namespace-context-getter '(nxml-ns-get-context))) | |
450 (rng-process-start-tag 'stop) | |
451 (rng-find-undeclared-prefixes) | |
452 t))))) | |
453 | |
454 (defun rng-find-undeclared-prefixes () | |
455 ;; Start with the newly effective namespace declarations. | |
456 ;; (Includes declarations added during recovery.) | |
457 (setq rng-undeclared-prefixes (nxml-ns-changed-prefixes)) | |
458 (let ((iter xmltok-attributes) | |
459 (ns-state (nxml-ns-state)) | |
460 att) | |
461 ;; Add namespace prefixes used in this tag, | |
462 ;; but not declared in the parent. | |
463 (nxml-ns-pop-state) | |
464 (while iter | |
465 (setq att (car iter)) | |
466 (let ((prefix (xmltok-attribute-prefix att))) | |
467 (when (and prefix | |
468 (not (member prefix rng-undeclared-prefixes)) | |
469 (not (nxml-ns-get-prefix prefix))) | |
470 (setq rng-undeclared-prefixes | |
471 (cons prefix rng-undeclared-prefixes)))) | |
472 (setq iter (cdr iter))) | |
473 (nxml-ns-set-state ns-state) | |
474 ;; Remove namespace prefixes explicitly declared. | |
475 (setq iter xmltok-namespace-attributes) | |
476 (while iter | |
477 (setq att (car iter)) | |
478 (setq rng-undeclared-prefixes | |
479 (delete (and (xmltok-attribute-prefix att) | |
480 (xmltok-attribute-local-name att)) | |
481 rng-undeclared-prefixes)) | |
482 (setq iter (cdr iter))))) | |
483 | |
484 (defun rng-prune-attribute-at (start atts) | |
485 (when atts | |
486 (let ((cur atts)) | |
487 (while (if (eq (xmltok-attribute-name-start (car cur)) start) | |
488 (progn | |
489 (setq atts (delq (car cur) atts)) | |
490 nil) | |
491 (setq cur (cdr cur))))) | |
492 atts)) | |
493 | |
494 (defun rng-adjust-state-for-attribute-value (name-start | |
495 colon | |
496 name-end) | |
497 (let* ((prefix (if colon | |
498 (buffer-substring-no-properties name-start colon) | |
499 nil)) | |
500 (local-name (buffer-substring-no-properties (if colon | |
501 (1+ colon) | |
502 name-start) | |
503 name-end)) | |
504 (ns (and prefix (nxml-ns-get-prefix prefix)))) | |
505 (and (or (not prefix) ns) | |
506 (rng-match-attribute-name (cons ns local-name))))) | |
507 | |
508 (defun rng-complete-qname-function (string predicate flag) | |
509 (let ((alist (mapcar (lambda (name) (cons name nil)) | |
510 (rng-generate-qname-list string)))) | |
511 (cond ((not flag) | |
512 (try-completion string alist predicate)) | |
513 ((eq flag t) | |
514 (all-completions string alist predicate)) | |
515 ((eq flag 'lambda) | |
516 (and (assoc string alist) t))))) | |
517 | |
518 (defun rng-generate-qname-list (&optional string) | |
519 (let ((forced-prefix (and string | |
520 (string-match ":" string) | |
521 (> (match-beginning 0) 0) | |
522 (substring string | |
523 0 | |
524 (match-beginning 0)))) | |
525 (namespaces (mapcar 'car rng-complete-target-names)) | |
526 ns-prefixes-alist ns-prefixes iter ns prefer) | |
527 (while namespaces | |
528 (setq ns (car namespaces)) | |
529 (when ns | |
530 (setq ns-prefixes-alist | |
531 (cons (cons ns (nxml-ns-prefixes-for | |
532 ns | |
533 rng-complete-name-attribute-flag)) | |
534 ns-prefixes-alist))) | |
535 (setq namespaces (delq ns (cdr namespaces)))) | |
536 (setq iter ns-prefixes-alist) | |
537 (while iter | |
538 (setq ns-prefixes (car iter)) | |
539 (setq ns (car ns-prefixes)) | |
540 (when (null (cdr ns-prefixes)) | |
541 ;; No declared prefix for the namespace | |
542 (if forced-prefix | |
543 ;; If namespace non-nil and prefix undeclared, | |
544 ;; use forced prefix. | |
545 (when (and ns | |
546 (not (nxml-ns-get-prefix forced-prefix))) | |
547 (setcdr ns-prefixes (list forced-prefix))) | |
548 (setq prefer (rng-get-preferred-unused-prefix ns)) | |
549 (when prefer | |
550 (setcdr ns-prefixes (list prefer))) | |
551 ;; Unless it's an attribute with a non-nil namespace, | |
552 ;; allow no prefix for this namespace. | |
553 (unless rng-complete-name-attribute-flag | |
554 (setcdr ns-prefixes (cons nil (cdr ns-prefixes)))))) | |
555 (setq iter (cdr iter))) | |
556 (rng-uniquify-equal | |
557 (sort (apply 'append | |
558 (cons rng-complete-extra-strings | |
559 (mapcar (lambda (name) | |
560 (if (car name) | |
561 (mapcar (lambda (prefix) | |
562 (if prefix | |
563 (concat prefix | |
564 ":" | |
565 (cdr name)) | |
566 (cdr name))) | |
567 (cdr (assoc (car name) | |
568 ns-prefixes-alist))) | |
569 (list (cdr name)))) | |
570 rng-complete-target-names))) | |
571 'string<)))) | |
572 | |
573 (defun rng-get-preferred-unused-prefix (ns) | |
574 (let ((ns-prefix (assoc (symbol-name ns) rng-preferred-prefix-alist)) | |
575 iter prefix) | |
576 (when ns-prefix | |
577 (setq prefix (cdr ns-prefix)) | |
578 (when (nxml-ns-get-prefix prefix) | |
579 ;; try to find an unused prefix | |
580 (setq iter (memq ns-prefix rng-preferred-prefix-alist)) | |
581 (while (and iter | |
582 (setq ns-prefix (assoc ns iter))) | |
583 (if (nxml-ns-get-prefix (cdr ns-prefix)) | |
584 (setq iter (memq ns-prefix iter)) | |
585 (setq prefix (cdr ns-prefix)) | |
586 nil)))) | |
587 prefix)) | |
588 | |
589 (defun rng-strings-to-completion-alist (strings) | |
590 (mapcar (lambda (s) (cons s s)) | |
591 (rng-uniquify-equal (sort (mapcar 'rng-escape-string strings) | |
592 'string<)))) | |
593 | |
594 (provide 'rng-nxml) | |
595 | |
86379 | 596 ;; arch-tag: bec0d6ed-6be1-4540-9c2c-6f56e8e55d8b |
86361 | 597 ;;; rng-nxml.el ends here |