Mercurial > emacs
annotate lisp/nxml/rng-valid.el @ 110149:4ac2b883320e
Forgor to save ChangeLog for previous commit.
author | Jan D. <jan.h.d@swipnet.se> |
---|---|
date | Thu, 02 Sep 2010 12:20:20 +0200 |
parents | 1d1d5d9bd884 |
children | 49c747159b30 376148b31b5e |
rev | line source |
---|---|
86361 | 1 ;;; rng-valid.el --- real-time validation of XML using RELAX NG |
2 | |
106815 | 3 ;; Copyright (C) 2003, 2007, 2008, 2009, 2010 Free Software Foundation, Inc. |
86361 | 4 |
5 ;; Author: James Clark | |
6 ;; Keywords: XML, RelaxNG | |
7 | |
86555 | 8 ;; This file is part of GNU Emacs. |
9 | |
94666
d495d4d5452f
Switch to recommended form of GPLv3 permissions notice.
Glenn Morris <rgm@gnu.org>
parents:
87665
diff
changeset
|
10 ;; GNU Emacs is free software: you can redistribute it and/or modify |
86555 | 11 ;; it under the terms of the GNU General Public License as published by |
94666
d495d4d5452f
Switch to recommended form of GPLv3 permissions notice.
Glenn Morris <rgm@gnu.org>
parents:
87665
diff
changeset
|
12 ;; the Free Software Foundation, either version 3 of the License, or |
d495d4d5452f
Switch to recommended form of GPLv3 permissions notice.
Glenn Morris <rgm@gnu.org>
parents:
87665
diff
changeset
|
13 ;; (at your option) any later version. |
86361 | 14 |
86555 | 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 |
86555 | 20 ;; You should have received a copy of the GNU General Public License |
94666
d495d4d5452f
Switch to recommended form of GPLv3 permissions notice.
Glenn Morris <rgm@gnu.org>
parents:
87665
diff
changeset
|
21 ;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>. |
86361 | 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 | |
87346
c5910db8e06e
(rng-error): Rename from rng-error-face.
Jason Rumney <jasonr@gnu.org>
parents:
86555
diff
changeset
|
108 (defface rng-error '((t (:inherit font-lock-warning-face))) |
86361 | 109 "Face for highlighting XML errors." |
110 :group 'relax-ng) | |
111 | |
112 (defcustom rng-state-cache-distance 2000 | |
113 "*Distance in characters between each parsing and validation state cache." | |
114 :type 'integer | |
115 :group 'relax-ng) | |
116 | |
117 (defcustom rng-validate-chunk-size 8000 | |
118 "*Number of characters in a RELAX NG validation chunk. | |
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 | |
126 "*Time in seconds that Emacs must be idle before starting a full validation. | |
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 | |
133 "*Time in seconds that Emacs must be idle before starting a quick validation. | |
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 | |
96496
e374c747704b
Fix typos, and general docstring cleanup.
Juanma Barranquero <lekktu@gmail.com>
parents:
96361
diff
changeset
|
151 "Number of errors in the current buffer. |
e374c747704b
Fix typos, and general docstring cleanup.
Juanma Barranquero <lekktu@gmail.com>
parents:
96361
diff
changeset
|
152 Always equal to number of overlays with category `rng-error'.") |
86361 | 153 (make-variable-buffer-local 'rng-error-count) |
154 | |
155 (defvar rng-message-overlay nil | |
96496
e374c747704b
Fix typos, and general docstring cleanup.
Juanma Barranquero <lekktu@gmail.com>
parents:
96361
diff
changeset
|
156 "Overlay in this buffer whose `help-echo' property was last printed. |
e374c747704b
Fix typos, and general docstring cleanup.
Juanma Barranquero <lekktu@gmail.com>
parents:
96361
diff
changeset
|
157 It is nil if none.") |
86361 | 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. | |
96496
e374c747704b
Fix typos, and general docstring cleanup.
Juanma Barranquero <lekktu@gmail.com>
parents:
96361
diff
changeset
|
192 It is nil if there is no conditionally up-to-date region. The |
e374c747704b
Fix typos, and general docstring cleanup.
Juanma Barranquero <lekktu@gmail.com>
parents:
96361
diff
changeset
|
193 conditionally up-to-date region must be such that for any cached |
e374c747704b
Fix typos, and general docstring cleanup.
Juanma Barranquero <lekktu@gmail.com>
parents:
96361
diff
changeset
|
194 state S with position P in the conditionally up-to-date region, |
e374c747704b
Fix typos, and general docstring cleanup.
Juanma Barranquero <lekktu@gmail.com>
parents:
96361
diff
changeset
|
195 if at some point it is determined that S becomes correct for P, |
e374c747704b
Fix typos, and general docstring cleanup.
Juanma Barranquero <lekktu@gmail.com>
parents:
96361
diff
changeset
|
196 then all states with position >= P in the conditionally up to |
e374c747704b
Fix typos, and general docstring cleanup.
Juanma Barranquero <lekktu@gmail.com>
parents:
96361
diff
changeset
|
197 date region must also then be correct and all errors between P |
e374c747704b
Fix typos, and general docstring cleanup.
Juanma Barranquero <lekktu@gmail.com>
parents:
96361
diff
changeset
|
198 and the end of the region must then be correctly marked.") |
86361 | 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. | |
96496
e374c747704b
Fix typos, and general docstring cleanup.
Juanma Barranquero <lekktu@gmail.com>
parents:
96361
diff
changeset
|
203 It is nil if there is no conditionally up-to-date region. |
e374c747704b
Fix typos, and general docstring cleanup.
Juanma Barranquero <lekktu@gmail.com>
parents:
96361
diff
changeset
|
204 See the variable `rng-conditional-up-to-date-start'.") |
86361 | 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 | |
96496
e374c747704b
Fix typos, and general docstring cleanup.
Juanma Barranquero <lekktu@gmail.com>
parents:
96361
diff
changeset
|
223 RELAX NG schema. The mode-line indicates whether it is or not. Any |
86361 | 224 parts of the buffer that cause it not to be are considered errors and |
96496
e374c747704b
Fix typos, and general docstring cleanup.
Juanma Barranquero <lekktu@gmail.com>
parents:
96361
diff
changeset
|
225 are highlighted with face `rng-error'. A description of each error is |
86361 | 226 available as a tooltip. \\[rng-next-error] goes to the next error |
96496
e374c747704b
Fix typos, and general docstring cleanup.
Juanma Barranquero <lekktu@gmail.com>
parents:
96361
diff
changeset
|
227 after point. Clicking mouse-1 on the word `Invalid' in the mode-line |
e374c747704b
Fix typos, and general docstring cleanup.
Juanma Barranquero <lekktu@gmail.com>
parents:
96361
diff
changeset
|
228 goes to the first error in the buffer. If the buffer changes, then it |
86361 | 229 will be automatically rechecked when Emacs becomes idle; the |
96496
e374c747704b
Fix typos, and general docstring cleanup.
Juanma Barranquero <lekktu@gmail.com>
parents:
96361
diff
changeset
|
230 rechecking will be paused whenever there is input pending. |
86361 | 231 |
232 By default, uses a vacuous schema that allows any well-formed XML | |
96496
e374c747704b
Fix typos, and general docstring cleanup.
Juanma Barranquero <lekktu@gmail.com>
parents:
96361
diff
changeset
|
233 document. A schema can be specified explictly using |
86361 | 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) | |
247 (nxml-with-unmodifying-text-property-changes | |
248 (rng-clear-cached-state (point-min) (point-max))) | |
249 ;; 1+ to clear empty overlays at (point-max) | |
106307
cbe5e21da2e4
Try and remove assumptions about point-min==1.
Stefan Monnier <monnier@iro.umontreal.ca>
parents:
100908
diff
changeset
|
250 (rng-clear-overlays (point-min) (1+ (point-max))) |
cbe5e21da2e4
Try and remove assumptions about point-min==1.
Stefan Monnier <monnier@iro.umontreal.ca>
parents:
100908
diff
changeset
|
251 (setq rng-validate-up-to-date-end (point-min))) |
86361 | 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)))) | |
96496
e374c747704b
Fix typos, and general docstring cleanup.
Juanma Barranquero <lekktu@gmail.com>
parents:
96361
diff
changeset
|
298 |
86361 | 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) | |
307 (setq rng-message-overlay-inhibit-point nil) | |
308 (nxml-with-unmodifying-text-property-changes | |
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). | |
106307
cbe5e21da2e4
Try and remove assumptions about point-min==1.
Stefan Monnier <monnier@iro.umontreal.ca>
parents:
100908
diff
changeset
|
334 ;; otherwise rng-validate-prepare will say there's nothing to do. |
cbe5e21da2e4
Try and remove assumptions about point-min==1.
Stefan Monnier <monnier@iro.umontreal.ca>
parents:
100908
diff
changeset
|
335 (when (>= rng-validate-up-to-date-end (point-max)) |
cbe5e21da2e4
Try and remove assumptions about point-min==1.
Stefan Monnier <monnier@iro.umontreal.ca>
parents:
100908
diff
changeset
|
336 (setq rng-validate-up-to-date-end |
cbe5e21da2e4
Try and remove assumptions about point-min==1.
Stefan Monnier <monnier@iro.umontreal.ca>
parents:
100908
diff
changeset
|
337 (if (< (point-min) (point-max)) |
cbe5e21da2e4
Try and remove assumptions about point-min==1.
Stefan Monnier <monnier@iro.umontreal.ca>
parents:
100908
diff
changeset
|
338 (1- (point-max)) |
cbe5e21da2e4
Try and remove assumptions about point-min==1.
Stefan Monnier <monnier@iro.umontreal.ca>
parents:
100908
diff
changeset
|
339 ;; Only widen if really necessary. |
cbe5e21da2e4
Try and remove assumptions about point-min==1.
Stefan Monnier <monnier@iro.umontreal.ca>
parents:
100908
diff
changeset
|
340 (save-restriction (widen) (max (point-min) (1- (point-max))))))) |
86361 | 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 | |
106307
cbe5e21da2e4
Try and remove assumptions about point-min==1.
Stefan Monnier <monnier@iro.umontreal.ca>
parents:
100908
diff
changeset
|
355 (/ (* (- rng-validate-up-to-date-end (point-min)) |
cbe5e21da2e4
Try and remove assumptions about point-min==1.
Stefan Monnier <monnier@iro.umontreal.ca>
parents:
100908
diff
changeset
|
356 100.0) |
cbe5e21da2e4
Try and remove assumptions about point-min==1.
Stefan Monnier <monnier@iro.umontreal.ca>
parents:
100908
diff
changeset
|
357 (- (point-max) (point-min)))))) |
86361 | 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"))) | |
96496
e374c747704b
Fix typos, and general docstring cleanup.
Juanma Barranquero <lekktu@gmail.com>
parents:
96361
diff
changeset
|
367 |
86361 | 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 | |
380 ;; cancelled even after changing mode. | |
381 ;; This function takes care of cancelling the timers and | |
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))) | |
96496
e374c747704b
Fix typos, and general docstring cleanup.
Juanma Barranquero <lekktu@gmail.com>
parents:
96361
diff
changeset
|
391 |
86361 | 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 () | |
417 ;; input-pending-p and sit-for run timers that are | |
418 ;; ripe. Binding timer-idle-list to nil prevents | |
419 ;; this. If we don't do this, then any ripe timers | |
420 ;; will get run, and we won't get any chance to | |
421 ;; validate until Emacs becomes idle again or until | |
422 ;; the other lower priority timers finish (which | |
423 ;; can take a very long time in the case of | |
424 ;; jit-lock). | |
425 (let ((timer-idle-list nil)) | |
426 (and (not (input-pending-p)) | |
427 ;; Fake rng-validate-up-to-date-end so that the mode line | |
428 ;; shows progress. Also use this to save point. | |
429 (let ((rng-validate-up-to-date-end (point))) | |
430 (goto-char rng-validate-display-point) | |
431 (when (not rng-validate-display-modified-p) | |
432 (restore-buffer-modified-p nil)) | |
433 (force-mode-line-update) | |
434 (let ((continue (sit-for 0))) | |
435 (goto-char rng-validate-up-to-date-end) | |
436 continue))))) | |
437 | |
438 ;; Calling rng-do-some-validation once with a continue-p function, as | |
439 ;; opposed to calling it repeatedly, helps on initial validation of a | |
440 ;; large buffer with lots of errors. The overlays for errors will all | |
441 ;; get added when rng-do-some-validation returns and won't slow the | |
442 ;; validation process down. | |
443 | |
444 (defun rng-validate-while-idle (buffer) | |
445 (with-current-buffer buffer | |
446 (if rng-validate-mode | |
447 (if (let ((rng-validate-display-point (point)) | |
448 (rng-validate-display-modified-p (buffer-modified-p))) | |
449 (rng-do-some-validation 'rng-validate-while-idle-continue-p)) | |
450 (force-mode-line-update) | |
451 (rng-validate-done)) | |
452 ;; must have done kill-all-local-variables | |
453 (rng-kill-timers)))) | |
454 | |
455 (defun rng-validate-quick-while-idle (buffer) | |
456 (with-current-buffer buffer | |
457 (if rng-validate-mode | |
458 (if (rng-do-some-validation) | |
459 (force-mode-line-update) | |
460 (rng-validate-done)) | |
461 ;; must have done kill-all-local-variables | |
462 (rng-kill-timers)))) | |
463 | |
464 (defun rng-validate-done () | |
465 (when (or (not (current-message)) | |
466 (rng-current-message-from-error-overlay-p)) | |
96496
e374c747704b
Fix typos, and general docstring cleanup.
Juanma Barranquero <lekktu@gmail.com>
parents:
96361
diff
changeset
|
467 (rng-error-overlay-message (or (rng-error-overlay-after (point)) |
86361 | 468 (rng-error-overlay-after (1- (point)))))) |
469 (rng-cancel-timers) | |
470 (force-mode-line-update)) | |
471 | |
472 (defun rng-do-some-validation (&optional continue-p-function) | |
96496
e374c747704b
Fix typos, and general docstring cleanup.
Juanma Barranquero <lekktu@gmail.com>
parents:
96361
diff
changeset
|
473 "Do some validation work. Return t if more to do, nil otherwise." |
86361 | 474 (save-excursion |
475 (save-restriction | |
476 (widen) | |
477 (nxml-with-invisible-motion | |
106307
cbe5e21da2e4
Try and remove assumptions about point-min==1.
Stefan Monnier <monnier@iro.umontreal.ca>
parents:
100908
diff
changeset
|
478 (condition-case-no-debug err |
86361 | 479 (and (rng-validate-prepare) |
480 (let ((rng-dt-namespace-context-getter '(nxml-ns-get-context))) | |
481 (nxml-with-unmodifying-text-property-changes | |
482 (rng-do-some-validation-1 continue-p-function)))) | |
96361
a99299e4d2de
American English spelling fix.
Glenn Morris <rgm@gnu.org>
parents:
94666
diff
changeset
|
483 ;; errors signaled from a function run by an idle timer |
86361 | 484 ;; are ignored; if we don't catch them, validation |
485 ;; will get mysteriously stuck at a single place | |
486 (rng-compile-error | |
487 (message "Incorrect schema. %s" (nth 1 err)) | |
488 (rng-validate-mode 0) | |
489 nil) | |
490 (error | |
491 (message "Internal error in rng-validate-mode triggered at buffer position %d. %s" | |
492 (point) | |
493 (error-message-string err)) | |
494 (rng-validate-mode 0) | |
495 nil)))))) | |
496 | |
497 (defun rng-validate-prepare () | |
498 "Prepare to do some validation, initializing point and the state. | |
499 Return t if there is work to do, nil otherwise." | |
500 (cond ((= rng-validate-up-to-date-end (point-min)) | |
501 (rng-set-initial-state) | |
502 t) | |
503 ((= rng-validate-up-to-date-end (point-max)) | |
504 nil) | |
505 (t (let ((state (get-text-property (1- rng-validate-up-to-date-end) | |
506 'rng-state))) | |
507 (cond (state | |
508 (rng-restore-state state) | |
509 (goto-char rng-validate-up-to-date-end)) | |
510 (t | |
511 (let ((pos (previous-single-property-change | |
512 rng-validate-up-to-date-end | |
513 'rng-state))) | |
514 (cond (pos | |
515 (rng-restore-state | |
516 (or (get-text-property (1- pos) 'rng-state) | |
517 (error "Internal error: state null"))) | |
518 (goto-char pos)) | |
519 (t (rng-set-initial-state)))))))))) | |
520 | |
521 | |
522 (defun rng-do-some-validation-1 (&optional continue-p-function) | |
523 (let ((limit (+ rng-validate-up-to-date-end | |
524 rng-validate-chunk-size)) | |
525 (remove-start rng-validate-up-to-date-end) | |
526 (next-cache-point (+ (point) rng-state-cache-distance)) | |
527 (continue t) | |
528 (xmltok-dtd rng-dtd) | |
529 have-remaining-chars | |
530 xmltok-type | |
531 xmltok-start | |
532 xmltok-name-colon | |
533 xmltok-name-end | |
534 xmltok-replacement | |
535 xmltok-attributes | |
536 xmltok-namespace-attributes | |
537 xmltok-dependent-regions | |
538 xmltok-errors) | |
539 (when (= (point) 1) | |
540 (let ((regions (xmltok-forward-prolog))) | |
541 (rng-clear-overlays 1 (point)) | |
542 (while regions | |
543 (when (eq (aref (car regions) 0) 'encoding-name) | |
544 (rng-process-encoding-name (aref (car regions) 1) | |
545 (aref (car regions) 2))) | |
546 (setq regions (cdr regions)))) | |
547 (unless (equal rng-dtd xmltok-dtd) | |
548 (rng-clear-conditional-region)) | |
549 (setq rng-dtd xmltok-dtd)) | |
550 (while continue | |
551 (setq have-remaining-chars (rng-forward)) | |
552 (let ((pos (point))) | |
553 (setq continue | |
554 (and have-remaining-chars | |
555 (or (< pos limit) | |
556 (and continue-p-function | |
557 (funcall continue-p-function) | |
558 (setq limit (+ limit rng-validate-chunk-size)) | |
559 t)))) | |
560 (cond ((and rng-conditional-up-to-date-start | |
561 ;; > because we are getting the state from (1- pos) | |
562 (> pos rng-conditional-up-to-date-start) | |
563 (< pos rng-conditional-up-to-date-end) | |
564 (rng-state-matches-current (get-text-property (1- pos) | |
565 'rng-state))) | |
566 (when (< remove-start (1- pos)) | |
567 (rng-clear-cached-state remove-start (1- pos))) | |
568 ;; sync up with cached validation state | |
569 (setq continue nil) | |
570 ;; do this before settting rng-validate-up-to-date-end | |
571 ;; in case we get a quit | |
572 (rng-mark-xmltok-errors) | |
573 (rng-mark-xmltok-dependent-regions) | |
574 (setq rng-validate-up-to-date-end | |
575 (marker-position rng-conditional-up-to-date-end)) | |
576 (rng-clear-conditional-region) | |
577 (setq have-remaining-chars | |
578 (< rng-validate-up-to-date-end (point-max)))) | |
579 ((or (>= pos next-cache-point) | |
580 (not continue)) | |
581 (setq next-cache-point (+ pos rng-state-cache-distance)) | |
582 (rng-clear-cached-state remove-start pos) | |
583 (when have-remaining-chars | |
584 (rng-cache-state (1- pos))) | |
585 (setq remove-start pos) | |
586 (unless continue | |
587 ;; if we have just blank chars skip to the end | |
588 (when have-remaining-chars | |
589 (skip-chars-forward " \t\r\n") | |
590 (when (= (point) (point-max)) | |
591 (rng-clear-overlays pos (point)) | |
592 (rng-clear-cached-state pos (point)) | |
593 (setq have-remaining-chars nil) | |
594 (setq pos (point)))) | |
595 (when (not have-remaining-chars) | |
596 (rng-process-end-document)) | |
597 (rng-mark-xmltok-errors) | |
598 (rng-mark-xmltok-dependent-regions) | |
599 (setq rng-validate-up-to-date-end pos) | |
600 (when rng-conditional-up-to-date-end | |
601 (cond ((<= rng-conditional-up-to-date-end pos) | |
602 (rng-clear-conditional-region)) | |
603 ((< rng-conditional-up-to-date-start pos) | |
604 (set-marker rng-conditional-up-to-date-start | |
605 pos))))))))) | |
606 have-remaining-chars)) | |
96496
e374c747704b
Fix typos, and general docstring cleanup.
Juanma Barranquero <lekktu@gmail.com>
parents:
96361
diff
changeset
|
607 |
86361 | 608 (defun rng-clear-conditional-region () |
609 (when rng-conditional-up-to-date-start | |
610 (set-marker rng-conditional-up-to-date-start nil) | |
611 (setq rng-conditional-up-to-date-start nil)) | |
612 (when rng-conditional-up-to-date-end | |
613 (set-marker rng-conditional-up-to-date-end nil) | |
614 (setq rng-conditional-up-to-date-end nil))) | |
615 | |
616 (defun rng-clear-cached-state (start end) | |
617 "Clear cached state between START and END." | |
618 (remove-text-properties start end '(rng-state nil))) | |
619 | |
620 (defun rng-cache-state (pos) | |
621 "Save the current state in a text property on the character at pos." | |
622 (put-text-property pos | |
623 (1+ pos) | |
624 'rng-state | |
625 (rng-get-state))) | |
626 | |
627 (defun rng-state-matches-current (state) | |
628 (and state | |
629 (rng-match-state-equal (car state)) | |
630 (nxml-ns-state-equal (nth 1 state)) | |
631 (equal (nth 2 state) rng-open-elements))) | |
632 | |
633 (defun rng-get-state () | |
634 (list (rng-match-state) | |
635 (nxml-ns-state) | |
636 rng-open-elements)) | |
637 | |
638 (defun rng-restore-state (state) | |
639 (rng-set-match-state (car state)) | |
640 (setq state (cdr state)) | |
641 (nxml-ns-set-state (car state)) | |
642 (setq rng-open-elements (cadr state)) | |
643 (setq rng-pending-contents nil) | |
644 (setq rng-collecting-text (rng-match-text-typed-p))) | |
645 | |
646 (defun rng-set-initial-state () | |
647 (nxml-ns-init) | |
648 (rng-match-start-document) | |
649 (setq rng-open-elements nil) | |
650 (setq rng-pending-contents nil) | |
651 (goto-char (point-min))) | |
652 | |
653 (defun rng-clear-overlays (beg end) | |
654 (unless rng-parsing-for-state | |
655 (let ((overlays (overlays-in beg end))) | |
656 (while overlays | |
657 (let* ((overlay (car overlays)) | |
658 (category (overlay-get overlay 'category))) | |
659 (cond ((eq category 'rng-error) | |
660 (let ((inhibit-quit t)) | |
661 (when (eq overlay rng-message-overlay) | |
662 (rng-error-overlay-message nil)) | |
663 (delete-overlay overlay) | |
664 ;; rng-error-count could be nil | |
665 ;; if overlays left over from a previous use | |
666 ;; of rng-validate-mode that ended with a change of mode | |
667 (when rng-error-count | |
668 (setq rng-error-count (1- rng-error-count))))) | |
669 ((and (eq category 'rng-dependent) | |
670 (<= beg (overlay-start overlay))) | |
671 (delete-overlay overlay)))) | |
672 (setq overlays (cdr overlays)))))) | |
673 | |
674 ;;; Dependent regions | |
675 | |
676 (defun rng-mark-xmltok-dependent-regions () | |
677 (while xmltok-dependent-regions | |
678 (apply 'rng-mark-xmltok-dependent-region | |
679 (car xmltok-dependent-regions)) | |
680 (setq xmltok-dependent-regions | |
681 (cdr xmltok-dependent-regions)))) | |
682 | |
683 (defun rng-mark-xmltok-dependent-region (fun start end &rest args) | |
684 (let ((overlay (make-overlay start end nil t t))) | |
685 (overlay-put overlay 'category 'rng-dependent) | |
686 (overlay-put overlay 'rng-funargs (cons fun args)))) | |
687 | |
688 (put 'rng-dependent 'evaporate t) | |
689 (put 'rng-dependent 'modification-hooks '(rng-dependent-region-changed)) | |
690 (put 'rng-dependent 'insert-behind-hooks '(rng-dependent-region-changed)) | |
691 | |
692 (defun rng-dependent-region-changed (overlay | |
693 after-p | |
694 change-start | |
695 change-end | |
696 &optional pre-change-length) | |
697 (when (and after-p | |
698 ;; Emacs sometimes appears to call deleted overlays | |
699 (overlay-start overlay) | |
700 (let ((funargs (overlay-get overlay 'rng-funargs))) | |
701 (save-match-data | |
702 (save-excursion | |
703 (save-restriction | |
704 (widen) | |
705 (apply (car funargs) | |
706 (append (list change-start | |
707 change-end | |
708 pre-change-length | |
709 (overlay-start overlay) | |
710 (overlay-end overlay)) | |
711 (cdr funargs)))))))) | |
712 (rng-after-change-function (overlay-start overlay) | |
713 change-end | |
714 (+ pre-change-length | |
715 (- (overlay-start overlay) | |
716 change-start))) | |
717 (delete-overlay overlay))) | |
718 | |
719 ;;; Error state | |
720 | |
721 (defun rng-mark-xmltok-errors () | |
722 (while xmltok-errors | |
723 (let ((err (car xmltok-errors))) | |
724 (rng-mark-not-well-formed (xmltok-error-message err) | |
725 (xmltok-error-start err) | |
726 (xmltok-error-end err))) | |
727 (setq xmltok-errors (cdr xmltok-errors)))) | |
728 | |
729 (defun rng-mark-invalid (message beg end) | |
730 (rng-mark-error message beg end)) | |
731 | |
732 (defun rng-mark-not-well-formed (message beg end) | |
733 ;; Don't try to validate further | |
734 ;;(rng-set-match-state rng-not-allowed-ipattern) | |
735 (rng-mark-error message beg end)) | |
736 | |
737 (defun rng-mark-error (message beg end) | |
738 (unless rng-parsing-for-state | |
739 (let ((overlays (overlays-in beg end))) | |
740 (while (and overlays message) | |
741 (let ((o (car overlays))) | |
742 (when (and (eq (overlay-get o 'category) 'rng-error) | |
743 (= (overlay-start o) beg) | |
744 (= (overlay-end o) end)) | |
745 (overlay-put o | |
746 'help-echo | |
747 (concat (overlay-get o 'help-echo) | |
748 "\n" | |
749 message)) | |
750 (setq message nil))) | |
751 (setq overlays (cdr overlays)))) | |
752 (when message | |
753 (let ((inhibit-quit t)) | |
754 (setq rng-error-count (1+ rng-error-count)) | |
755 (let ((overlay | |
756 (make-overlay beg end nil t | |
757 ;; Need to make the rear delimiter advance | |
758 ;; with the front delimiter when the overlay | |
759 ;; is empty, otherwise the front delimiter | |
760 ;; will move past the rear delimiter. | |
761 (= beg end)))) | |
762 ;; Ensure when we have two overlapping messages, the help-echo | |
763 ;; of the one that starts first is shown | |
764 (overlay-put overlay 'priority beg) | |
765 (overlay-put overlay 'category 'rng-error) | |
766 (overlay-put overlay 'help-echo message)))))) | |
767 | |
87346
c5910db8e06e
(rng-error): Rename from rng-error-face.
Jason Rumney <jasonr@gnu.org>
parents:
86555
diff
changeset
|
768 (put 'rng-error 'face 'rng-error) |
86361 | 769 (put 'rng-error 'modification-hooks '(rng-error-modified)) |
770 | |
771 ;; If we don't do this, then the front delimiter can move | |
772 ;; past the end delimiter. | |
773 (defun rng-error-modified (overlay after-p beg end &optional pre-change-len) | |
774 (when (and after-p | |
775 (overlay-start overlay) ; check not deleted | |
776 (>= (overlay-start overlay) | |
777 (overlay-end overlay))) | |
778 (let ((inhibit-quit t)) | |
779 (delete-overlay overlay) | |
780 (setq rng-error-count (1- rng-error-count))))) | |
781 | |
782 (defun rng-echo-area-clear-function () | |
783 (setq rng-message-overlay-current nil)) | |
784 | |
785 ;;; Error navigation | |
96496
e374c747704b
Fix typos, and general docstring cleanup.
Juanma Barranquero <lekktu@gmail.com>
parents:
96361
diff
changeset
|
786 |
86361 | 787 (defun rng-maybe-echo-error-at-point () |
788 (when (or (not (current-message)) | |
789 (rng-current-message-from-error-overlay-p)) | |
790 (rng-error-overlay-message (rng-error-overlay-after (point))))) | |
791 | |
792 (defun rng-error-overlay-after (pos) | |
793 (let ((overlays (overlays-in pos (1+ pos))) | |
794 (best nil)) | |
795 (while overlays | |
796 (let ((overlay (car overlays))) | |
797 (when (and (eq (overlay-get overlay 'category) | |
798 'rng-error) | |
799 (or (not best) | |
800 (< (overlay-start best) | |
801 (overlay-start overlay)))) | |
802 (setq best overlay))) | |
803 (setq overlays (cdr overlays))) | |
804 best)) | |
805 | |
806 (defun rng-first-error () | |
807 "Go to the first validation error. | |
808 Turn on `rng-validate-mode' if it is not already on." | |
809 (interactive) | |
810 (or rng-validate-mode (rng-validate-mode)) | |
106307
cbe5e21da2e4
Try and remove assumptions about point-min==1.
Stefan Monnier <monnier@iro.umontreal.ca>
parents:
100908
diff
changeset
|
811 (rng-do-some-validation) |
86361 | 812 (let ((err (rng-find-next-error-overlay (1- (point-min))))) |
813 (if err | |
814 (rng-goto-error-overlay err) | |
815 (let ((pos (save-excursion | |
816 (goto-char (point-min)) | |
817 (rng-next-error 1)))) | |
818 (when pos | |
819 (goto-char pos)))))) | |
820 | |
821 (defun rng-mouse-first-error (event) | |
822 "Go to the first validation error from a mouse click." | |
823 (interactive "e") | |
824 (select-window (posn-window (event-start event))) | |
825 (rng-first-error)) | |
826 | |
827 (defun rng-next-error (arg) | |
828 "Go to the next validation error after point. | |
829 Turn on `rng-validate-mode' if it is not already on. | |
96496
e374c747704b
Fix typos, and general docstring cleanup.
Juanma Barranquero <lekktu@gmail.com>
parents:
96361
diff
changeset
|
830 A prefix ARG specifies how many errors to move. |
e374c747704b
Fix typos, and general docstring cleanup.
Juanma Barranquero <lekktu@gmail.com>
parents:
96361
diff
changeset
|
831 A negative ARG moves backwards. Just \\[universal-argument] as a prefix |
86361 | 832 means goto the first error." |
833 (interactive "P") | |
834 (if (consp arg) | |
835 (rng-first-error) | |
836 (or rng-validate-mode (rng-validate-mode)) | |
837 (setq arg (prefix-numeric-value arg)) | |
838 (if (< arg 0) | |
839 (rng-previous-error-1 (- arg)) | |
840 (rng-next-error-1 arg)))) | |
841 | |
842 (defun rng-previous-error (arg) | |
843 "Go to the previous validation error before point. | |
844 Turn on `rng-validate-mode' if it is not already on. | |
96496
e374c747704b
Fix typos, and general docstring cleanup.
Juanma Barranquero <lekktu@gmail.com>
parents:
96361
diff
changeset
|
845 A prefix ARG specifies how many errors to move. |
e374c747704b
Fix typos, and general docstring cleanup.
Juanma Barranquero <lekktu@gmail.com>
parents:
96361
diff
changeset
|
846 A negative ARG moves forwards. Just \\[universal-argument] as a prefix |
86361 | 847 means goto the first error." |
848 (interactive "P") | |
849 (if (consp arg) | |
850 (rng-first-error) | |
851 (or rng-validate-mode (rng-validate-mode)) | |
852 (setq arg (prefix-numeric-value arg)) | |
853 (if (< arg 0) | |
854 (rng-next-error-1 (- arg)) | |
855 (rng-previous-error-1 arg)))) | |
856 | |
857 (defun rng-next-error-1 (arg) | |
858 (let* ((pos (point)) | |
859 err last-err) | |
860 (while (and (> arg 0) | |
861 (setq err (rng-find-next-error-overlay pos))) | |
862 (setq arg (1- arg)) | |
863 (setq last-err err) | |
864 (setq pos (overlay-start err))) | |
865 (when (> arg 0) | |
96496
e374c747704b
Fix typos, and general docstring cleanup.
Juanma Barranquero <lekktu@gmail.com>
parents:
96361
diff
changeset
|
866 (setq pos (max pos (1- rng-validate-up-to-date-end))) |
86361 | 867 (when (< rng-validate-up-to-date-end (point-max)) |
868 (message "Parsing...") | |
869 (while (let ((more-to-do (rng-do-some-validation))) | |
870 (while (and (> arg 0) | |
871 (setq err (rng-find-next-error-overlay pos))) | |
872 (setq arg (1- arg)) | |
873 (setq last-err err) | |
874 (setq pos (overlay-start err))) | |
875 (when (and (> arg 0) | |
876 more-to-do | |
877 (< rng-validate-up-to-date-end (point-max))) | |
878 ;; Display percentage validated. | |
879 (force-mode-line-update) | |
880 ;; Force redisplay but don't allow idle timers to run. | |
881 (let ((timer-idle-list nil)) | |
882 (sit-for 0)) | |
883 (setq pos | |
884 (max pos (1- rng-validate-up-to-date-end))) | |
885 t))))) | |
886 (if last-err | |
887 (rng-goto-error-overlay last-err) | |
888 (message "No more errors") | |
889 nil))) | |
890 | |
891 (defun rng-previous-error-1 (arg) | |
892 (let* ((pos (point)) | |
893 err last-err) | |
894 (while (and (> arg 0) | |
895 (setq err (rng-find-previous-error-overlay pos))) | |
896 (setq pos (overlay-start err)) | |
897 (setq last-err err) | |
898 (setq arg (1- arg))) | |
899 (when (and (> arg 0) | |
900 (< rng-validate-up-to-date-end (min pos (point-max)))) | |
901 (message "Parsing...") | |
902 (while (and (rng-do-some-validation) | |
903 (< rng-validate-up-to-date-end (min pos (point-max)))) | |
904 (force-mode-line-update) | |
905 ;; Force redisplay but don't allow idle timers to run. | |
906 (let ((timer-idle-list nil)) | |
907 (sit-for 0))) | |
908 (while (and (> arg 0) | |
909 (setq err (rng-find-previous-error-overlay pos))) | |
910 (setq pos (overlay-start err)) | |
911 (setq last-err err) | |
912 (setq arg (1- arg)))) | |
913 (if last-err | |
914 (rng-goto-error-overlay last-err) | |
915 (message "No previous errors") | |
916 nil))) | |
96496
e374c747704b
Fix typos, and general docstring cleanup.
Juanma Barranquero <lekktu@gmail.com>
parents:
96361
diff
changeset
|
917 |
86361 | 918 (defun rng-goto-error-overlay (err) |
919 "Goto the start of error overlay ERR and print its message." | |
920 (goto-char (overlay-start err)) | |
921 (setq rng-message-overlay-inhibit-point nil) | |
922 (rng-error-overlay-message err)) | |
923 | |
924 (defun rng-error-overlay-message (err) | |
925 (if err | |
926 (unless (or (and (eq rng-message-overlay-inhibit-point (point)) | |
927 (eq rng-message-overlay err)) | |
928 (= (point-max) 1)) | |
929 (message "%s" (overlay-get err 'help-echo)) | |
930 (setq rng-message-overlay-current t) | |
931 (setq rng-message-overlay-inhibit-point (point))) | |
932 (when (rng-current-message-from-error-overlay-p) | |
933 (message nil)) | |
934 (setq rng-message-overlay-inhibit-point nil)) | |
935 (setq rng-message-overlay err)) | |
936 | |
937 (defun rng-current-message-from-error-overlay-p () | |
938 (and rng-message-overlay-current | |
939 rng-message-overlay | |
940 (equal (overlay-get rng-message-overlay 'help-echo) | |
941 (current-message)))) | |
942 | |
943 (defun rng-find-next-error-overlay (pos) | |
944 "Return the overlay for the next error starting after POS. | |
945 Return nil if there is no such overlay or it is out of date. | |
946 Do not do any additional validation." | |
947 (when rng-error-count | |
948 (let (done found overlays) | |
949 (while (not done) | |
950 (cond (overlays | |
951 (let ((overlay (car overlays))) | |
952 (setq overlays (cdr overlays)) | |
953 (when (and (eq (overlay-get overlay 'category) 'rng-error) | |
954 ;; Is it the first? | |
955 (= (overlay-start overlay) pos) | |
956 ;; Is it up to date? | |
957 (<= (overlay-end overlay) | |
958 rng-validate-up-to-date-end)) | |
959 (setq done t) | |
960 (setq found overlay)))) | |
961 ((or (= pos (point-max)) | |
962 (> (setq pos (next-overlay-change pos)) | |
963 rng-validate-up-to-date-end)) | |
964 (setq done t)) | |
965 (t (setq overlays (overlays-in pos (1+ pos)))))) | |
966 found))) | |
967 | |
968 (defun rng-find-previous-error-overlay (pos) | |
969 "Return the overlay for the last error starting before POS. | |
970 Return nil if there is no such overlay or it is out of date. | |
971 Do not do any additional validation." | |
972 (when (and rng-error-count | |
973 (<= pos rng-validate-up-to-date-end)) | |
974 (let (done found overlays) | |
975 (while (not done) | |
976 (cond (overlays | |
977 (let ((overlay (car overlays))) | |
978 (setq overlays (cdr overlays)) | |
979 (when (and (eq (overlay-get overlay 'category) 'rng-error) | |
980 ;; Is it the first? | |
981 (= (overlay-start overlay) pos)) | |
982 (setq done t) | |
983 (setq found overlay)))) | |
984 ((= pos (point-min)) | |
985 (setq done t)) | |
986 (t | |
987 (setq pos (previous-overlay-change pos)) | |
988 (setq overlays (overlays-in pos (1+ pos)))))) | |
989 found))) | |
990 | |
991 ;;; Parsing | |
992 | |
993 (defun rng-forward (&optional limit) | |
994 "Move forward over one or more tokens updating the state. | |
995 If LIMIT is nil, stop after tags. | |
996 If LIMIT is non-nil, stop when end of last token parsed is >= LIMIT. | |
997 Return nil at end of buffer, t otherwise." | |
998 (let (type) | |
999 (while (progn | |
1000 (setq type (xmltok-forward)) | |
1001 (rng-clear-overlays xmltok-start (point)) | |
1002 (let ((continue | |
1003 (cond ((eq type 'start-tag) | |
1004 (rng-process-start-tag 'start-tag) | |
1005 nil) | |
1006 ((eq type 'end-tag) | |
1007 (rng-process-end-tag) | |
1008 nil) | |
1009 ((eq type 'empty-element) | |
1010 (rng-process-start-tag 'empty-element) | |
1011 nil) | |
1012 ((eq type 'space) | |
1013 (rng-process-text xmltok-start nil t) | |
1014 t) | |
1015 ((eq type 'data) | |
1016 (rng-process-text xmltok-start nil nil) | |
1017 t) | |
1018 ((memq type '(entity-ref char-ref)) | |
1019 (cond (xmltok-replacement | |
1020 (rng-process-text xmltok-start | |
1021 nil | |
1022 'maybe | |
1023 xmltok-replacement)) | |
1024 ((eq type 'char-ref) | |
1025 (rng-process-unknown-char)) | |
1026 (t | |
1027 (rng-process-unknown-entity))) | |
1028 t) | |
1029 ((eq type 'cdata-section) | |
1030 (rng-process-text (+ xmltok-start 9) ; "<![CDATA[" | |
1031 (- (point) 3) ; "]]>" | |
1032 'maybe) | |
1033 t) | |
1034 ((eq type 'partial-start-tag) | |
1035 (rng-process-start-tag 'partial-start-tag) | |
1036 t) | |
1037 ((eq type 'partial-empty-element) | |
1038 (rng-process-start-tag 'empty-element) | |
1039 t) | |
1040 ((eq type 'partial-end-tag) | |
1041 (rng-process-end-tag 'partial) | |
1042 t) | |
1043 (t type)))) | |
1044 (if limit | |
1045 (< (point) limit) | |
1046 continue)))) | |
1047 (and type t))) | |
1048 | |
1049 (defun rng-process-start-tag (tag-type) | |
1050 "TAG-TYPE is `start-tag' for a start-tag, `empty-element' for | |
96496
e374c747704b
Fix typos, and general docstring cleanup.
Juanma Barranquero <lekktu@gmail.com>
parents:
96361
diff
changeset
|
1051 an empty element. `partial-empty-element' should be passed |
86361 | 1052 as empty-element." |
1053 (and rng-collecting-text (rng-flush-text)) | |
1054 (setq rng-collecting-text nil) | |
1055 (setq rng-pending-contents nil) | |
1056 (rng-process-namespaces) | |
1057 (let ((tag (rng-process-tag-name))) | |
1058 (rng-process-attributes) | |
1059 ;; set the state appropriately | |
1060 (cond ((eq tag-type 'empty-element) | |
1061 (rng-process-start-tag-close) | |
1062 ;; deal with missing content with empty element | |
1063 (when (not (rng-match-empty-content)) | |
1064 (rng-match-after) | |
1065 (rng-mark-start-tag-close "Empty content not allowed")) | |
1066 (nxml-ns-pop-state)) | |
1067 ((eq tag-type 'start-tag) | |
1068 (rng-process-start-tag-close) | |
1069 (setq rng-collecting-text (rng-match-text-typed-p)) | |
1070 (rng-push-tag tag)) | |
1071 ((eq tag-type 'partial-start-tag) | |
1072 (rng-process-start-tag-close) | |
1073 (rng-match-after) | |
1074 (nxml-ns-pop-state))))) | |
1075 | |
1076 (defun rng-process-namespaces () | |
1077 (let ((nsatts xmltok-namespace-attributes) | |
1078 prefixes) | |
1079 (nxml-ns-push-state) | |
1080 (while nsatts | |
1081 (let* ((att (car nsatts)) | |
1082 (value (xmltok-attribute-value att))) | |
1083 (when value | |
1084 (let ((ns (nxml-make-namespace value)) | |
1085 (prefix (and (xmltok-attribute-prefix att) | |
1086 (xmltok-attribute-local-name att)))) | |
1087 (cond ((member prefix prefixes) | |
1088 (rng-mark-invalid "Duplicate namespace declaration" | |
1089 (xmltok-attribute-name-start att) | |
1090 (xmltok-attribute-name-end att))) | |
1091 ((not prefix) | |
1092 (nxml-ns-set-default ns)) | |
1093 (ns | |
1094 (nxml-ns-set-prefix prefix ns)) | |
1095 (t | |
1096 ;; cannot have xmlns:foo="" | |
1097 (rng-mark-invalid "Namespace prefix cannot be undeclared" | |
1098 (1- (xmltok-attribute-value-start att)) | |
1099 (1+ (xmltok-attribute-value-end att))))) | |
1100 (setq prefixes (cons prefix prefixes))))) | |
1101 (setq nsatts (cdr nsatts))))) | |
1102 | |
1103 (defun rng-process-tag-name () | |
1104 (let* ((prefix (xmltok-start-tag-prefix)) | |
1105 (local-name (xmltok-start-tag-local-name)) | |
1106 (name | |
1107 (if prefix | |
1108 (let ((ns (nxml-ns-get-prefix prefix))) | |
1109 (cond (ns (cons ns local-name)) | |
1110 ((and (setq ns | |
1111 (rng-match-infer-start-tag-namespace | |
1112 local-name)) | |
1113 (rng-match-start-tag-open (cons ns local-name))) | |
1114 (nxml-ns-set-prefix prefix ns) | |
1115 (rng-mark-start-tag-close "Missing xmlns:%s=\"%s\"" | |
1116 prefix | |
1117 (nxml-namespace-name ns)) | |
1118 nil) | |
1119 (t | |
1120 (rng-recover-bad-element-prefix) | |
1121 nil))) | |
1122 (cons (nxml-ns-get-default) local-name)))) | |
1123 (when (and name | |
1124 (not (rng-match-start-tag-open name))) | |
1125 (unless (and (not (car name)) | |
1126 (let ((ns (rng-match-infer-start-tag-namespace (cdr name)))) | |
1127 (and ns | |
1128 (rng-match-start-tag-open (cons ns local-name)) | |
1129 (progn | |
1130 (nxml-ns-set-default ns) | |
1131 ;; XXX need to check we don't have xmlns="" | |
1132 (rng-mark-start-tag-close "Missing xmlns=\"%s\"" | |
1133 (nxml-namespace-name ns)) | |
1134 t)))) | |
1135 (rng-recover-start-tag-open name))) | |
1136 (cons prefix local-name))) | |
1137 | |
1138 (defun rng-process-attributes () | |
1139 (let ((atts xmltok-attributes) | |
1140 names) | |
1141 (while atts | |
1142 (let* ((att (car atts)) | |
1143 (prefix (xmltok-attribute-prefix att)) | |
1144 (local-name (xmltok-attribute-local-name att)) | |
1145 (name | |
1146 (if prefix | |
1147 (let ((ns (nxml-ns-get-prefix prefix))) | |
1148 (and ns | |
1149 (cons ns local-name))) | |
1150 (cons nil local-name)))) | |
1151 (cond ((not name) | |
1152 (rng-recover-bad-attribute-prefix att)) | |
1153 ((member name names) | |
1154 (rng-recover-duplicate-attribute-name att)) | |
1155 ((not (rng-match-attribute-name name)) | |
1156 (rng-recover-attribute-name att)) | |
1157 ((rng-match-text-typed-p) | |
1158 (let ((value (xmltok-attribute-value att))) | |
1159 (if value | |
1160 (or (rng-match-attribute-value value) | |
1161 (rng-recover-attribute-value att)) | |
1162 (rng-match-after)))) | |
1163 (t (or (rng-match-end-tag) | |
1164 (error "Internal error:\ | |
1165 invalid on untyped attribute value")))) | |
1166 (setq names (cons name names))) | |
1167 (setq atts (cdr atts))))) | |
1168 | |
1169 (defun rng-process-start-tag-close () | |
1170 ;; deal with missing attributes | |
1171 (unless (rng-match-start-tag-close) | |
1172 (rng-mark-start-tag-close (rng-missing-attributes-message)) | |
1173 (rng-match-ignore-attributes))) | |
1174 | |
1175 (defun rng-mark-start-tag-close (&rest args) | |
1176 (when (not (eq xmltok-type 'partial-start-tag)) | |
1177 (rng-mark-invalid (apply 'format args) | |
1178 (- (point) | |
1179 (if (eq xmltok-type 'empty-element) | |
1180 2 | |
1181 1)) | |
1182 (point)))) | |
1183 | |
1184 (defun rng-recover-bad-element-prefix () | |
1185 (rng-mark-invalid "Prefix not declared" | |
1186 (1+ xmltok-start) | |
1187 xmltok-name-colon) | |
1188 (rng-match-unknown-start-tag-open)) | |
1189 | |
1190 (defun rng-recover-bad-attribute-prefix (att) | |
1191 (rng-mark-invalid "Prefix not declared" | |
1192 (xmltok-attribute-name-start att) | |
1193 (xmltok-attribute-name-colon att))) | |
1194 | |
1195 (defun rng-recover-duplicate-attribute-name (att) | |
1196 (rng-mark-invalid "Duplicate attribute" | |
1197 (xmltok-attribute-name-start att) | |
1198 (xmltok-attribute-name-end att))) | |
1199 | |
1200 (defun rng-recover-start-tag-open (name) | |
1201 (let ((required (rng-match-required-element-name))) | |
1202 (cond ((and required | |
1203 (rng-match-start-tag-open required) | |
1204 (rng-match-after) | |
1205 (rng-match-start-tag-open name)) | |
1206 (rng-mark-invalid (concat "Missing element " | |
1207 (rng-quote-string | |
1208 (rng-name-to-string required))) | |
1209 xmltok-start | |
1210 (1+ xmltok-start))) | |
1211 ((and (rng-match-optionalize-elements) | |
1212 (rng-match-start-tag-open name)) | |
1213 (rng-mark-invalid "Required elements missing" | |
1214 xmltok-start | |
1215 (1+ xmltok-start))) | |
1216 ((rng-match-out-of-context-start-tag-open name) | |
1217 (rng-mark-invalid "Element not allowed in this context" | |
1218 (1+ xmltok-start) | |
1219 xmltok-name-end)) | |
1220 (t | |
1221 (rng-match-unknown-start-tag-open) | |
1222 (rng-mark-invalid "Unknown element" | |
1223 (1+ xmltok-start) | |
1224 xmltok-name-end))))) | |
1225 | |
1226 (defun rng-recover-attribute-value (att) | |
1227 (let ((start (xmltok-attribute-value-start att)) | |
1228 (end (xmltok-attribute-value-end att))) | |
1229 (if (= start end) | |
1230 (rng-mark-invalid "Empty attribute value invalid" start (1+ end)) | |
1231 (rng-mark-invalid "Attribute value invalid" start end))) | |
1232 (rng-match-after)) | |
1233 | |
1234 (defun rng-recover-attribute-name (att) | |
1235 (rng-mark-invalid "Attribute not allowed" | |
1236 (xmltok-attribute-name-start att) | |
1237 (xmltok-attribute-name-end att))) | |
1238 | |
1239 (defun rng-missing-attributes-message () | |
1240 (let ((required-attributes | |
1241 (rng-match-required-attribute-names))) | |
1242 (cond ((not required-attributes) | |
1243 "Required attributes missing") | |
1244 ((not (cdr required-attributes)) | |
1245 (concat "Missing attribute " | |
1246 (rng-quote-string | |
1247 (rng-name-to-string (car required-attributes) t)))) | |
1248 (t | |
1249 (concat "Missing attributes " | |
1250 (mapconcat (lambda (nm) | |
1251 (rng-quote-string | |
1252 (rng-name-to-string nm t))) | |
1253 required-attributes | |
1254 ", ")))))) | |
96496
e374c747704b
Fix typos, and general docstring cleanup.
Juanma Barranquero <lekktu@gmail.com>
parents:
96361
diff
changeset
|
1255 |
86361 | 1256 (defun rng-process-end-tag (&optional partial) |
1257 (cond ((not rng-open-elements) | |
1258 (rng-mark-not-well-formed "Extra end-tag" | |
1259 xmltok-start | |
1260 (point))) | |
1261 ((or partial | |
1262 (equal (cons (xmltok-end-tag-prefix) | |
1263 (xmltok-end-tag-local-name)) | |
1264 (car rng-open-elements))) | |
1265 (rng-end-element)) | |
1266 (t (rng-recover-mismatched-end-tag)))) | |
1267 | |
1268 (defun rng-end-element () | |
1269 (if rng-collecting-text | |
1270 (let ((contents (rng-contents-string))) | |
1271 (cond ((not contents) (rng-match-after)) | |
1272 ((not (rng-match-element-value contents)) | |
1273 (let* ((region (rng-contents-region))) | |
1274 (if (not region) | |
1275 (rng-mark-invalid "Empty content not allowed" | |
1276 xmltok-start | |
1277 (+ xmltok-start 2)) | |
1278 (rng-mark-invalid "Invalid data" | |
1279 (car region) | |
1280 (cdr region)))) | |
1281 (rng-match-after))) | |
1282 (setq rng-collecting-text nil) | |
1283 (setq rng-pending-contents nil)) | |
1284 (unless (rng-match-end-tag) | |
1285 (rng-mark-invalid (rng-missing-element-message) | |
1286 xmltok-start | |
1287 (+ xmltok-start 2)) | |
1288 (rng-match-after))) | |
1289 (nxml-ns-pop-state) | |
1290 (when (eq (car rng-open-elements) t) | |
1291 (rng-pop-tag)) | |
1292 (rng-pop-tag)) | |
1293 | |
1294 (defun rng-missing-element-message () | |
1295 (let ((element (rng-match-required-element-name))) | |
1296 (if element | |
1297 (concat "Missing element " | |
1298 (rng-quote-string (rng-name-to-string element))) | |
1299 "Required child elements missing"))) | |
1300 | |
1301 (defun rng-recover-mismatched-end-tag () | |
1302 (let* ((name (cons (xmltok-end-tag-prefix) | |
1303 (xmltok-end-tag-local-name)))) | |
1304 (cond ((member name (cdr rng-open-elements)) | |
1305 (let* ((suppress-error (eq (car rng-open-elements) t)) | |
1306 missing top) | |
1307 (while (progn | |
1308 (setq top (car rng-open-elements)) | |
1309 (rng-pop-tag) | |
1310 (unless (eq top t) | |
1311 (setq missing (cons top missing)) | |
1312 (nxml-ns-pop-state) | |
1313 (rng-match-after)) | |
1314 (not (equal top name)))) | |
1315 (unless suppress-error | |
1316 (rng-mark-missing-end-tags (cdr missing))))) | |
1317 ((rng-match-empty-before-p) | |
1318 (rng-mark-mismatched-end-tag) | |
1319 (rng-end-element)) | |
1320 (t (rng-mark-mismatched-end-tag) | |
1321 (setq rng-open-elements | |
1322 (cons t rng-open-elements)))))) | |
1323 | |
1324 (defun rng-mark-missing-end-tags (missing) | |
1325 (rng-mark-not-well-formed | |
1326 (format "Missing end-tag%s %s" | |
1327 (if (null (cdr missing)) "" "s") | |
1328 (mapconcat (lambda (name) | |
1329 (rng-quote-string | |
1330 (if (car name) | |
1331 (concat (car name) | |
1332 ":" | |
1333 (cdr name)) | |
1334 (cdr name)))) | |
1335 missing | |
1336 ", ")) | |
1337 xmltok-start | |
1338 (+ xmltok-start 2))) | |
1339 | |
1340 (defun rng-mark-mismatched-end-tag () | |
1341 (rng-mark-not-well-formed "Mismatched end-tag" | |
1342 (+ xmltok-start 2) | |
1343 xmltok-name-end)) | |
1344 | |
1345 (defun rng-push-tag (prefix-local-name) | |
1346 (setq rng-open-elements | |
1347 (cons prefix-local-name rng-open-elements))) | |
1348 | |
1349 (defun rng-pop-tag () | |
1350 (setq rng-open-elements (cdr rng-open-elements))) | |
1351 | |
1352 (defun rng-contents-string () | |
1353 (let ((contents rng-pending-contents)) | |
1354 (cond ((not contents) "") | |
1355 ((memq nil contents) nil) | |
1356 ((not (cdr contents)) | |
1357 (rng-segment-string (car contents))) | |
1358 (t (apply 'concat | |
1359 (nreverse (mapcar 'rng-segment-string | |
1360 contents))))))) | |
1361 | |
1362 (defun rng-segment-string (segment) | |
1363 (or (car segment) | |
1364 (apply 'buffer-substring-no-properties | |
1365 (cdr segment)))) | |
1366 | |
1367 (defun rng-segment-blank-p (segment) | |
1368 (if (car segment) | |
1369 (rng-blank-p (car segment)) | |
1370 (apply 'rng-region-blank-p | |
1371 (cdr segment)))) | |
1372 | |
1373 (defun rng-contents-region () | |
1374 (if (null rng-pending-contents) | |
1375 nil | |
1376 (let* ((contents rng-pending-contents) | |
1377 (head (cdar contents)) | |
1378 (start (car head)) | |
1379 (end (cadr head))) | |
1380 (while (setq contents (cdr contents)) | |
1381 (setq start (car (cdar contents)))) | |
1382 (cons start end)))) | |
1383 | |
1384 (defun rng-process-text (start end whitespace &optional value) | |
1385 "Process characters between position START and END as text. | |
96496
e374c747704b
Fix typos, and general docstring cleanup.
Juanma Barranquero <lekktu@gmail.com>
parents:
96361
diff
changeset
|
1386 END nil means point. WHITESPACE t means known to be whitespace, nil |
86361 | 1387 means known not to be, anything else means unknown whether whitespace |
96496
e374c747704b
Fix typos, and general docstring cleanup.
Juanma Barranquero <lekktu@gmail.com>
parents:
96361
diff
changeset
|
1388 or not. END must not be nil if WHITESPACE is neither t nor nil. |
86361 | 1389 VALUE is a string or nil; nil means the value is equal to the |
1390 string between START and END." | |
1391 (cond (rng-collecting-text | |
1392 (setq rng-pending-contents (cons (list value start (or end (point))) | |
1393 rng-pending-contents))) | |
1394 ((not (or (and whitespace | |
1395 (or (eq whitespace t) | |
1396 (if value | |
1397 (rng-blank-p value) | |
1398 (rng-region-blank-p start end)))) | |
1399 (rng-match-mixed-text))) | |
1400 (rng-mark-invalid "Text not allowed" start (or end (point)))))) | |
1401 | |
1402 (defun rng-process-unknown-char () | |
1403 (when rng-collecting-text | |
1404 (setq rng-pending-contents | |
1405 (cons nil rng-pending-contents)))) | |
1406 | |
1407 (defun rng-process-unknown-entity () | |
1408 (rng-process-unknown-char) | |
1409 (rng-match-optionalize-elements)) | |
1410 | |
1411 (defun rng-region-blank-p (beg end) | |
1412 (save-excursion | |
1413 (goto-char beg) | |
1414 (= (skip-chars-forward " \n\r\t" end) | |
1415 (- end beg)))) | |
1416 | |
1417 (defun rng-flush-text () | |
1418 (while rng-pending-contents | |
1419 (let ((segment (car rng-pending-contents))) | |
1420 (unless (or (rng-segment-blank-p segment) | |
1421 (rng-match-mixed-text)) | |
1422 (let ((region (cdr segment))) | |
1423 (rng-mark-invalid "In this context text cannot be mixed with elements" | |
1424 (car region) | |
1425 (cadr region))))) | |
1426 (setq rng-pending-contents (cdr rng-pending-contents)))) | |
1427 | |
1428 (defun rng-process-end-document () | |
1429 ;; this is necessary to clear empty overlays at (point-max) | |
1430 (rng-clear-overlays (point) (point)) | |
1431 (let ((start (save-excursion | |
1432 (skip-chars-backward " \t\r\n") | |
1433 (point)))) | |
1434 (cond (rng-open-elements | |
1435 (unless (eq (car rng-open-elements) t) | |
1436 (rng-mark-not-well-formed "Missing end-tag" | |
1437 start | |
1438 (point)))) | |
1439 ((not (rng-match-nullable-p)) | |
1440 (rng-mark-not-well-formed "No document element" | |
1441 start | |
1442 (point)))))) | |
1443 | |
1444 (defun rng-process-encoding-name (beg end) | |
1445 (unless (let ((charset (buffer-substring-no-properties beg end))) | |
1446 (or (nxml-mime-charset-coding-system charset) | |
1447 (string= (downcase charset) "utf-16"))) | |
1448 (rng-mark-not-well-formed "Unsupported encoding" beg end))) | |
1449 | |
1450 (defun rng-name-to-string (name &optional attributep) | |
1451 (let ((ns (car name)) | |
1452 (local-name (cdr name))) | |
1453 (if (or (not ns) | |
1454 (and (not attributep) | |
1455 (eq (nxml-ns-get-default) ns))) | |
1456 local-name | |
1457 (let ((prefix (nxml-ns-prefix-for ns))) | |
1458 (if prefix | |
1459 (concat prefix ":" local-name) | |
1460 (concat "{" (symbol-name ns) "}" local-name)))))) | |
1461 | |
1462 (provide 'rng-valid) | |
1463 | |
86379 | 1464 ;; arch-tag: 7dd846d3-519d-4a6d-8107-4ff0024a60ef |
86361 | 1465 ;;; rng-valid.el ends here |