Commit | Line | Data |
---|---|---|
8cd39fb3 MH |
1 | ;;; rng-valid.el --- real-time validation of XML using RELAX NG |
2 | ||
ba318903 | 3 | ;; Copyright (C) 2003, 2007-2014 Free Software Foundation, Inc. |
8cd39fb3 MH |
4 | |
5 | ;; Author: James Clark | |
3e77f05d | 6 | ;; Keywords: wp, hypermedia, languages, XML, RelaxNG |
8cd39fb3 | 7 | |
09aa73e6 | 8 | ;; This file is part of GNU Emacs. |
8cd39fb3 | 9 | |
4936186e | 10 | ;; GNU Emacs is free software: you can redistribute it and/or modify |
09aa73e6 | 11 | ;; it under the terms of the GNU General Public License as published by |
4936186e GM |
12 | ;; the Free Software Foundation, either version 3 of the License, or |
13 | ;; (at your option) 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 | |
4936186e | 21 | ;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>. |
8cd39fb3 MH |
22 | |
23 | ;;; Commentary: | |
24 | ||
25 | ;; For usage information, see the documentation for rng-validate-mode. | |
26 | ;; | |
27 | ;; This file provides a minor mode that continually validates a buffer | |
28 | ;; against a RELAX NG schema. The validation state is used to support | |
29 | ;; schema-sensitive editing as well as validation. Validation is | |
30 | ;; performed while Emacs is idle. XML parsing is done using | |
31 | ;; xmltok.el. This file is responsible for checking that end-tags | |
32 | ;; match their start-tags. Namespace processing is handled by | |
33 | ;; nxml-ns.el. The RELAX NG Compact Syntax schema is parsed into | |
34 | ;; internal form by rng-cmpct.el. This internal form is described by | |
35 | ;; rng-pttrn.el. Validation of the document by matching against this | |
36 | ;; internal form is done by rng-match.el. Handling of W3C XML Schema | |
37 | ;; datatypes is delegated by rng-match.el to rng-xsd.el. The minor | |
38 | ;; mode is intended to be used in conjunction with the nxml major | |
39 | ;; mode, but does not have to be. | |
40 | ;; | |
41 | ;; The major responsibility of this file is to allow validation to | |
42 | ;; happen incrementally. If a buffer has been validated and is then | |
43 | ;; changed, we can often revalidate it without having to completely | |
44 | ;; parse and validate it from start to end. As we parse and validate | |
45 | ;; the buffer, we periodically cache the state. The state has three | |
46 | ;; components: the stack of open elements, the namespace processing | |
47 | ;; state and the RELAX NG validation state. The state is cached as the | |
48 | ;; value of the rng-state text property on the closing greater-than of | |
49 | ;; tags (but at intervals, not on every tag). We keep track of the | |
50 | ;; position up to which cached state is known to be correct by adding | |
51 | ;; a function to the buffer's after-change-functions. This is stored | |
52 | ;; in the rng-validate-up-to-date-end variable. The first way in | |
53 | ;; which we make validation incremental is obvious: we start | |
54 | ;; validation from the first cached state before | |
55 | ;; rng-validate-up-to-date-end. | |
56 | ;; | |
57 | ;; To make this work efficiently, we have to be able to copy the | |
58 | ;; current parsing and validation state efficiently. We do this by | |
59 | ;; minimizing destructive changes to the objects storing the state. | |
60 | ;; When state is changed, we use the old state to create new objects | |
61 | ;; representing the new state rather than destructively modifying the | |
62 | ;; objects representing the old state. Copying the state is just a | |
63 | ;; matter of making a list of three objects, one for each component of | |
64 | ;; the state; the three objects themselves can be shared and do not | |
65 | ;; need to be copied. | |
66 | ;; | |
67 | ;; There's one other idea that is used to make validation incremental. | |
68 | ;; Suppose we have a buffer that's 4000 bytes long and suppose we | |
69 | ;; validated it, caching state at positions 1000, 2000 and 3000. Now | |
70 | ;; suppose we make a change at position 1500 inserting 100 characters. | |
71 | ;; rng-validate-up-to-date-end will be changed to 1500. When Emacs | |
72 | ;; becomes idle and we revalidate, validation will restart using the | |
73 | ;; cached state at position 1000. However, we take advantage of the | |
74 | ;; cached state beyond rng-validate-up-to-date-end as follows. When | |
75 | ;; our validation reaches position 2100 (the current position of the | |
76 | ;; character that was at 2000), we compare our current state with the | |
77 | ;; cached state. If they are the same, then we can stop parsing | |
78 | ;; immediately and set rng-validate-up-to-date-end to the end of the | |
79 | ;; buffer: we already know that the state cached at position 3100 is | |
80 | ;; correct. If they are not the same, then we have to continue | |
81 | ;; parsing. After the change, but before revalidation, we call the | |
82 | ;; region from 1600 to the end of the buffer "conditionally | |
83 | ;; up-to-date". | |
84 | ;; | |
85 | ;; As well as the cached parsing and validation state, we also keep | |
86 | ;; track of the errors in the file. Errors are stored as overlays | |
87 | ;; with a category of rng-error. The number of such overlays in the | |
88 | ;; buffer must always be equal to rng-error-count. | |
89 | ||
90 | ;;; Code: | |
91 | ||
92 | (require 'xmltok) | |
93 | (require 'nxml-enc) | |
94 | (require 'nxml-util) | |
95 | (require 'nxml-ns) | |
96 | (require 'rng-match) | |
97 | (require 'rng-util) | |
98 | (require 'rng-loc) | |
99 | ||
100 | ;;; Customizable variables | |
101 | ||
102 | (defgroup relax-ng nil | |
103 | "Validation of XML using RELAX NG." | |
104 | :group 'wp | |
105 | :group 'nxml | |
106 | :group 'languages) | |
107 | ||
d65d0260 | 108 | (defface rng-error '((t (:inherit font-lock-warning-face))) |
8cd39fb3 MH |
109 | "Face for highlighting XML errors." |
110 | :group 'relax-ng) | |
111 | ||
112 | (defcustom rng-state-cache-distance 2000 | |
65beee52 | 113 | "Distance in characters between each parsing and validation state cache." |
8cd39fb3 MH |
114 | :type 'integer |
115 | :group 'relax-ng) | |
116 | ||
117 | (defcustom rng-validate-chunk-size 8000 | |
65beee52 | 118 | "Number of characters in a RELAX NG validation chunk. |
8cd39fb3 MH |
119 | A validation chunk will be the smallest chunk that is at least this |
120 | size and ends with a tag. After validating a chunk, validation will | |
121 | continue only if Emacs is still idle." | |
122 | :type 'integer | |
123 | :group 'relax-ng) | |
124 | ||
125 | (defcustom rng-validate-delay 1.5 | |
65beee52 | 126 | "Time in seconds that Emacs must be idle before starting a full validation. |
8cd39fb3 MH |
127 | A full validation continues until either validation is up to date |
128 | or Emacs is no longer idle." | |
129 | :type 'number | |
130 | :group 'relax-ng) | |
131 | ||
132 | (defcustom rng-validate-quick-delay 0.3 | |
65beee52 | 133 | "Time in seconds that Emacs must be idle before starting a quick validation. |
8cd39fb3 MH |
134 | A quick validation validates at most one chunk." |
135 | :type 'number | |
136 | :group 'relax-ng) | |
137 | ||
138 | ;; Global variables | |
139 | ||
140 | (defvar rng-validate-timer nil) | |
141 | (make-variable-buffer-local 'rng-validate-timer) | |
142 | ;; ensure that we can cancel the timer even after a kill-all-local-variables | |
143 | (put 'rng-validate-timer 'permanent-local t) | |
144 | ||
145 | (defvar rng-validate-quick-timer nil) | |
146 | (make-variable-buffer-local 'rng-validate-quick-timer) | |
147 | ;; ensure that we can cancel the timer even after a kill-all-local-variables | |
148 | (put 'rng-validate-quick-timer 'permanent-local t) | |
149 | ||
150 | (defvar rng-error-count nil | |
10545bd8 JB |
151 | "Number of errors in the current buffer. |
152 | Always equal to number of overlays with category `rng-error'.") | |
8cd39fb3 MH |
153 | (make-variable-buffer-local 'rng-error-count) |
154 | ||
155 | (defvar rng-message-overlay nil | |
10545bd8 JB |
156 | "Overlay in this buffer whose `help-echo' property was last printed. |
157 | It is nil if none.") | |
8cd39fb3 MH |
158 | (make-variable-buffer-local 'rng-message-overlay) |
159 | ||
160 | (defvar rng-message-overlay-inhibit-point nil | |
161 | "Position at which message from overlay should be inhibited. | |
162 | If point is equal to this and the error overlay around | |
163 | point is `rng-message-overlay', then the `help-echo' property | |
164 | of the error overlay should not be printed with `message'.") | |
165 | (make-variable-buffer-local 'rng-message-overlay-inhibit-point) | |
166 | ||
167 | (defvar rng-message-overlay-current nil | |
168 | "Non-nil if `rng-message-overlay' is still the current message.") | |
169 | (make-variable-buffer-local 'rng-message-overlay-current) | |
170 | ||
171 | (defvar rng-open-elements nil | |
172 | "Stack of names of open elements represented as a list. | |
173 | Each member of the list is either t or a (PREFIX . LOCAL-NAME) pair. | |
174 | \(PREFIX . LOCAL-NAME) is pushed for a start-tag; t is pushed | |
175 | for a mismatched end-tag.") | |
176 | ||
177 | (defvar rng-pending-contents nil | |
178 | "Text content of current element that has yet to be processed. | |
179 | Value is a list of segments (VALUE START END) positions in reverse | |
180 | order. VALUE is a string or nil. If VALUE is nil, then the value is | |
181 | the string between START and END. A segment can also be nil | |
182 | indicating an unresolvable entity or character reference.") | |
183 | ||
184 | (defvar rng-collecting-text nil) | |
185 | ||
186 | (defvar rng-validate-up-to-date-end nil | |
187 | "Last position where validation is known to be up to date.") | |
188 | (make-variable-buffer-local 'rng-validate-up-to-date-end) | |
189 | ||
190 | (defvar rng-conditional-up-to-date-start nil | |
191 | "Marker for the start of the conditionally up-to-date region. | |
10545bd8 JB |
192 | It is nil if there is no conditionally up-to-date region. The |
193 | conditionally up-to-date region must be such that for any cached | |
194 | state S with position P in the conditionally up-to-date region, | |
195 | if at some point it is determined that S becomes correct for P, | |
196 | then all states with position >= P in the conditionally up to | |
197 | date region must also then be correct and all errors between P | |
198 | and the end of the region must then be correctly marked.") | |
8cd39fb3 MH |
199 | (make-variable-buffer-local 'rng-conditional-up-to-date-start) |
200 | ||
201 | (defvar rng-conditional-up-to-date-end nil | |
202 | "Marker for the end of the conditionally up-to-date region. | |
10545bd8 JB |
203 | It is nil if there is no conditionally up-to-date region. |
204 | See the variable `rng-conditional-up-to-date-start'.") | |
8cd39fb3 MH |
205 | (make-variable-buffer-local 'rng-conditional-up-to-date-end) |
206 | ||
207 | (defvar rng-parsing-for-state nil | |
208 | "Non-nil means we are currently parsing just to compute the state. | |
209 | Should be dynamically bound.") | |
210 | ||
211 | (defvar rng-validate-mode nil) | |
212 | (make-variable-buffer-local 'rng-validate-mode) | |
213 | ||
214 | (defvar rng-dtd nil) | |
215 | (make-variable-buffer-local 'rng-dtd) | |
216 | ||
217 | ;;;###autoload | |
218 | (defun rng-validate-mode (&optional arg no-change-schema) | |
219 | "Minor mode performing continual validation against a RELAX NG schema. | |
220 | ||
221 | Checks whether the buffer is a well-formed XML 1.0 document, | |
222 | conforming to the XML Namespaces Recommendation and valid against a | |
10545bd8 | 223 | RELAX NG schema. The mode-line indicates whether it is or not. Any |
8cd39fb3 | 224 | parts of the buffer that cause it not to be are considered errors and |
10545bd8 | 225 | are highlighted with face `rng-error'. A description of each error is |
8cd39fb3 | 226 | available as a tooltip. \\[rng-next-error] goes to the next error |
10545bd8 JB |
227 | after point. Clicking mouse-1 on the word `Invalid' in the mode-line |
228 | goes to the first error in the buffer. If the buffer changes, then it | |
8cd39fb3 | 229 | will be automatically rechecked when Emacs becomes idle; the |
10545bd8 | 230 | rechecking will be paused whenever there is input pending. |
8cd39fb3 MH |
231 | |
232 | By default, uses a vacuous schema that allows any well-formed XML | |
e4769531 | 233 | document. A schema can be specified explicitly using |
8cd39fb3 MH |
234 | \\[rng-set-schema-file-and-validate], or implicitly based on the buffer's |
235 | file name or on the root element name. In each case the schema must | |
236 | be a RELAX NG schema using the compact schema \(such schemas | |
237 | conventionally have a suffix of `.rnc'). The variable | |
238 | `rng-schema-locating-files' specifies files containing rules | |
239 | to use for finding the schema." | |
240 | (interactive "P") | |
241 | (setq rng-validate-mode | |
242 | (if (null arg) | |
243 | (not rng-validate-mode) | |
244 | (> (prefix-numeric-value arg) 0))) | |
245 | (save-restriction | |
246 | (widen) | |
7e74b0fb | 247 | (with-silent-modifications |
8cd39fb3 MH |
248 | (rng-clear-cached-state (point-min) (point-max))) |
249 | ;; 1+ to clear empty overlays at (point-max) | |
21f49db9 SM |
250 | (rng-clear-overlays (point-min) (1+ (point-max))) |
251 | (setq rng-validate-up-to-date-end (point-min))) | |
8cd39fb3 MH |
252 | (rng-clear-conditional-region) |
253 | (setq rng-error-count 0) | |
254 | ;; do this here to avoid infinite loop if we set the schema | |
255 | (remove-hook 'rng-schema-change-hook 'rng-validate-clear t) | |
256 | (cond (rng-validate-mode | |
257 | (unwind-protect | |
258 | (save-excursion | |
259 | ;; An error can change the current buffer | |
260 | (when (or (not rng-current-schema) | |
261 | (and (eq rng-current-schema rng-any-element) | |
262 | (not no-change-schema))) | |
263 | (rng-auto-set-schema t))) | |
264 | (unless rng-current-schema (rng-set-schema-file-1 nil)) | |
265 | (add-hook 'rng-schema-change-hook 'rng-validate-clear nil t) | |
266 | (add-hook 'after-change-functions 'rng-after-change-function nil t) | |
267 | (add-hook 'kill-buffer-hook 'rng-kill-timers nil t) | |
268 | (add-hook 'echo-area-clear-hook 'rng-echo-area-clear-function nil t) | |
269 | (add-hook 'post-command-hook 'rng-maybe-echo-error-at-point nil t) | |
270 | (rng-match-init-buffer) | |
271 | (rng-activate-timers) | |
272 | ;; Start validating right away if the buffer is visible. | |
273 | ;; If it's not visible, don't do this, because the user | |
274 | ;; won't get any progress indication. When the user finds | |
275 | ;; a new file, then the buffer won't be visible | |
276 | ;; when this is invoked. | |
277 | (when (get-buffer-window (current-buffer) 'visible) | |
278 | (rng-validate-while-idle (current-buffer))))) | |
279 | (t | |
280 | (rng-cancel-timers) | |
281 | (force-mode-line-update) | |
282 | (remove-hook 'kill-buffer-hook 'rng-cancel-timers t) | |
283 | (remove-hook 'post-command-hook 'rng-maybe-echo-error-at-point t) | |
284 | (remove-hook 'echo-area-clear-hook 'rng-echo-area-clear-function t) | |
285 | (remove-hook 'after-change-functions 'rng-after-change-function t)))) | |
286 | ||
287 | (defun rng-set-schema-file-and-validate (filename) | |
288 | "Sets the schema and turns on `rng-validate-mode' if not already on. | |
289 | The schema is set like `rng-set-schema'." | |
290 | (interactive "fSchema file: ") | |
291 | (rng-set-schema-file filename) | |
292 | (or rng-validate-mode (rng-validate-mode))) | |
293 | ||
294 | (defun rng-set-document-type-and-validate (type-id) | |
295 | (interactive (list (rng-read-type-id))) | |
296 | (and (rng-set-document-type type-id) | |
297 | (or rng-validate-mode (rng-validate-mode)))) | |
10545bd8 | 298 | |
8cd39fb3 MH |
299 | (defun rng-auto-set-schema-and-validate () |
300 | "Set the schema for this buffer automatically and turn on `rng-validate-mode'. | |
301 | The schema is set like `rng-auto-set-schema'." | |
302 | (interactive) | |
303 | (rng-auto-set-schema) | |
304 | (or rng-validate-mode (rng-validate-mode))) | |
305 | ||
306 | (defun rng-after-change-function (start end pre-change-len) | |
8cd39fb3 | 307 | (setq rng-message-overlay-inhibit-point nil) |
7e74b0fb | 308 | (with-silent-modifications |
8cd39fb3 MH |
309 | (rng-clear-cached-state start end)) |
310 | ;; rng-validate-up-to-date-end holds the position before the change | |
311 | ;; Adjust it to reflect the change. | |
312 | (if (< start rng-validate-up-to-date-end) | |
313 | (setq rng-validate-up-to-date-end | |
314 | (if (<= (+ start pre-change-len) rng-validate-up-to-date-end) | |
315 | (+ rng-validate-up-to-date-end | |
316 | (- end start pre-change-len)) | |
317 | start))) | |
318 | ;; Adjust the conditional zone | |
319 | (cond (rng-conditional-up-to-date-start | |
320 | (when (< rng-conditional-up-to-date-start end) | |
321 | (if (< end rng-conditional-up-to-date-end) | |
322 | (set-marker rng-conditional-up-to-date-start end) | |
323 | (rng-clear-conditional-region)))) | |
324 | ((< end rng-validate-up-to-date-end) | |
325 | (setq rng-conditional-up-to-date-end | |
326 | (copy-marker rng-validate-up-to-date-end nil)) | |
327 | (setq rng-conditional-up-to-date-start | |
328 | (copy-marker end t)))) | |
329 | ;; Adjust rng-validate-up-to-date-end | |
330 | (if (< start rng-validate-up-to-date-end) | |
331 | (setq rng-validate-up-to-date-end start)) | |
332 | ;; Must make rng-validate-up-to-date-end < point-max | |
333 | ;; (unless the buffer is empty). | |
21f49db9 SM |
334 | ;; otherwise rng-validate-prepare will say there's nothing to do. |
335 | (when (>= rng-validate-up-to-date-end (point-max)) | |
336 | (setq rng-validate-up-to-date-end | |
337 | (if (< (point-min) (point-max)) | |
338 | (1- (point-max)) | |
339 | ;; Only widen if really necessary. | |
340 | (save-restriction (widen) (max (point-min) (1- (point-max))))))) | |
8cd39fb3 MH |
341 | ;; Arrange to revalidate |
342 | (rng-activate-timers) | |
343 | ;; Need to do this after activating the timer | |
344 | (force-mode-line-update)) | |
345 | ||
346 | (defun rng-compute-mode-line-string () | |
347 | (cond (rng-validate-timer | |
348 | (concat " Validated:" | |
349 | (number-to-string | |
350 | ;; Use floor rather than round because we want | |
351 | ;; to show 99% rather than 100% for changes near | |
352 | ;; the end. | |
353 | (floor (if (eq (buffer-size) 0) | |
354 | 0.0 | |
21f49db9 SM |
355 | (/ (* (- rng-validate-up-to-date-end (point-min)) |
356 | 100.0) | |
357 | (- (point-max) (point-min)))))) | |
8cd39fb3 MH |
358 | "%%")) |
359 | ((> rng-error-count 0) | |
360 | (concat " " | |
361 | (propertize "Invalid" | |
362 | 'help-echo "mouse-1: go to first error" | |
363 | 'local-map (make-mode-line-mouse-map | |
364 | 'mouse-1 | |
365 | 'rng-mouse-first-error)))) | |
366 | (t " Valid"))) | |
10545bd8 | 367 | |
8cd39fb3 MH |
368 | (defun rng-cancel-timers () |
369 | (let ((inhibit-quit t)) | |
370 | (when rng-validate-timer | |
371 | (cancel-timer rng-validate-timer) | |
372 | (setq rng-validate-timer nil)) | |
373 | (when rng-validate-quick-timer | |
374 | (cancel-timer rng-validate-quick-timer) | |
375 | (setq rng-validate-quick-timer nil)))) | |
376 | ||
377 | (defun rng-kill-timers () | |
378 | ;; rng-validate-timer and rng-validate-quick-timer have the | |
379 | ;; permanent-local property, so that the timers can be | |
c80e3b4a PE |
380 | ;; canceled even after changing mode. |
381 | ;; This function takes care of canceling the timers and | |
8cd39fb3 MH |
382 | ;; then killing the local variables. |
383 | (when (local-variable-p 'rng-validate-timer) | |
384 | (when rng-validate-timer | |
385 | (cancel-timer rng-validate-timer)) | |
386 | (kill-local-variable 'rng-validate-timer)) | |
387 | (when (local-variable-p 'rng-validate-quick-timer) | |
388 | (when rng-validate-quick-timer | |
389 | (cancel-timer rng-validate-quick-timer)) | |
390 | (kill-local-variable 'rng-validate-quick-timer))) | |
10545bd8 | 391 | |
8cd39fb3 MH |
392 | (defun rng-activate-timers () |
393 | (unless rng-validate-timer | |
394 | (let ((inhibit-quit t)) | |
395 | (setq rng-validate-timer | |
396 | (run-with-idle-timer rng-validate-delay | |
397 | t | |
398 | 'rng-validate-while-idle | |
399 | (current-buffer))) | |
400 | (setq rng-validate-quick-timer | |
401 | (run-with-idle-timer rng-validate-quick-delay | |
402 | t | |
403 | 'rng-validate-quick-while-idle | |
404 | (current-buffer)))))) | |
405 | ||
406 | (defun rng-validate-clear () | |
407 | (rng-validate-mode 1 t)) | |
408 | ||
409 | ;; These two variables are dynamically bound and used | |
410 | ;; to pass information between rng-validate-while-idle | |
411 | ;; and rng-validate-while-idle-continue-p. | |
412 | ||
413 | (defvar rng-validate-display-point nil) | |
414 | (defvar rng-validate-display-modified-p nil) | |
415 | ||
416 | (defun rng-validate-while-idle-continue-p () | |
a320a2db LL |
417 | (and (not (input-pending-p)) |
418 | ;; Fake rng-validate-up-to-date-end so that the mode line | |
419 | ;; shows progress. Also use this to save point. | |
420 | (let ((rng-validate-up-to-date-end (point))) | |
421 | (goto-char rng-validate-display-point) | |
422 | (when (not rng-validate-display-modified-p) | |
423 | (restore-buffer-modified-p nil)) | |
424 | (force-mode-line-update) | |
425 | (let ((continue (sit-for 0))) | |
426 | (goto-char rng-validate-up-to-date-end) | |
427 | continue)))) | |
8cd39fb3 MH |
428 | |
429 | ;; Calling rng-do-some-validation once with a continue-p function, as | |
430 | ;; opposed to calling it repeatedly, helps on initial validation of a | |
431 | ;; large buffer with lots of errors. The overlays for errors will all | |
432 | ;; get added when rng-do-some-validation returns and won't slow the | |
433 | ;; validation process down. | |
434 | ||
435 | (defun rng-validate-while-idle (buffer) | |
7b0e2f85 LL |
436 | (when (buffer-live-p buffer) ; bug#13999 |
437 | (with-current-buffer buffer | |
438 | (if rng-validate-mode | |
439 | (if (let ((rng-validate-display-point (point)) | |
440 | (rng-validate-display-modified-p (buffer-modified-p))) | |
441 | (rng-do-some-validation 'rng-validate-while-idle-continue-p)) | |
442 | (force-mode-line-update) | |
443 | (rng-validate-done)) | |
444 | ;; must have done kill-all-local-variables | |
445 | (rng-kill-timers))))) | |
8cd39fb3 MH |
446 | |
447 | (defun rng-validate-quick-while-idle (buffer) | |
7b0e2f85 LL |
448 | (when (buffer-live-p buffer) ; bug#13999 |
449 | (with-current-buffer buffer | |
450 | (if rng-validate-mode | |
451 | (if (rng-do-some-validation) | |
452 | (force-mode-line-update) | |
453 | (rng-validate-done)) | |
454 | ;; must have done kill-all-local-variables | |
455 | (rng-kill-timers))))) | |
8cd39fb3 MH |
456 | |
457 | (defun rng-validate-done () | |
458 | (when (or (not (current-message)) | |
459 | (rng-current-message-from-error-overlay-p)) | |
10545bd8 | 460 | (rng-error-overlay-message (or (rng-error-overlay-after (point)) |
8cd39fb3 MH |
461 | (rng-error-overlay-after (1- (point)))))) |
462 | (rng-cancel-timers) | |
463 | (force-mode-line-update)) | |
464 | ||
465 | (defun rng-do-some-validation (&optional continue-p-function) | |
10545bd8 | 466 | "Do some validation work. Return t if more to do, nil otherwise." |
8cd39fb3 MH |
467 | (save-excursion |
468 | (save-restriction | |
469 | (widen) | |
470 | (nxml-with-invisible-motion | |
1be3ca5a | 471 | (condition-case-unless-debug err |
8cd39fb3 MH |
472 | (and (rng-validate-prepare) |
473 | (let ((rng-dt-namespace-context-getter '(nxml-ns-get-context))) | |
7e74b0fb | 474 | (with-silent-modifications |
8cd39fb3 | 475 | (rng-do-some-validation-1 continue-p-function)))) |
04bf5b65 | 476 | ;; errors signaled from a function run by an idle timer |
8cd39fb3 MH |
477 | ;; are ignored; if we don't catch them, validation |
478 | ;; will get mysteriously stuck at a single place | |
479 | (rng-compile-error | |
480 | (message "Incorrect schema. %s" (nth 1 err)) | |
481 | (rng-validate-mode 0) | |
482 | nil) | |
483 | (error | |
484 | (message "Internal error in rng-validate-mode triggered at buffer position %d. %s" | |
485 | (point) | |
486 | (error-message-string err)) | |
487 | (rng-validate-mode 0) | |
488 | nil)))))) | |
489 | ||
490 | (defun rng-validate-prepare () | |
491 | "Prepare to do some validation, initializing point and the state. | |
492 | Return t if there is work to do, nil otherwise." | |
493 | (cond ((= rng-validate-up-to-date-end (point-min)) | |
494 | (rng-set-initial-state) | |
495 | t) | |
496 | ((= rng-validate-up-to-date-end (point-max)) | |
497 | nil) | |
498 | (t (let ((state (get-text-property (1- rng-validate-up-to-date-end) | |
499 | 'rng-state))) | |
500 | (cond (state | |
501 | (rng-restore-state state) | |
502 | (goto-char rng-validate-up-to-date-end)) | |
503 | (t | |
504 | (let ((pos (previous-single-property-change | |
505 | rng-validate-up-to-date-end | |
506 | 'rng-state))) | |
507 | (cond (pos | |
508 | (rng-restore-state | |
509 | (or (get-text-property (1- pos) 'rng-state) | |
510 | (error "Internal error: state null"))) | |
511 | (goto-char pos)) | |
512 | (t (rng-set-initial-state)))))))))) | |
513 | ||
f7ca27a1 SS |
514 | (defun rng-dtd-trivial-p (dtd) |
515 | "Check whether the current dtd is different from the trivial default." | |
516 | (or (null dtd) (eq dtd xmltok-predefined-entity-alist))) | |
8cd39fb3 MH |
517 | |
518 | (defun rng-do-some-validation-1 (&optional continue-p-function) | |
519 | (let ((limit (+ rng-validate-up-to-date-end | |
520 | rng-validate-chunk-size)) | |
521 | (remove-start rng-validate-up-to-date-end) | |
522 | (next-cache-point (+ (point) rng-state-cache-distance)) | |
523 | (continue t) | |
524 | (xmltok-dtd rng-dtd) | |
525 | have-remaining-chars | |
526 | xmltok-type | |
527 | xmltok-start | |
528 | xmltok-name-colon | |
529 | xmltok-name-end | |
530 | xmltok-replacement | |
531 | xmltok-attributes | |
532 | xmltok-namespace-attributes | |
8cd39fb3 MH |
533 | xmltok-errors) |
534 | (when (= (point) 1) | |
535 | (let ((regions (xmltok-forward-prolog))) | |
536 | (rng-clear-overlays 1 (point)) | |
537 | (while regions | |
538 | (when (eq (aref (car regions) 0) 'encoding-name) | |
539 | (rng-process-encoding-name (aref (car regions) 1) | |
540 | (aref (car regions) 2))) | |
541 | (setq regions (cdr regions)))) | |
542 | (unless (equal rng-dtd xmltok-dtd) | |
543 | (rng-clear-conditional-region)) | |
544 | (setq rng-dtd xmltok-dtd)) | |
545 | (while continue | |
546 | (setq have-remaining-chars (rng-forward)) | |
547 | (let ((pos (point))) | |
548 | (setq continue | |
549 | (and have-remaining-chars | |
550 | (or (< pos limit) | |
551 | (and continue-p-function | |
552 | (funcall continue-p-function) | |
553 | (setq limit (+ limit rng-validate-chunk-size)) | |
554 | t)))) | |
555 | (cond ((and rng-conditional-up-to-date-start | |
556 | ;; > because we are getting the state from (1- pos) | |
557 | (> pos rng-conditional-up-to-date-start) | |
558 | (< pos rng-conditional-up-to-date-end) | |
559 | (rng-state-matches-current (get-text-property (1- pos) | |
560 | 'rng-state))) | |
561 | (when (< remove-start (1- pos)) | |
562 | (rng-clear-cached-state remove-start (1- pos))) | |
563 | ;; sync up with cached validation state | |
564 | (setq continue nil) | |
9858f6c3 | 565 | ;; do this before setting rng-validate-up-to-date-end |
8cd39fb3 MH |
566 | ;; in case we get a quit |
567 | (rng-mark-xmltok-errors) | |
8cd39fb3 MH |
568 | (setq rng-validate-up-to-date-end |
569 | (marker-position rng-conditional-up-to-date-end)) | |
570 | (rng-clear-conditional-region) | |
571 | (setq have-remaining-chars | |
572 | (< rng-validate-up-to-date-end (point-max)))) | |
573 | ((or (>= pos next-cache-point) | |
574 | (not continue)) | |
575 | (setq next-cache-point (+ pos rng-state-cache-distance)) | |
576 | (rng-clear-cached-state remove-start pos) | |
577 | (when have-remaining-chars | |
578 | (rng-cache-state (1- pos))) | |
579 | (setq remove-start pos) | |
580 | (unless continue | |
581 | ;; if we have just blank chars skip to the end | |
582 | (when have-remaining-chars | |
583 | (skip-chars-forward " \t\r\n") | |
584 | (when (= (point) (point-max)) | |
585 | (rng-clear-overlays pos (point)) | |
586 | (rng-clear-cached-state pos (point)) | |
587 | (setq have-remaining-chars nil) | |
588 | (setq pos (point)))) | |
589 | (when (not have-remaining-chars) | |
590 | (rng-process-end-document)) | |
591 | (rng-mark-xmltok-errors) | |
8cd39fb3 MH |
592 | (setq rng-validate-up-to-date-end pos) |
593 | (when rng-conditional-up-to-date-end | |
594 | (cond ((<= rng-conditional-up-to-date-end pos) | |
595 | (rng-clear-conditional-region)) | |
596 | ((< rng-conditional-up-to-date-start pos) | |
597 | (set-marker rng-conditional-up-to-date-start | |
598 | pos))))))))) | |
599 | have-remaining-chars)) | |
10545bd8 | 600 | |
8cd39fb3 MH |
601 | (defun rng-clear-conditional-region () |
602 | (when rng-conditional-up-to-date-start | |
603 | (set-marker rng-conditional-up-to-date-start nil) | |
604 | (setq rng-conditional-up-to-date-start nil)) | |
605 | (when rng-conditional-up-to-date-end | |
606 | (set-marker rng-conditional-up-to-date-end nil) | |
607 | (setq rng-conditional-up-to-date-end nil))) | |
608 | ||
609 | (defun rng-clear-cached-state (start end) | |
610 | "Clear cached state between START and END." | |
611 | (remove-text-properties start end '(rng-state nil))) | |
612 | ||
613 | (defun rng-cache-state (pos) | |
614 | "Save the current state in a text property on the character at pos." | |
615 | (put-text-property pos | |
616 | (1+ pos) | |
617 | 'rng-state | |
618 | (rng-get-state))) | |
619 | ||
620 | (defun rng-state-matches-current (state) | |
621 | (and state | |
622 | (rng-match-state-equal (car state)) | |
623 | (nxml-ns-state-equal (nth 1 state)) | |
624 | (equal (nth 2 state) rng-open-elements))) | |
625 | ||
626 | (defun rng-get-state () | |
627 | (list (rng-match-state) | |
628 | (nxml-ns-state) | |
629 | rng-open-elements)) | |
630 | ||
631 | (defun rng-restore-state (state) | |
632 | (rng-set-match-state (car state)) | |
633 | (setq state (cdr state)) | |
634 | (nxml-ns-set-state (car state)) | |
635 | (setq rng-open-elements (cadr state)) | |
636 | (setq rng-pending-contents nil) | |
637 | (setq rng-collecting-text (rng-match-text-typed-p))) | |
638 | ||
639 | (defun rng-set-initial-state () | |
640 | (nxml-ns-init) | |
641 | (rng-match-start-document) | |
642 | (setq rng-open-elements nil) | |
643 | (setq rng-pending-contents nil) | |
644 | (goto-char (point-min))) | |
645 | ||
646 | (defun rng-clear-overlays (beg end) | |
647 | (unless rng-parsing-for-state | |
648 | (let ((overlays (overlays-in beg end))) | |
649 | (while overlays | |
650 | (let* ((overlay (car overlays)) | |
651 | (category (overlay-get overlay 'category))) | |
652 | (cond ((eq category 'rng-error) | |
653 | (let ((inhibit-quit t)) | |
654 | (when (eq overlay rng-message-overlay) | |
655 | (rng-error-overlay-message nil)) | |
656 | (delete-overlay overlay) | |
657 | ;; rng-error-count could be nil | |
658 | ;; if overlays left over from a previous use | |
659 | ;; of rng-validate-mode that ended with a change of mode | |
660 | (when rng-error-count | |
c9990474 | 661 | (setq rng-error-count (1- rng-error-count))))))) |
8cd39fb3 MH |
662 | (setq overlays (cdr overlays)))))) |
663 | ||
8cd39fb3 MH |
664 | ;;; Error state |
665 | ||
666 | (defun rng-mark-xmltok-errors () | |
667 | (while xmltok-errors | |
668 | (let ((err (car xmltok-errors))) | |
669 | (rng-mark-not-well-formed (xmltok-error-message err) | |
670 | (xmltok-error-start err) | |
671 | (xmltok-error-end err))) | |
672 | (setq xmltok-errors (cdr xmltok-errors)))) | |
673 | ||
674 | (defun rng-mark-invalid (message beg end) | |
675 | (rng-mark-error message beg end)) | |
676 | ||
677 | (defun rng-mark-not-well-formed (message beg end) | |
678 | ;; Don't try to validate further | |
679 | ;;(rng-set-match-state rng-not-allowed-ipattern) | |
680 | (rng-mark-error message beg end)) | |
681 | ||
682 | (defun rng-mark-error (message beg end) | |
683 | (unless rng-parsing-for-state | |
684 | (let ((overlays (overlays-in beg end))) | |
685 | (while (and overlays message) | |
686 | (let ((o (car overlays))) | |
687 | (when (and (eq (overlay-get o 'category) 'rng-error) | |
688 | (= (overlay-start o) beg) | |
689 | (= (overlay-end o) end)) | |
690 | (overlay-put o | |
691 | 'help-echo | |
692 | (concat (overlay-get o 'help-echo) | |
693 | "\n" | |
694 | message)) | |
695 | (setq message nil))) | |
696 | (setq overlays (cdr overlays)))) | |
697 | (when message | |
698 | (let ((inhibit-quit t)) | |
699 | (setq rng-error-count (1+ rng-error-count)) | |
700 | (let ((overlay | |
701 | (make-overlay beg end nil t | |
702 | ;; Need to make the rear delimiter advance | |
703 | ;; with the front delimiter when the overlay | |
704 | ;; is empty, otherwise the front delimiter | |
705 | ;; will move past the rear delimiter. | |
706 | (= beg end)))) | |
707 | ;; Ensure when we have two overlapping messages, the help-echo | |
708 | ;; of the one that starts first is shown | |
709 | (overlay-put overlay 'priority beg) | |
710 | (overlay-put overlay 'category 'rng-error) | |
711 | (overlay-put overlay 'help-echo message)))))) | |
712 | ||
d65d0260 | 713 | (put 'rng-error 'face 'rng-error) |
8cd39fb3 MH |
714 | (put 'rng-error 'modification-hooks '(rng-error-modified)) |
715 | ||
716 | ;; If we don't do this, then the front delimiter can move | |
717 | ;; past the end delimiter. | |
718 | (defun rng-error-modified (overlay after-p beg end &optional pre-change-len) | |
719 | (when (and after-p | |
720 | (overlay-start overlay) ; check not deleted | |
721 | (>= (overlay-start overlay) | |
722 | (overlay-end overlay))) | |
723 | (let ((inhibit-quit t)) | |
724 | (delete-overlay overlay) | |
725 | (setq rng-error-count (1- rng-error-count))))) | |
726 | ||
727 | (defun rng-echo-area-clear-function () | |
728 | (setq rng-message-overlay-current nil)) | |
729 | ||
730 | ;;; Error navigation | |
10545bd8 | 731 | |
8cd39fb3 MH |
732 | (defun rng-maybe-echo-error-at-point () |
733 | (when (or (not (current-message)) | |
734 | (rng-current-message-from-error-overlay-p)) | |
735 | (rng-error-overlay-message (rng-error-overlay-after (point))))) | |
736 | ||
737 | (defun rng-error-overlay-after (pos) | |
738 | (let ((overlays (overlays-in pos (1+ pos))) | |
739 | (best nil)) | |
740 | (while overlays | |
741 | (let ((overlay (car overlays))) | |
742 | (when (and (eq (overlay-get overlay 'category) | |
743 | 'rng-error) | |
744 | (or (not best) | |
745 | (< (overlay-start best) | |
746 | (overlay-start overlay)))) | |
747 | (setq best overlay))) | |
748 | (setq overlays (cdr overlays))) | |
749 | best)) | |
750 | ||
751 | (defun rng-first-error () | |
752 | "Go to the first validation error. | |
753 | Turn on `rng-validate-mode' if it is not already on." | |
754 | (interactive) | |
755 | (or rng-validate-mode (rng-validate-mode)) | |
21f49db9 | 756 | (rng-do-some-validation) |
8cd39fb3 MH |
757 | (let ((err (rng-find-next-error-overlay (1- (point-min))))) |
758 | (if err | |
759 | (rng-goto-error-overlay err) | |
760 | (let ((pos (save-excursion | |
761 | (goto-char (point-min)) | |
762 | (rng-next-error 1)))) | |
763 | (when pos | |
764 | (goto-char pos)))))) | |
765 | ||
766 | (defun rng-mouse-first-error (event) | |
767 | "Go to the first validation error from a mouse click." | |
768 | (interactive "e") | |
769 | (select-window (posn-window (event-start event))) | |
770 | (rng-first-error)) | |
771 | ||
772 | (defun rng-next-error (arg) | |
773 | "Go to the next validation error after point. | |
774 | Turn on `rng-validate-mode' if it is not already on. | |
10545bd8 JB |
775 | A prefix ARG specifies how many errors to move. |
776 | A negative ARG moves backwards. Just \\[universal-argument] as a prefix | |
8cd39fb3 MH |
777 | means goto the first error." |
778 | (interactive "P") | |
779 | (if (consp arg) | |
780 | (rng-first-error) | |
781 | (or rng-validate-mode (rng-validate-mode)) | |
782 | (setq arg (prefix-numeric-value arg)) | |
783 | (if (< arg 0) | |
784 | (rng-previous-error-1 (- arg)) | |
785 | (rng-next-error-1 arg)))) | |
786 | ||
787 | (defun rng-previous-error (arg) | |
788 | "Go to the previous validation error before point. | |
789 | Turn on `rng-validate-mode' if it is not already on. | |
10545bd8 JB |
790 | A prefix ARG specifies how many errors to move. |
791 | A negative ARG moves forwards. Just \\[universal-argument] as a prefix | |
8cd39fb3 MH |
792 | means goto the first error." |
793 | (interactive "P") | |
794 | (if (consp arg) | |
795 | (rng-first-error) | |
796 | (or rng-validate-mode (rng-validate-mode)) | |
797 | (setq arg (prefix-numeric-value arg)) | |
798 | (if (< arg 0) | |
799 | (rng-next-error-1 (- arg)) | |
800 | (rng-previous-error-1 arg)))) | |
801 | ||
802 | (defun rng-next-error-1 (arg) | |
803 | (let* ((pos (point)) | |
804 | err last-err) | |
805 | (while (and (> arg 0) | |
806 | (setq err (rng-find-next-error-overlay pos))) | |
807 | (setq arg (1- arg)) | |
808 | (setq last-err err) | |
809 | (setq pos (overlay-start err))) | |
810 | (when (> arg 0) | |
10545bd8 | 811 | (setq pos (max pos (1- rng-validate-up-to-date-end))) |
8cd39fb3 MH |
812 | (when (< rng-validate-up-to-date-end (point-max)) |
813 | (message "Parsing...") | |
814 | (while (let ((more-to-do (rng-do-some-validation))) | |
815 | (while (and (> arg 0) | |
816 | (setq err (rng-find-next-error-overlay pos))) | |
817 | (setq arg (1- arg)) | |
818 | (setq last-err err) | |
819 | (setq pos (overlay-start err))) | |
820 | (when (and (> arg 0) | |
821 | more-to-do | |
822 | (< rng-validate-up-to-date-end (point-max))) | |
823 | ;; Display percentage validated. | |
824 | (force-mode-line-update) | |
a320a2db | 825 | (sit-for 0) |
8cd39fb3 MH |
826 | (setq pos |
827 | (max pos (1- rng-validate-up-to-date-end))) | |
828 | t))))) | |
829 | (if last-err | |
830 | (rng-goto-error-overlay last-err) | |
831 | (message "No more errors") | |
832 | nil))) | |
833 | ||
834 | (defun rng-previous-error-1 (arg) | |
835 | (let* ((pos (point)) | |
836 | err last-err) | |
837 | (while (and (> arg 0) | |
838 | (setq err (rng-find-previous-error-overlay pos))) | |
839 | (setq pos (overlay-start err)) | |
840 | (setq last-err err) | |
841 | (setq arg (1- arg))) | |
842 | (when (and (> arg 0) | |
843 | (< rng-validate-up-to-date-end (min pos (point-max)))) | |
844 | (message "Parsing...") | |
845 | (while (and (rng-do-some-validation) | |
846 | (< rng-validate-up-to-date-end (min pos (point-max)))) | |
847 | (force-mode-line-update) | |
a320a2db | 848 | (sit-for 0)) |
8cd39fb3 MH |
849 | (while (and (> arg 0) |
850 | (setq err (rng-find-previous-error-overlay pos))) | |
851 | (setq pos (overlay-start err)) | |
852 | (setq last-err err) | |
853 | (setq arg (1- arg)))) | |
854 | (if last-err | |
855 | (rng-goto-error-overlay last-err) | |
856 | (message "No previous errors") | |
857 | nil))) | |
10545bd8 | 858 | |
8cd39fb3 MH |
859 | (defun rng-goto-error-overlay (err) |
860 | "Goto the start of error overlay ERR and print its message." | |
861 | (goto-char (overlay-start err)) | |
862 | (setq rng-message-overlay-inhibit-point nil) | |
863 | (rng-error-overlay-message err)) | |
864 | ||
865 | (defun rng-error-overlay-message (err) | |
866 | (if err | |
867 | (unless (or (and (eq rng-message-overlay-inhibit-point (point)) | |
868 | (eq rng-message-overlay err)) | |
869 | (= (point-max) 1)) | |
870 | (message "%s" (overlay-get err 'help-echo)) | |
871 | (setq rng-message-overlay-current t) | |
872 | (setq rng-message-overlay-inhibit-point (point))) | |
873 | (when (rng-current-message-from-error-overlay-p) | |
874 | (message nil)) | |
875 | (setq rng-message-overlay-inhibit-point nil)) | |
876 | (setq rng-message-overlay err)) | |
877 | ||
878 | (defun rng-current-message-from-error-overlay-p () | |
879 | (and rng-message-overlay-current | |
880 | rng-message-overlay | |
881 | (equal (overlay-get rng-message-overlay 'help-echo) | |
882 | (current-message)))) | |
883 | ||
884 | (defun rng-find-next-error-overlay (pos) | |
885 | "Return the overlay for the next error starting after POS. | |
886 | Return nil if there is no such overlay or it is out of date. | |
887 | Do not do any additional validation." | |
888 | (when rng-error-count | |
889 | (let (done found overlays) | |
890 | (while (not done) | |
891 | (cond (overlays | |
892 | (let ((overlay (car overlays))) | |
893 | (setq overlays (cdr overlays)) | |
894 | (when (and (eq (overlay-get overlay 'category) 'rng-error) | |
895 | ;; Is it the first? | |
896 | (= (overlay-start overlay) pos) | |
897 | ;; Is it up to date? | |
898 | (<= (overlay-end overlay) | |
899 | rng-validate-up-to-date-end)) | |
900 | (setq done t) | |
901 | (setq found overlay)))) | |
902 | ((or (= pos (point-max)) | |
903 | (> (setq pos (next-overlay-change pos)) | |
904 | rng-validate-up-to-date-end)) | |
905 | (setq done t)) | |
906 | (t (setq overlays (overlays-in pos (1+ pos)))))) | |
907 | found))) | |
908 | ||
909 | (defun rng-find-previous-error-overlay (pos) | |
910 | "Return the overlay for the last error starting before POS. | |
911 | Return nil if there is no such overlay or it is out of date. | |
912 | Do not do any additional validation." | |
913 | (when (and rng-error-count | |
914 | (<= pos rng-validate-up-to-date-end)) | |
915 | (let (done found overlays) | |
916 | (while (not done) | |
917 | (cond (overlays | |
918 | (let ((overlay (car overlays))) | |
919 | (setq overlays (cdr overlays)) | |
920 | (when (and (eq (overlay-get overlay 'category) 'rng-error) | |
921 | ;; Is it the first? | |
922 | (= (overlay-start overlay) pos)) | |
923 | (setq done t) | |
924 | (setq found overlay)))) | |
925 | ((= pos (point-min)) | |
926 | (setq done t)) | |
927 | (t | |
928 | (setq pos (previous-overlay-change pos)) | |
929 | (setq overlays (overlays-in pos (1+ pos)))))) | |
930 | found))) | |
931 | ||
932 | ;;; Parsing | |
933 | ||
934 | (defun rng-forward (&optional limit) | |
935 | "Move forward over one or more tokens updating the state. | |
936 | If LIMIT is nil, stop after tags. | |
937 | If LIMIT is non-nil, stop when end of last token parsed is >= LIMIT. | |
938 | Return nil at end of buffer, t otherwise." | |
939 | (let (type) | |
940 | (while (progn | |
941 | (setq type (xmltok-forward)) | |
942 | (rng-clear-overlays xmltok-start (point)) | |
943 | (let ((continue | |
944 | (cond ((eq type 'start-tag) | |
945 | (rng-process-start-tag 'start-tag) | |
946 | nil) | |
947 | ((eq type 'end-tag) | |
948 | (rng-process-end-tag) | |
949 | nil) | |
950 | ((eq type 'empty-element) | |
951 | (rng-process-start-tag 'empty-element) | |
952 | nil) | |
953 | ((eq type 'space) | |
954 | (rng-process-text xmltok-start nil t) | |
955 | t) | |
956 | ((eq type 'data) | |
957 | (rng-process-text xmltok-start nil nil) | |
958 | t) | |
959 | ((memq type '(entity-ref char-ref)) | |
960 | (cond (xmltok-replacement | |
961 | (rng-process-text xmltok-start | |
962 | nil | |
963 | 'maybe | |
964 | xmltok-replacement)) | |
965 | ((eq type 'char-ref) | |
966 | (rng-process-unknown-char)) | |
967 | (t | |
968 | (rng-process-unknown-entity))) | |
969 | t) | |
970 | ((eq type 'cdata-section) | |
971 | (rng-process-text (+ xmltok-start 9) ; "<![CDATA[" | |
972 | (- (point) 3) ; "]]>" | |
973 | 'maybe) | |
974 | t) | |
975 | ((eq type 'partial-start-tag) | |
976 | (rng-process-start-tag 'partial-start-tag) | |
977 | t) | |
978 | ((eq type 'partial-empty-element) | |
979 | (rng-process-start-tag 'empty-element) | |
980 | t) | |
981 | ((eq type 'partial-end-tag) | |
982 | (rng-process-end-tag 'partial) | |
983 | t) | |
984 | (t type)))) | |
985 | (if limit | |
986 | (< (point) limit) | |
987 | continue)))) | |
988 | (and type t))) | |
989 | ||
990 | (defun rng-process-start-tag (tag-type) | |
991 | "TAG-TYPE is `start-tag' for a start-tag, `empty-element' for | |
10545bd8 | 992 | an empty element. `partial-empty-element' should be passed |
8cd39fb3 MH |
993 | as empty-element." |
994 | (and rng-collecting-text (rng-flush-text)) | |
995 | (setq rng-collecting-text nil) | |
996 | (setq rng-pending-contents nil) | |
997 | (rng-process-namespaces) | |
998 | (let ((tag (rng-process-tag-name))) | |
999 | (rng-process-attributes) | |
1000 | ;; set the state appropriately | |
1001 | (cond ((eq tag-type 'empty-element) | |
1002 | (rng-process-start-tag-close) | |
1003 | ;; deal with missing content with empty element | |
1004 | (when (not (rng-match-empty-content)) | |
1005 | (rng-match-after) | |
1006 | (rng-mark-start-tag-close "Empty content not allowed")) | |
1007 | (nxml-ns-pop-state)) | |
1008 | ((eq tag-type 'start-tag) | |
1009 | (rng-process-start-tag-close) | |
1010 | (setq rng-collecting-text (rng-match-text-typed-p)) | |
1011 | (rng-push-tag tag)) | |
1012 | ((eq tag-type 'partial-start-tag) | |
1013 | (rng-process-start-tag-close) | |
1014 | (rng-match-after) | |
1015 | (nxml-ns-pop-state))))) | |
1016 | ||
1017 | (defun rng-process-namespaces () | |
1018 | (let ((nsatts xmltok-namespace-attributes) | |
1019 | prefixes) | |
1020 | (nxml-ns-push-state) | |
1021 | (while nsatts | |
1022 | (let* ((att (car nsatts)) | |
1023 | (value (xmltok-attribute-value att))) | |
1024 | (when value | |
1025 | (let ((ns (nxml-make-namespace value)) | |
1026 | (prefix (and (xmltok-attribute-prefix att) | |
1027 | (xmltok-attribute-local-name att)))) | |
1028 | (cond ((member prefix prefixes) | |
1029 | (rng-mark-invalid "Duplicate namespace declaration" | |
1030 | (xmltok-attribute-name-start att) | |
1031 | (xmltok-attribute-name-end att))) | |
1032 | ((not prefix) | |
1033 | (nxml-ns-set-default ns)) | |
1034 | (ns | |
1035 | (nxml-ns-set-prefix prefix ns)) | |
1036 | (t | |
1037 | ;; cannot have xmlns:foo="" | |
1038 | (rng-mark-invalid "Namespace prefix cannot be undeclared" | |
1039 | (1- (xmltok-attribute-value-start att)) | |
1040 | (1+ (xmltok-attribute-value-end att))))) | |
1041 | (setq prefixes (cons prefix prefixes))))) | |
1042 | (setq nsatts (cdr nsatts))))) | |
1043 | ||
1044 | (defun rng-process-tag-name () | |
1045 | (let* ((prefix (xmltok-start-tag-prefix)) | |
1046 | (local-name (xmltok-start-tag-local-name)) | |
1047 | (name | |
1048 | (if prefix | |
1049 | (let ((ns (nxml-ns-get-prefix prefix))) | |
1050 | (cond (ns (cons ns local-name)) | |
1051 | ((and (setq ns | |
1052 | (rng-match-infer-start-tag-namespace | |
1053 | local-name)) | |
1054 | (rng-match-start-tag-open (cons ns local-name))) | |
1055 | (nxml-ns-set-prefix prefix ns) | |
1056 | (rng-mark-start-tag-close "Missing xmlns:%s=\"%s\"" | |
1057 | prefix | |
1058 | (nxml-namespace-name ns)) | |
1059 | nil) | |
1060 | (t | |
1061 | (rng-recover-bad-element-prefix) | |
1062 | nil))) | |
1063 | (cons (nxml-ns-get-default) local-name)))) | |
1064 | (when (and name | |
1065 | (not (rng-match-start-tag-open name))) | |
1066 | (unless (and (not (car name)) | |
1067 | (let ((ns (rng-match-infer-start-tag-namespace (cdr name)))) | |
1068 | (and ns | |
1069 | (rng-match-start-tag-open (cons ns local-name)) | |
1070 | (progn | |
1071 | (nxml-ns-set-default ns) | |
1072 | ;; XXX need to check we don't have xmlns="" | |
1073 | (rng-mark-start-tag-close "Missing xmlns=\"%s\"" | |
1074 | (nxml-namespace-name ns)) | |
1075 | t)))) | |
1076 | (rng-recover-start-tag-open name))) | |
1077 | (cons prefix local-name))) | |
1078 | ||
1079 | (defun rng-process-attributes () | |
1080 | (let ((atts xmltok-attributes) | |
1081 | names) | |
1082 | (while atts | |
1083 | (let* ((att (car atts)) | |
1084 | (prefix (xmltok-attribute-prefix att)) | |
1085 | (local-name (xmltok-attribute-local-name att)) | |
1086 | (name | |
1087 | (if prefix | |
1088 | (let ((ns (nxml-ns-get-prefix prefix))) | |
1089 | (and ns | |
1090 | (cons ns local-name))) | |
1091 | (cons nil local-name)))) | |
1092 | (cond ((not name) | |
1093 | (rng-recover-bad-attribute-prefix att)) | |
1094 | ((member name names) | |
1095 | (rng-recover-duplicate-attribute-name att)) | |
1096 | ((not (rng-match-attribute-name name)) | |
1097 | (rng-recover-attribute-name att)) | |
1098 | ((rng-match-text-typed-p) | |
1099 | (let ((value (xmltok-attribute-value att))) | |
1100 | (if value | |
1101 | (or (rng-match-attribute-value value) | |
1102 | (rng-recover-attribute-value att)) | |
1103 | (rng-match-after)))) | |
1104 | (t (or (rng-match-end-tag) | |
1105 | (error "Internal error:\ | |
1106 | invalid on untyped attribute value")))) | |
1107 | (setq names (cons name names))) | |
1108 | (setq atts (cdr atts))))) | |
1109 | ||
1110 | (defun rng-process-start-tag-close () | |
1111 | ;; deal with missing attributes | |
1112 | (unless (rng-match-start-tag-close) | |
1113 | (rng-mark-start-tag-close (rng-missing-attributes-message)) | |
1114 | (rng-match-ignore-attributes))) | |
1115 | ||
1116 | (defun rng-mark-start-tag-close (&rest args) | |
1117 | (when (not (eq xmltok-type 'partial-start-tag)) | |
1118 | (rng-mark-invalid (apply 'format args) | |
1119 | (- (point) | |
1120 | (if (eq xmltok-type 'empty-element) | |
1121 | 2 | |
1122 | 1)) | |
1123 | (point)))) | |
1124 | ||
1125 | (defun rng-recover-bad-element-prefix () | |
1126 | (rng-mark-invalid "Prefix not declared" | |
1127 | (1+ xmltok-start) | |
1128 | xmltok-name-colon) | |
1129 | (rng-match-unknown-start-tag-open)) | |
1130 | ||
1131 | (defun rng-recover-bad-attribute-prefix (att) | |
1132 | (rng-mark-invalid "Prefix not declared" | |
1133 | (xmltok-attribute-name-start att) | |
1134 | (xmltok-attribute-name-colon att))) | |
1135 | ||
1136 | (defun rng-recover-duplicate-attribute-name (att) | |
1137 | (rng-mark-invalid "Duplicate attribute" | |
1138 | (xmltok-attribute-name-start att) | |
1139 | (xmltok-attribute-name-end att))) | |
1140 | ||
1141 | (defun rng-recover-start-tag-open (name) | |
1142 | (let ((required (rng-match-required-element-name))) | |
1143 | (cond ((and required | |
1144 | (rng-match-start-tag-open required) | |
1145 | (rng-match-after) | |
1146 | (rng-match-start-tag-open name)) | |
1147 | (rng-mark-invalid (concat "Missing element " | |
1148 | (rng-quote-string | |
1149 | (rng-name-to-string required))) | |
1150 | xmltok-start | |
1151 | (1+ xmltok-start))) | |
1152 | ((and (rng-match-optionalize-elements) | |
1153 | (rng-match-start-tag-open name)) | |
1154 | (rng-mark-invalid "Required elements missing" | |
1155 | xmltok-start | |
1156 | (1+ xmltok-start))) | |
1157 | ((rng-match-out-of-context-start-tag-open name) | |
1158 | (rng-mark-invalid "Element not allowed in this context" | |
1159 | (1+ xmltok-start) | |
1160 | xmltok-name-end)) | |
1161 | (t | |
1162 | (rng-match-unknown-start-tag-open) | |
1163 | (rng-mark-invalid "Unknown element" | |
1164 | (1+ xmltok-start) | |
1165 | xmltok-name-end))))) | |
1166 | ||
1167 | (defun rng-recover-attribute-value (att) | |
1168 | (let ((start (xmltok-attribute-value-start att)) | |
1169 | (end (xmltok-attribute-value-end att))) | |
1170 | (if (= start end) | |
1171 | (rng-mark-invalid "Empty attribute value invalid" start (1+ end)) | |
1172 | (rng-mark-invalid "Attribute value invalid" start end))) | |
1173 | (rng-match-after)) | |
1174 | ||
1175 | (defun rng-recover-attribute-name (att) | |
1176 | (rng-mark-invalid "Attribute not allowed" | |
1177 | (xmltok-attribute-name-start att) | |
1178 | (xmltok-attribute-name-end att))) | |
1179 | ||
1180 | (defun rng-missing-attributes-message () | |
1181 | (let ((required-attributes | |
1182 | (rng-match-required-attribute-names))) | |
1183 | (cond ((not required-attributes) | |
1184 | "Required attributes missing") | |
1185 | ((not (cdr required-attributes)) | |
1186 | (concat "Missing attribute " | |
1187 | (rng-quote-string | |
1188 | (rng-name-to-string (car required-attributes) t)))) | |
1189 | (t | |
1190 | (concat "Missing attributes " | |
1191 | (mapconcat (lambda (nm) | |
1192 | (rng-quote-string | |
1193 | (rng-name-to-string nm t))) | |
1194 | required-attributes | |
1195 | ", ")))))) | |
10545bd8 | 1196 | |
8cd39fb3 MH |
1197 | (defun rng-process-end-tag (&optional partial) |
1198 | (cond ((not rng-open-elements) | |
1199 | (rng-mark-not-well-formed "Extra end-tag" | |
1200 | xmltok-start | |
1201 | (point))) | |
1202 | ((or partial | |
1203 | (equal (cons (xmltok-end-tag-prefix) | |
1204 | (xmltok-end-tag-local-name)) | |
1205 | (car rng-open-elements))) | |
1206 | (rng-end-element)) | |
1207 | (t (rng-recover-mismatched-end-tag)))) | |
1208 | ||
1209 | (defun rng-end-element () | |
1210 | (if rng-collecting-text | |
1211 | (let ((contents (rng-contents-string))) | |
1212 | (cond ((not contents) (rng-match-after)) | |
1213 | ((not (rng-match-element-value contents)) | |
1214 | (let* ((region (rng-contents-region))) | |
1215 | (if (not region) | |
1216 | (rng-mark-invalid "Empty content not allowed" | |
1217 | xmltok-start | |
1218 | (+ xmltok-start 2)) | |
1219 | (rng-mark-invalid "Invalid data" | |
1220 | (car region) | |
1221 | (cdr region)))) | |
1222 | (rng-match-after))) | |
1223 | (setq rng-collecting-text nil) | |
1224 | (setq rng-pending-contents nil)) | |
1225 | (unless (rng-match-end-tag) | |
1226 | (rng-mark-invalid (rng-missing-element-message) | |
1227 | xmltok-start | |
1228 | (+ xmltok-start 2)) | |
1229 | (rng-match-after))) | |
1230 | (nxml-ns-pop-state) | |
1231 | (when (eq (car rng-open-elements) t) | |
1232 | (rng-pop-tag)) | |
1233 | (rng-pop-tag)) | |
1234 | ||
1235 | (defun rng-missing-element-message () | |
1236 | (let ((element (rng-match-required-element-name))) | |
1237 | (if element | |
1238 | (concat "Missing element " | |
1239 | (rng-quote-string (rng-name-to-string element))) | |
1240 | "Required child elements missing"))) | |
1241 | ||
1242 | (defun rng-recover-mismatched-end-tag () | |
1243 | (let* ((name (cons (xmltok-end-tag-prefix) | |
1244 | (xmltok-end-tag-local-name)))) | |
1245 | (cond ((member name (cdr rng-open-elements)) | |
1246 | (let* ((suppress-error (eq (car rng-open-elements) t)) | |
1247 | missing top) | |
1248 | (while (progn | |
1249 | (setq top (car rng-open-elements)) | |
1250 | (rng-pop-tag) | |
1251 | (unless (eq top t) | |
1252 | (setq missing (cons top missing)) | |
1253 | (nxml-ns-pop-state) | |
1254 | (rng-match-after)) | |
1255 | (not (equal top name)))) | |
1256 | (unless suppress-error | |
1257 | (rng-mark-missing-end-tags (cdr missing))))) | |
1258 | ((rng-match-empty-before-p) | |
1259 | (rng-mark-mismatched-end-tag) | |
1260 | (rng-end-element)) | |
1261 | (t (rng-mark-mismatched-end-tag) | |
1262 | (setq rng-open-elements | |
1263 | (cons t rng-open-elements)))))) | |
1264 | ||
1265 | (defun rng-mark-missing-end-tags (missing) | |
1266 | (rng-mark-not-well-formed | |
1267 | (format "Missing end-tag%s %s" | |
1268 | (if (null (cdr missing)) "" "s") | |
1269 | (mapconcat (lambda (name) | |
1270 | (rng-quote-string | |
1271 | (if (car name) | |
1272 | (concat (car name) | |
1273 | ":" | |
1274 | (cdr name)) | |
1275 | (cdr name)))) | |
1276 | missing | |
1277 | ", ")) | |
1278 | xmltok-start | |
1279 | (+ xmltok-start 2))) | |
1280 | ||
1281 | (defun rng-mark-mismatched-end-tag () | |
1282 | (rng-mark-not-well-formed "Mismatched end-tag" | |
1283 | (+ xmltok-start 2) | |
1284 | xmltok-name-end)) | |
1285 | ||
1286 | (defun rng-push-tag (prefix-local-name) | |
1287 | (setq rng-open-elements | |
1288 | (cons prefix-local-name rng-open-elements))) | |
1289 | ||
1290 | (defun rng-pop-tag () | |
1291 | (setq rng-open-elements (cdr rng-open-elements))) | |
1292 | ||
1293 | (defun rng-contents-string () | |
1294 | (let ((contents rng-pending-contents)) | |
1295 | (cond ((not contents) "") | |
1296 | ((memq nil contents) nil) | |
1297 | ((not (cdr contents)) | |
1298 | (rng-segment-string (car contents))) | |
1299 | (t (apply 'concat | |
1300 | (nreverse (mapcar 'rng-segment-string | |
1301 | contents))))))) | |
1302 | ||
1303 | (defun rng-segment-string (segment) | |
1304 | (or (car segment) | |
1305 | (apply 'buffer-substring-no-properties | |
1306 | (cdr segment)))) | |
1307 | ||
1308 | (defun rng-segment-blank-p (segment) | |
1309 | (if (car segment) | |
1310 | (rng-blank-p (car segment)) | |
1311 | (apply 'rng-region-blank-p | |
1312 | (cdr segment)))) | |
1313 | ||
1314 | (defun rng-contents-region () | |
1315 | (if (null rng-pending-contents) | |
1316 | nil | |
1317 | (let* ((contents rng-pending-contents) | |
1318 | (head (cdar contents)) | |
1319 | (start (car head)) | |
1320 | (end (cadr head))) | |
1321 | (while (setq contents (cdr contents)) | |
1322 | (setq start (car (cdar contents)))) | |
1323 | (cons start end)))) | |
1324 | ||
1325 | (defun rng-process-text (start end whitespace &optional value) | |
1326 | "Process characters between position START and END as text. | |
10545bd8 | 1327 | END nil means point. WHITESPACE t means known to be whitespace, nil |
8cd39fb3 | 1328 | means known not to be, anything else means unknown whether whitespace |
10545bd8 | 1329 | or not. END must not be nil if WHITESPACE is neither t nor nil. |
8cd39fb3 MH |
1330 | VALUE is a string or nil; nil means the value is equal to the |
1331 | string between START and END." | |
1332 | (cond (rng-collecting-text | |
1333 | (setq rng-pending-contents (cons (list value start (or end (point))) | |
1334 | rng-pending-contents))) | |
1335 | ((not (or (and whitespace | |
1336 | (or (eq whitespace t) | |
1337 | (if value | |
1338 | (rng-blank-p value) | |
1339 | (rng-region-blank-p start end)))) | |
1340 | (rng-match-mixed-text))) | |
1341 | (rng-mark-invalid "Text not allowed" start (or end (point)))))) | |
1342 | ||
1343 | (defun rng-process-unknown-char () | |
1344 | (when rng-collecting-text | |
1345 | (setq rng-pending-contents | |
1346 | (cons nil rng-pending-contents)))) | |
1347 | ||
1348 | (defun rng-process-unknown-entity () | |
1349 | (rng-process-unknown-char) | |
1350 | (rng-match-optionalize-elements)) | |
1351 | ||
1352 | (defun rng-region-blank-p (beg end) | |
1353 | (save-excursion | |
1354 | (goto-char beg) | |
1355 | (= (skip-chars-forward " \n\r\t" end) | |
1356 | (- end beg)))) | |
1357 | ||
1358 | (defun rng-flush-text () | |
1359 | (while rng-pending-contents | |
1360 | (let ((segment (car rng-pending-contents))) | |
1361 | (unless (or (rng-segment-blank-p segment) | |
1362 | (rng-match-mixed-text)) | |
1363 | (let ((region (cdr segment))) | |
1364 | (rng-mark-invalid "In this context text cannot be mixed with elements" | |
1365 | (car region) | |
1366 | (cadr region))))) | |
1367 | (setq rng-pending-contents (cdr rng-pending-contents)))) | |
1368 | ||
1369 | (defun rng-process-end-document () | |
1370 | ;; this is necessary to clear empty overlays at (point-max) | |
1371 | (rng-clear-overlays (point) (point)) | |
1372 | (let ((start (save-excursion | |
1373 | (skip-chars-backward " \t\r\n") | |
1374 | (point)))) | |
1375 | (cond (rng-open-elements | |
1376 | (unless (eq (car rng-open-elements) t) | |
1377 | (rng-mark-not-well-formed "Missing end-tag" | |
1378 | start | |
1379 | (point)))) | |
1380 | ((not (rng-match-nullable-p)) | |
1381 | (rng-mark-not-well-formed "No document element" | |
1382 | start | |
1383 | (point)))))) | |
1384 | ||
1385 | (defun rng-process-encoding-name (beg end) | |
1386 | (unless (let ((charset (buffer-substring-no-properties beg end))) | |
1387 | (or (nxml-mime-charset-coding-system charset) | |
1388 | (string= (downcase charset) "utf-16"))) | |
1389 | (rng-mark-not-well-formed "Unsupported encoding" beg end))) | |
1390 | ||
1391 | (defun rng-name-to-string (name &optional attributep) | |
1392 | (let ((ns (car name)) | |
1393 | (local-name (cdr name))) | |
1394 | (if (or (not ns) | |
1395 | (and (not attributep) | |
1396 | (eq (nxml-ns-get-default) ns))) | |
1397 | local-name | |
1398 | (let ((prefix (nxml-ns-prefix-for ns))) | |
1399 | (if prefix | |
1400 | (concat prefix ":" local-name) | |
1401 | (concat "{" (symbol-name ns) "}" local-name)))))) | |
1402 | ||
1403 | (provide 'rng-valid) | |
1404 | ||
1405 | ;;; rng-valid.el ends here |