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