|
0
|
1 ;;; psgml-edit.el --- Editing commands for SGML-mode with parsing support
|
|
2
|
2 ;;-*-byte-compile-warnings:(free-vars unused-vars unresolved callargs redefine)-*-
|
|
108
|
3 ;; $Id: psgml-edit.el,v 1.2 1997/03/08 23:26:53 steve Exp $
|
|
0
|
4
|
|
|
5 ;; Copyright (C) 1994, 1995, 1996 Lennart Staflin
|
|
|
6
|
|
|
7 ;; Author: Lennart Staflin <lenst@lysator.liu.se>
|
|
|
8
|
|
|
9 ;; This program is free software; you can redistribute it and/or
|
|
|
10 ;; modify it under the terms of the GNU General Public License
|
|
|
11 ;; as published by the Free Software Foundation; either version 2
|
|
|
12 ;; of the License, or (at your option) any later version.
|
|
|
13 ;;
|
|
|
14 ;; This program is distributed in the hope that it will be useful,
|
|
|
15 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
|
|
|
16 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
|
|
|
17 ;; GNU General Public License for more details.
|
|
|
18 ;;
|
|
|
19 ;; You should have received a copy of the GNU General Public License
|
|
|
20 ;; along with this program; if not, write to the Free Software
|
|
|
21 ;; Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
|
|
|
22
|
|
|
23
|
|
|
24 ;;;; Commentary:
|
|
|
25
|
|
|
26 ;; Part of major mode for editing the SGML document-markup language.
|
|
|
27
|
|
|
28
|
|
|
29 ;;;; Code:
|
|
|
30
|
|
|
31 (provide 'psgml-edit)
|
|
|
32 (require 'psgml)
|
|
|
33 (require 'psgml-parse)
|
|
2
|
34 (require 'tempo)
|
|
0
|
35
|
|
|
36
|
|
|
37 ;;;; Variables
|
|
|
38
|
|
|
39 (defvar sgml-split-level nil
|
|
|
40 "Used by sgml-split-element")
|
|
|
41
|
|
|
42
|
|
|
43 ;;;; SGML mode: structure editing
|
|
|
44
|
|
|
45 (defun sgml-last-element ()
|
|
|
46 "Return the element where last command left point.
|
|
|
47 This either uses the save value in `sgml-last-element' or parses the buffer
|
|
|
48 to find current open element."
|
|
|
49 (setq sgml-markup-type nil)
|
|
|
50 (if (and (memq last-command sgml-users-of-last-element)
|
|
|
51 sgml-last-element) ; Don't return nil
|
|
|
52 sgml-last-element
|
|
|
53 (setq sgml-last-element (sgml-find-context-of (point)))) )
|
|
|
54
|
|
|
55 (defun sgml-set-last-element (&optional el)
|
|
|
56 (if el (setq sgml-last-element el))
|
|
|
57 (sgml-show-context sgml-last-element))
|
|
|
58
|
|
|
59 (defun sgml-beginning-of-element ()
|
|
|
60 "Move to after the start-tag of the current element.
|
|
|
61 If the start-tag is implied, move to the start of the element."
|
|
|
62 (interactive)
|
|
|
63 (goto-char (sgml-element-stag-end (sgml-last-element)))
|
|
|
64 (sgml-set-last-element (if (sgml-element-empty sgml-last-element)
|
|
|
65 (sgml-element-parent sgml-last-element))))
|
|
|
66
|
|
|
67 (defun sgml-end-of-element ()
|
|
|
68 "Move to before the end-tag of the current element."
|
|
|
69 (interactive)
|
|
|
70 (goto-char (sgml-element-etag-start (sgml-last-element)))
|
|
|
71 (sgml-set-last-element (if (sgml-element-empty sgml-last-element)
|
|
|
72 (sgml-element-parent sgml-last-element))))
|
|
|
73
|
|
|
74 (defun sgml-backward-up-element ()
|
|
|
75 "Move backward out of this element level.
|
|
|
76 That is move to before the start-tag or where a start-tag is implied."
|
|
|
77 (interactive)
|
|
|
78 (goto-char (sgml-element-start (sgml-last-element)))
|
|
|
79 (sgml-set-last-element (sgml-element-parent sgml-last-element)))
|
|
|
80
|
|
|
81 (defun sgml-up-element ()
|
|
|
82 "Move forward out of this element level.
|
|
|
83 That is move to after the end-tag or where an end-tag is implied."
|
|
|
84 (interactive)
|
|
|
85 (goto-char (sgml-element-end (sgml-last-element)))
|
|
|
86 (sgml-set-last-element (sgml-element-parent sgml-last-element)))
|
|
|
87
|
|
|
88 (defun sgml-forward-element ()
|
|
|
89 "Move forward over next element."
|
|
|
90 (interactive)
|
|
|
91 (let ((next
|
|
|
92 (sgml-find-element-after (point) (sgml-last-element))))
|
|
|
93 (goto-char (sgml-element-end next))
|
|
|
94 (sgml-set-last-element (sgml-element-parent next))))
|
|
|
95
|
|
|
96 (defun sgml-backward-element ()
|
|
|
97 "Move backward over previous element at this level.
|
|
|
98 With implied tags this is ambigous."
|
|
|
99 (interactive)
|
|
|
100 (let ((prev ; previous element
|
|
|
101 (sgml-find-previous-element (point) (sgml-last-element))))
|
|
|
102 (goto-char (sgml-element-start prev))
|
|
|
103 (sgml-set-last-element (sgml-element-parent prev))))
|
|
|
104
|
|
|
105 (defun sgml-down-element ()
|
|
|
106 "Move forward and down one level in the element structure."
|
|
|
107 (interactive)
|
|
|
108 (let ((to
|
|
|
109 (sgml-find-element-after (point) (sgml-last-element))))
|
|
2
|
110 (when (sgml-strict-epos-p (sgml-element-stag-epos to))
|
|
|
111 (error "Sub-element in other entity"))
|
|
0
|
112 (goto-char (sgml-element-stag-end to))
|
|
|
113 (sgml-set-last-element (if (sgml-element-empty to)
|
|
|
114 (sgml-element-parent to)
|
|
|
115 to))))
|
|
|
116
|
|
|
117
|
|
|
118 (defun sgml-kill-element ()
|
|
|
119 "Kill the element following the cursor."
|
|
|
120 (interactive "*")
|
|
|
121 (sgml-parse-to-here)
|
|
|
122 (when sgml-markup-type
|
|
|
123 (error "Point is inside markup"))
|
|
|
124 (kill-region (point)
|
|
|
125 (sgml-element-end (sgml-find-element-after (point)))))
|
|
|
126
|
|
|
127 (defun sgml-transpose-element ()
|
|
|
128 "Interchange element before point with element after point, leave point after."
|
|
|
129 (interactive "*")
|
|
|
130 (let ((pre (sgml-find-previous-element (point)))
|
|
|
131 (next (sgml-find-element-after (point)))
|
|
|
132 s1 s2 m2)
|
|
|
133 (goto-char (sgml-element-start next))
|
|
|
134 (setq m2 (point-marker))
|
|
|
135 (setq s2 (buffer-substring (point)
|
|
|
136 (sgml-element-end next)))
|
|
|
137 (delete-region (point) (sgml-element-end next))
|
|
|
138 (goto-char (sgml-element-start pre))
|
|
|
139 (setq s1 (buffer-substring (point) (sgml-element-end pre)))
|
|
|
140 (delete-region (point) (sgml-element-end pre))
|
|
|
141 (insert-before-markers s2)
|
|
|
142 (goto-char m2)
|
|
|
143 (insert s1)
|
|
|
144 (sgml-message "")))
|
|
|
145
|
|
|
146 (defun sgml-mark-element ()
|
|
|
147 "Set mark after next element."
|
|
|
148 (interactive)
|
|
|
149 (push-mark (sgml-element-end (sgml-find-element-after (point))) nil t))
|
|
|
150
|
|
|
151 (defun sgml-mark-current-element ()
|
|
|
152 "Set mark at end of current element, and leave point before current element."
|
|
|
153 (interactive)
|
|
|
154 (let ((el (sgml-find-element-of (point))))
|
|
|
155 (goto-char (sgml-element-start el))
|
|
|
156 (push-mark (sgml-element-end el) nil t)))
|
|
|
157
|
|
|
158
|
|
|
159 (defun sgml-change-element-name (gi)
|
|
|
160 "Replace the name of the current element with a new name.
|
|
|
161 Eventual attributes of the current element will be translated if
|
|
|
162 possible."
|
|
|
163 (interactive
|
|
|
164 (list (let ((el (sgml-find-element-of (point))))
|
|
|
165 (goto-char (sgml-element-start el))
|
|
|
166 (sgml-read-element-name
|
|
|
167 (format "Change %s to: " (sgml-element-name el))))))
|
|
|
168 (when (or (null gi) (equal gi ""))
|
|
|
169 (error "Illegal name"))
|
|
|
170 (let* ((element (sgml-find-element-of (point)))
|
|
|
171 (attspec (sgml-element-attribute-specification-list element))
|
|
|
172 (oldattlist (sgml-element-attlist element)))
|
|
|
173 (unless (sgml-element-empty element)
|
|
|
174 (goto-char (sgml-element-end element))
|
|
|
175 (delete-char (- (sgml-element-etag-len element)))
|
|
2
|
176 (tempo-process-and-insert-string (sgml-end-tag-of gi)))
|
|
0
|
177 (goto-char (sgml-element-start element))
|
|
|
178 (delete-char (sgml-element-stag-len element))
|
|
2
|
179 (tempo-process-and-insert-string (sgml-start-tag-of gi))
|
|
0
|
180 (forward-char -1)
|
|
|
181 (let* ((newel (sgml-find-element-of (point)))
|
|
|
182 (newattlist (sgml-element-attlist newel))
|
|
|
183 (newasl (sgml-translate-attribute-specification-list
|
|
|
184 attspec oldattlist newattlist)))
|
|
|
185 (sgml-insert-attributes newasl newattlist))))
|
|
|
186
|
|
|
187 (defun sgml-translate-attribute-specification-list (values from to)
|
|
|
188 "Translate attribute specification from one element type to another.
|
|
|
189 Input attribute values in VALUES using attlist FROM is translated into
|
|
|
190 a list using attlist TO."
|
|
|
191 (let ((new-values nil)
|
|
|
192 (sgml-show-warnings t)
|
|
|
193 tem)
|
|
|
194 (loop for attspec in values
|
|
|
195 as from-decl = (sgml-lookup-attdecl (sgml-attspec-name attspec) from)
|
|
|
196 as to-decl = (sgml-lookup-attdecl (sgml-attspec-name attspec) to)
|
|
|
197 do
|
|
|
198 (cond
|
|
|
199 ;; Special case ID attribute
|
|
|
200 ((and (eq 'id (sgml-attdecl-declared-value from-decl))
|
|
|
201 (setq tem (sgml-attribute-with-declared-value to 'id)))
|
|
|
202 (push
|
|
|
203 (sgml-make-attspec (sgml-attdecl-name tem)
|
|
|
204 (sgml-attspec-attval attspec))
|
|
|
205 new-values))
|
|
|
206 ;; Use attribute with same name if compatible type
|
|
|
207 ((equal (sgml-attdecl-declared-value from-decl)
|
|
|
208 (sgml-attdecl-declared-value to-decl))
|
|
|
209 (push attspec new-values))
|
|
|
210 (to-decl
|
|
|
211 (sgml-log-warning
|
|
|
212 "Attribute %s has new declared-value"
|
|
|
213 (sgml-attspec-name attspec))
|
|
|
214 (push attspec new-values))
|
|
|
215 (t
|
|
|
216 (sgml-log-warning "Can't translate attribute %s = %s"
|
|
|
217 (sgml-attspec-name attspec)
|
|
|
218 (sgml-attspec-attval attspec)))))
|
|
|
219 new-values))
|
|
|
220
|
|
|
221 (defun sgml-untag-element ()
|
|
|
222 "Remove tags from current element."
|
|
|
223 (interactive "*")
|
|
|
224 (let ((el (sgml-find-element-of (point))))
|
|
|
225 (when (or (sgml-strict-epos-p (sgml-element-stag-epos el))
|
|
|
226 (sgml-strict-epos-p (sgml-element-etag-epos el)))
|
|
|
227 (error "Current element has some tag inside an entity reference"))
|
|
|
228 (goto-char (sgml-element-etag-start el))
|
|
|
229 (delete-char (sgml-element-etag-len el))
|
|
|
230 (goto-char (sgml-element-start el))
|
|
|
231 (delete-char (sgml-element-stag-len el))))
|
|
|
232
|
|
|
233 (defun sgml-kill-markup ()
|
|
|
234 "Kill next tag, markup declaration or process instruction."
|
|
|
235 (interactive "*")
|
|
|
236 (let ((start (point)))
|
|
|
237 (sgml-with-parser-syntax
|
|
|
238 (sgml-parse-s)
|
|
|
239 (setq sgml-markup-start (point))
|
|
|
240 (cond ((sgml-parse-markup-declaration 'ignore))
|
|
|
241 ((sgml-parse-processing-instruction))
|
|
|
242 ((sgml-skip-tag)))
|
|
|
243 (kill-region start (point)))))
|
|
|
244
|
|
|
245
|
|
|
246 ;;;; SGML mode: folding
|
|
|
247
|
|
|
248 (defun sgml-fold-region (beg end &optional unhide)
|
|
|
249 "Hide (or if prefixarg unhide) region.
|
|
|
250 If called from a program first two arguments are start and end of
|
|
|
251 region. And optional third argument true unhides."
|
|
|
252 (interactive "r\nP")
|
|
|
253 (let ((mp (buffer-modified-p))
|
|
|
254 (inhibit-read-only t) ;
|
|
|
255 (buffer-read-only nil) ; should not need this, but
|
|
|
256 ; perhaps some old version of
|
|
|
257 ; emacs does not understand
|
|
|
258 ; inhibit-read-only
|
|
|
259 (before-change-function nil)
|
|
|
260 (after-change-function nil))
|
|
|
261 (setq selective-display t)
|
|
|
262 (unwind-protect
|
|
|
263 (subst-char-in-region beg end
|
|
|
264 (if unhide ?\r ?\n)
|
|
|
265 (if unhide ?\n ?\r)
|
|
|
266 'noundo)
|
|
|
267 (when sgml-buggy-subst-char-in-region
|
|
|
268 (set-buffer-modified-p mp)))))
|
|
|
269
|
|
|
270 (defun sgml-fold-element ()
|
|
|
271 "Fold the lines comprising the current element, leaving the first line visible.
|
|
|
272 This uses the selective display feature."
|
|
|
273 (interactive)
|
|
|
274 (sgml-parse-to-here)
|
|
|
275 (cond ((and (eq sgml-current-tree sgml-top-tree) ; outside document element
|
|
|
276 sgml-markup-type)
|
|
|
277 (sgml-fold-region sgml-markup-start
|
|
|
278 (save-excursion
|
|
|
279 (sgml-parse-to (point))
|
|
|
280 (point))))
|
|
|
281 ((and (eq sgml-current-tree sgml-top-tree) ; outside document element
|
|
|
282 (looking-at " *<!"))
|
|
|
283 (sgml-fold-region (point)
|
|
|
284 (save-excursion
|
|
|
285 (skip-chars-forward " \t")
|
|
|
286 (sgml-parse-to (1+ (point)))
|
|
|
287 (point))))
|
|
|
288
|
|
|
289 (t
|
|
|
290 (let ((el (sgml-find-element-of (point))))
|
|
|
291 (when (eq el sgml-top-tree)
|
|
|
292 (error "No element here"))
|
|
|
293 (save-excursion
|
|
|
294 (goto-char (sgml-element-end el))
|
|
|
295 (when (zerop (sgml-element-etag-len el))
|
|
|
296 (skip-chars-backward " \t\n"))
|
|
|
297 (sgml-fold-region (sgml-element-start el)
|
|
|
298 (point)))))))
|
|
|
299
|
|
|
300 (defun sgml-fold-subelement ()
|
|
|
301 "Fold all elements current elements content, leaving the first lines visible.
|
|
|
302 This uses the selective display feature."
|
|
|
303 (interactive)
|
|
|
304 (let* ((el (sgml-find-element-of (point)))
|
|
|
305 (c (sgml-element-content el)))
|
|
|
306 (while c
|
|
|
307 (sgml-fold-region (sgml-element-start c)
|
|
|
308 (sgml-element-end c))
|
|
|
309 (setq c (sgml-element-next c)))))
|
|
|
310
|
|
|
311 (defun sgml-unfold-line ()
|
|
|
312 "Show hidden lines in current line."
|
|
|
313 (interactive)
|
|
|
314 (let ((op (point)))
|
|
|
315 (beginning-of-line)
|
|
|
316 (push-mark)
|
|
|
317 (end-of-line)
|
|
|
318 (exchange-point-and-mark)
|
|
|
319 (sgml-fold-region (point) (mark) 'unhide)
|
|
|
320 (goto-char op)))
|
|
|
321
|
|
|
322 (defun sgml-unfold-element ()
|
|
|
323 "Show all hidden lines in current element."
|
|
|
324 (interactive)
|
|
|
325 (let* ((element (sgml-find-element-of (point))))
|
|
|
326 (sgml-fold-region (sgml-element-start element)
|
|
|
327 (sgml-element-end element)
|
|
|
328 'unfold)))
|
|
|
329
|
|
|
330 (defun sgml-expand-element ()
|
|
|
331 "As sgml-fold-subelement, but unfold first."
|
|
|
332 (interactive)
|
|
|
333 (sgml-unfold-element)
|
|
|
334 (sgml-fold-subelement))
|
|
|
335
|
|
|
336 (defun sgml-unfold-all ()
|
|
|
337 "Show all hidden lines in buffer."
|
|
|
338 (interactive)
|
|
|
339 (sgml-fold-region (point-min)
|
|
|
340 (point-max)
|
|
|
341 'unfold))
|
|
|
342
|
|
|
343 ;;;; SGML mode: indentation and movement
|
|
|
344
|
|
|
345 (defun sgml-indent-line (&optional col element)
|
|
|
346 "Indent line, calling parser to determine level unless COL or ELEMENT
|
|
|
347 is given. If COL is given it should be the column to indent to. If
|
|
|
348 ELEMENT is given it should be a parse tree node, from which the level
|
|
|
349 is determined."
|
|
|
350 (when sgml-indent-step
|
|
|
351 (let ((here (point-marker)))
|
|
|
352 (back-to-indentation)
|
|
|
353 (unless (or col element)
|
|
|
354 ;; Determine element
|
|
|
355 (setq element
|
|
|
356 (let ((sgml-throw-on-error 'parse-error))
|
|
|
357 (catch sgml-throw-on-error
|
|
|
358 (if (eobp)
|
|
|
359 (sgml-find-context-of (point))
|
|
|
360 (sgml-find-element-of (point)))))))
|
|
|
361 (when (eq element sgml-top-tree) ; not in a element at all
|
|
|
362 (setq element nil) ; forget element
|
|
|
363 (goto-char here)) ; insert normal tab insted)
|
|
|
364 (when element
|
|
|
365 (sgml-with-parser-syntax
|
|
|
366 (let ((stag (sgml-is-start-tag))
|
|
|
367 (etag (sgml-is-end-tag)))
|
|
2
|
368 ;; Wing change
|
|
0
|
369 (when (and
|
|
|
370 (not (member* (sgml-element-gi
|
|
|
371 (if (or stag etag)
|
|
|
372 (sgml-element-parent element)
|
|
|
373 element))
|
|
|
374 sgml-inhibit-indent-tags
|
|
|
375 :test #'equalp))
|
|
|
376 (or sgml-indent-data
|
|
|
377 (not (sgml-element-data-p
|
|
|
378 (if stag
|
|
|
379 (sgml-element-parent element)
|
|
|
380 element)))))
|
|
|
381 (setq col
|
|
|
382 (* sgml-indent-step
|
|
|
383 (+ (if (or stag etag) -1 0)
|
|
|
384 (sgml-element-level element))))))))
|
|
|
385 (when (and col (/= col (current-column)))
|
|
|
386 (beginning-of-line 1)
|
|
|
387 (delete-horizontal-space)
|
|
|
388 (indent-to col))
|
|
|
389 (when (< (point) here)
|
|
|
390 (goto-char here))
|
|
|
391 col)))
|
|
|
392
|
|
|
393 (defun sgml-next-data-field ()
|
|
|
394 "Move forward to next point where data is allowed."
|
|
|
395 (interactive)
|
|
|
396 (when (eobp)
|
|
|
397 (error "End of buffer"))
|
|
|
398 (let ((sgml-throw-on-warning 'next-data)
|
|
|
399 (avoid-el (sgml-last-element)))
|
|
|
400 ;; Avoid stopping in current element, unless point is in the start
|
|
|
401 ;; tag of the element
|
|
|
402 (when (< (point) (sgml-element-stag-end avoid-el))
|
|
|
403 (setq avoid-el nil))
|
|
|
404 (catch sgml-throw-on-warning
|
|
|
405 (while (progn
|
|
|
406 (sgml-parse-to (1+ (point)))
|
|
|
407 (setq sgml-last-element
|
|
|
408 (if (not (eq ?< (following-char)))
|
|
|
409 (sgml-find-element-of (point))
|
|
|
410 sgml-current-tree))
|
|
|
411 (or (eq sgml-last-element avoid-el)
|
|
|
412 (not (sgml-element-data-p sgml-last-element)))))
|
|
|
413 (sgml-set-last-element))))
|
|
|
414
|
|
|
415 (defun sgml-next-trouble-spot ()
|
|
|
416 "Move forward to next point where something is amiss with the structure."
|
|
|
417 (interactive)
|
|
|
418 (push-mark)
|
|
|
419 (sgml-note-change-at (point)) ; Prune the parse tree
|
|
|
420 (sgml-parse-to (point))
|
|
2
|
421 (let ((sgml-throw-on-warning 'trouble))
|
|
0
|
422 (or (catch sgml-throw-on-warning
|
|
|
423 (sgml-parse-until-end-of nil t))
|
|
|
424 (message "Ok"))))
|
|
|
425
|
|
|
426
|
|
|
427
|
|
|
428 ;;;; SGML mode: information display
|
|
|
429
|
|
|
430 (defun sgml-list-valid-tags ()
|
|
|
431 "Display a list of the contextually valid tags."
|
|
|
432 (interactive)
|
|
|
433 (sgml-parse-to-here)
|
|
2
|
434 (let ((model (sgml-element-model sgml-current-tree))
|
|
|
435 (smap-name (sgml-lookup-shortref-name
|
|
|
436 (sgml-dtd-shortmaps sgml-dtd-info)
|
|
|
437 sgml-current-shortmap)))
|
|
0
|
438 (with-output-to-temp-buffer "*Tags*"
|
|
|
439 (princ (format "Current element: %s %s\n"
|
|
|
440 (sgml-element-name sgml-current-tree)
|
|
|
441 (if (sgml-eltype-defined
|
|
|
442 (sgml-element-eltype sgml-current-tree))
|
|
|
443 ""
|
|
|
444 "[UNDEFINED]")))
|
|
|
445 (princ (format "Element content: %s %s\n"
|
|
|
446 (cond ((or (sgml-current-mixed-p) (eq model sgml-any))
|
|
|
447 "mixed")
|
|
|
448 ((sgml-model-group-p model)
|
|
|
449 "element")
|
|
|
450 (t
|
|
|
451 model))
|
|
|
452 (if (eq model sgml-any)
|
|
|
453 "[ANY]" "")))
|
|
|
454
|
|
2
|
455 (when smap-name
|
|
|
456 (princ (format "Current short reference map: %s\n" smap-name)))
|
|
|
457
|
|
0
|
458 (cond ((sgml-final-p sgml-current-state)
|
|
|
459 (princ "Valid end-tags : ")
|
|
|
460 (loop for e in (sgml-current-list-of-endable-eltypes)
|
|
|
461 do (princ (sgml-end-tag-of e)) (princ " "))
|
|
|
462 (terpri))
|
|
|
463 (t
|
|
|
464 (princ "Current element can not end here\n")))
|
|
|
465 ;;; (let ((s (sgml-tree-shortmap sgml-current-tree)))
|
|
|
466 ;;; (when s
|
|
|
467 ;;; (princ (format "Current shortref map: %s\n" s))))
|
|
|
468 (princ "Valid start-tags\n")
|
|
|
469 (sgml-print-valid-tags "In current element:"
|
|
|
470 sgml-current-tree sgml-current-state))))
|
|
|
471
|
|
|
472 (defun sgml-print-valid-tags (prompt tree state &optional exclude omitted-stag)
|
|
|
473 (if (not (sgml-model-group-p state))
|
|
|
474 (princ (format "%s (in %s)\n" prompt state))
|
|
|
475 (let* ((req (sgml-required-tokens state))
|
|
|
476 (elems (nconc req
|
|
|
477 (delq sgml-pcdata-token
|
|
|
478 (sgml-optional-tokens state))))
|
|
|
479 (in (sgml-tree-includes tree))
|
|
|
480 (ex (append exclude (sgml-tree-excludes tree))))
|
|
|
481 ;; Modify for exceptions
|
|
|
482 (while in
|
|
|
483 (unless (memq (car in) elems)
|
|
|
484 (setq elems (nconc elems (list (car in)))))
|
|
|
485 (setq in (cdr in)))
|
|
|
486 (while ex
|
|
|
487 (setq elems (delq (car ex) elems))
|
|
|
488 (setq ex (cdr ex)))
|
|
|
489 ;;
|
|
|
490 (setq elems (sort elems (function string-lessp)))
|
|
|
491 (sgml-print-list-of-tags prompt elems)
|
|
|
492 ;; Check for omissable start-tags
|
|
|
493 (when (and req (null (cdr req)))
|
|
|
494 ;; *** Assumes tokens are eltypes
|
|
|
495 (let ((el (sgml-fake-open-element tree (car req))))
|
|
|
496 (when (sgml-element-stag-optional el)
|
|
|
497 (sgml-print-valid-tags
|
|
|
498 (format "If omitting %s:" (sgml-start-tag-of el))
|
|
|
499 el
|
|
|
500 (sgml-element-model el)
|
|
|
501 (append exclude elems)
|
|
|
502 'omitted-stag))))
|
|
|
503 ;; Check for omissable end-tag
|
|
|
504 (when (and (not omitted-stag)
|
|
|
505 (sgml-final-p state)
|
|
|
506 (sgml-element-etag-optional tree))
|
|
|
507 (sgml-print-valid-tags
|
|
|
508 (format "If omitting %s:" (sgml-end-tag-of tree))
|
|
|
509 (sgml-element-parent tree)
|
|
|
510 (sgml-element-pstate tree)
|
|
|
511 (append exclude elems))))))
|
|
|
512
|
|
|
513 (defun sgml-print-list-of-tags (prompt list)
|
|
|
514 (when list
|
|
|
515 (princ prompt)
|
|
|
516 (let ((col (length prompt))
|
|
|
517 (w (1- (frame-width))))
|
|
|
518 (loop for e in list
|
|
|
519 as str = (sgml-start-tag-of e)
|
|
|
520 do
|
|
|
521 (setq col (+ col (length str) 2))
|
|
|
522 (cond ((>= col w)
|
|
|
523 (setq col (+ (length str) 2))
|
|
|
524 (terpri)))
|
|
|
525 (princ " ")
|
|
|
526 (princ str))
|
|
|
527 (terpri))))
|
|
|
528
|
|
|
529 (defun sgml-show-context (&optional element)
|
|
|
530 "Display where the cursor is in the element hierarchy."
|
|
|
531 (interactive)
|
|
|
532 (let* ((el (or element (sgml-last-element)))
|
|
|
533 (model (sgml-element-model el)))
|
|
|
534 (sgml-message "%s %s"
|
|
|
535 (cond
|
|
|
536 ((and (null element) ; Don't trust sgml-markup-type if
|
|
|
537 ; explicit element is given as argument
|
|
|
538 sgml-markup-type))
|
|
|
539 ((sgml-element-mixed el)
|
|
|
540 "#PCDATA")
|
|
|
541 ((not (sgml-model-group-p model))
|
|
|
542 model)
|
|
|
543 (t ""))
|
|
|
544 (if (eq el sgml-top-tree)
|
|
|
545 "in empty context"
|
|
|
546 (sgml-element-context-string el)))))
|
|
|
547
|
|
|
548 (defun sgml-what-element ()
|
|
|
549 "Display what element is under the cursor."
|
|
|
550 (interactive)
|
|
2
|
551 (let* ((pos (point))
|
|
|
552 (nobol (eq (point) sgml-rs-ignore-pos))
|
|
|
553 (sref (sgml-deref-shortmap sgml-current-shortmap nobol))
|
|
|
554 (el nil))
|
|
|
555 (goto-char pos)
|
|
|
556 (setq el (sgml-find-element-of pos))
|
|
0
|
557 (assert (not (null el)))
|
|
|
558 (message "%s %s"
|
|
|
559 (cond ((eq el sgml-top-tree)
|
|
|
560 "outside document element")
|
|
|
561 ((< (point) (sgml-element-stag-end el))
|
|
|
562 "start-tag")
|
|
|
563 ((>= (point) (sgml-element-etag-start el))
|
|
|
564 "end-tag")
|
|
2
|
565 (sref
|
|
|
566 "shortref")
|
|
0
|
567 (t
|
|
|
568 "content"))
|
|
|
569 (sgml-element-context-string el))))
|
|
|
570
|
|
|
571 ;;;; SGML mode: keyboard inserting
|
|
|
572
|
|
|
573 (defun sgml-insert-tag (tag &optional silent no-nl-after)
|
|
|
574 "Insert a tag, reading tag name in minibuffer with completion.
|
|
|
575 If the variable sgml-balanced-tag-edit is t, also inserts the
|
|
|
576 corresponding end tag. If sgml-leave-point-after-insert is t, the point
|
|
|
577 is left after the inserted tag(s), unless the element has som required
|
|
|
578 content. If sgml-leave-point-after-insert is nil the point is left
|
|
|
579 after the first tag inserted."
|
|
|
580 (interactive
|
|
|
581 (list
|
|
|
582 (completing-read "Tag: " (sgml-completion-table) nil t "<" )))
|
|
|
583 (sgml-find-context-of (point))
|
|
|
584 (assert (null sgml-markup-type))
|
|
|
585 ;; Fix white-space before tag
|
|
|
586 (unless (sgml-element-data-p (sgml-parse-to-here))
|
|
|
587 (skip-chars-backward " \t")
|
|
|
588 (cond ((bolp)
|
|
|
589 (if (looking-at "^\\s-*$")
|
|
|
590 (fixup-whitespace)))
|
|
|
591 (t
|
|
|
592 (insert "\n"))))
|
|
2
|
593 (tempo-process-and-insert-string tag)
|
|
0
|
594 (sgml-indent-line)
|
|
|
595 (unless no-nl-after
|
|
|
596 (save-excursion
|
|
|
597 (unless (sgml-element-data-p (sgml-parse-to-here))
|
|
|
598 (unless (eolp)
|
|
|
599 (save-excursion (insert "\n"))))))
|
|
|
600 (or silent (sgml-show-context)))
|
|
|
601
|
|
|
602 (defvar sgml-new-attribute-list-function
|
|
|
603 (function sgml-default-asl))
|
|
|
604
|
|
|
605 (defun sgml-insert-element (name &optional after silent)
|
|
|
606 "Reads element name from minibuffer and inserts start and end tags."
|
|
|
607 (interactive (list (sgml-read-element-name "Element: ")
|
|
|
608 sgml-leave-point-after-insert))
|
|
|
609 (let (newpos ; position to leave cursor at
|
|
|
610 element ; inserted element
|
|
|
611 (sgml-show-warnings nil))
|
|
|
612 (when (and name (not (equal name "")))
|
|
|
613 (sgml-insert-tag (sgml-start-tag-of name) 'silent)
|
|
|
614 (forward-char -1)
|
|
|
615 (setq element (sgml-find-element-of (point)))
|
|
|
616 (sgml-insert-attributes (funcall sgml-new-attribute-list-function
|
|
|
617 element)
|
|
|
618 (sgml-element-attlist element))
|
|
|
619 (forward-char 1)
|
|
|
620 (when (not (sgml-element-empty element))
|
|
|
621 (when (and sgml-auto-insert-required-elements
|
|
|
622 (sgml-model-group-p sgml-current-state))
|
|
|
623 (let (tem)
|
|
|
624 (while (and (setq tem (sgml-required-tokens sgml-current-state))
|
|
|
625 (null (cdr tem)))
|
|
|
626 (setq tem (sgml-insert-element (car tem) t t))
|
|
|
627 (setq newpos (or newpos tem))
|
|
|
628 (sgml-parse-to-here))
|
|
|
629 (when tem ; more than one req elem
|
|
|
630 (insert "\n")
|
|
|
631 (when sgml-insert-missing-element-comment
|
|
|
632 (insert (format "<!-- one of %s -->" tem))
|
|
|
633 (sgml-indent-line nil element)))))
|
|
|
634 (setq newpos (or newpos (point)))
|
|
|
635 (when sgml-insert-end-tag-on-new-line
|
|
|
636 (insert "\n"))
|
|
|
637 (sgml-insert-tag (sgml-end-tag-of name) 'silent)
|
|
|
638 (unless after
|
|
|
639 (goto-char newpos))
|
|
|
640 (unless silent (sgml-show-context)))
|
|
|
641 newpos)))
|
|
|
642
|
|
|
643 (defun sgml-default-asl (element)
|
|
|
644 (loop for attdecl in (sgml-element-attlist element)
|
|
|
645 when (sgml-default-value-type-p (sgml-attdecl-default-value attdecl)
|
|
|
646 'required)
|
|
|
647 collect
|
|
|
648 (sgml-make-attspec
|
|
|
649 (sgml-attdecl-name attdecl)
|
|
|
650 (sgml-read-attribute-value attdecl nil))))
|
|
|
651
|
|
|
652 (defun sgml-tag-region (element start end)
|
|
|
653 "Reads element name from minibuffer and inserts start and end tags."
|
|
|
654 (interactive
|
|
|
655 (list
|
|
|
656 (save-excursion (goto-char (region-beginning))
|
|
|
657 (sgml-read-element-name "Tag region with element: "))
|
|
|
658 (region-beginning)
|
|
|
659 (region-end)))
|
|
|
660 (save-excursion
|
|
|
661 (when (and element (not (equal element "")))
|
|
|
662 (goto-char end)
|
|
2
|
663 (tempo-process-and-insert-string (sgml-end-tag-of element))
|
|
0
|
664 (goto-char start)
|
|
|
665 (sgml-insert-tag (sgml-start-tag-of element)))))
|
|
|
666
|
|
|
667 (defun sgml-insert-attributes (avl attlist)
|
|
|
668 "Insert the attributes with values AVL and declarations ATTLIST.
|
|
|
669 AVL should be a assoc list mapping symbols to strings."
|
|
2
|
670 (let (name val dcl def)
|
|
0
|
671 (loop for attspec in attlist do
|
|
|
672 (setq name (sgml-attspec-name attspec)
|
|
|
673 val (cdr-safe (sgml-lookup-attspec name avl))
|
|
|
674 dcl (sgml-attdecl-declared-value attspec)
|
|
|
675 def (sgml-attdecl-default-value attspec))
|
|
|
676 (unless val ; no value given
|
|
|
677 ;; Supply the default value if a value is needed
|
|
|
678 (cond ((sgml-default-value-type-p 'required def)
|
|
|
679 (setq val ""))
|
|
|
680 ((and (not (or sgml-omittag sgml-shorttag))
|
|
|
681 (consp def))
|
|
|
682 (setq val (sgml-default-value-attval def)))))
|
|
|
683 (cond
|
|
|
684 ((null val)) ; Ignore
|
|
|
685 ;; Ignore attributes with default value
|
|
|
686 ((and (consp def)
|
|
|
687 (eq sgml-minimize-attributes 'max)
|
|
|
688 (or sgml-omittag sgml-shorttag)
|
|
|
689 (equal val (sgml-default-value-attval def))))
|
|
|
690 ;; No attribute name for token groups
|
|
|
691 ((and sgml-minimize-attributes sgml-shorttag
|
|
|
692 (member (sgml-general-case val)
|
|
|
693 (sgml-declared-value-token-group dcl)))
|
|
2
|
694 (tempo-process-and-insert-string (concat " " val)))
|
|
0
|
695 (t
|
|
2
|
696 (tempo-process-and-insert-string (concat " " name "="))
|
|
|
697 (insert (sgml-quote-attribute-value val)))))
|
|
0
|
698 (when auto-fill-function
|
|
|
699 (funcall auto-fill-function))))
|
|
|
700
|
|
|
701
|
|
|
702 (defun sgml-quote-attribute-value (value)
|
|
|
703 "Add quotes to the string VALUE unless minimization is on."
|
|
|
704 (let ((quote ""))
|
|
|
705 (cond ((and (not sgml-always-quote-attributes)
|
|
|
706 sgml-shorttag
|
|
|
707 (string-match "\\`[.A-Za-z0-9---]+\\'" value))
|
|
|
708 ) ; no need to quote
|
|
|
709 ((not (string-match "\"" value)) ; can use "" quotes
|
|
|
710 (setq quote "\""))
|
|
|
711 (t ; use '' quotes
|
|
|
712 (setq quote "'")))
|
|
|
713 (concat quote value quote)))
|
|
|
714
|
|
|
715 (defun sgml-completion-table (&optional avoid-tags-in-cdata)
|
|
|
716 (sgml-parse-to-here)
|
|
|
717 (when sgml-markup-type
|
|
|
718 (error "No tags allowed"))
|
|
|
719 (cond ((or (sgml-model-group-p sgml-current-state)
|
|
|
720 (eq sgml-current-state sgml-any))
|
|
|
721 (append
|
|
|
722 (mapcar (function (lambda (x) (cons (sgml-end-tag-of x) x)))
|
|
|
723 (sgml-current-list-of-endable-eltypes))
|
|
|
724 (mapcar (function (lambda (x) (cons (sgml-start-tag-of x) x)))
|
|
|
725 (sgml-current-list-of-valid-eltypes))))
|
|
|
726 (t
|
|
|
727 (sgml-message "%s" sgml-current-state)
|
|
|
728 nil)))
|
|
|
729
|
|
2
|
730 (defun sgml-element-endable-p ()
|
|
|
731 (sgml-parse-to-here)
|
|
|
732 (and (not (eq sgml-current-tree sgml-top-tree))
|
|
|
733 (sgml-final-p sgml-current-state)))
|
|
|
734
|
|
0
|
735 (defun sgml-insert-end-tag ()
|
|
|
736 "Insert end-tag for the current open element."
|
|
|
737 (interactive "*")
|
|
|
738 (sgml-parse-to-here)
|
|
|
739 (cond
|
|
|
740 ((eq sgml-current-tree sgml-top-tree)
|
|
|
741 (sgml-error "No open element"))
|
|
|
742 ((not (sgml-final-p sgml-current-state))
|
|
|
743 (sgml-error "Can`t end element here"))
|
|
|
744 (t
|
|
|
745 (when (and sgml-indent-step
|
|
|
746 (not (sgml-element-data-p sgml-current-tree)))
|
|
|
747 (delete-horizontal-space)
|
|
|
748 (unless (bolp)
|
|
|
749 (insert "\n")))
|
|
|
750 (when (prog1 (bolp)
|
|
2
|
751 (tempo-process-and-insert-string
|
|
|
752 (if (eq t (sgml-element-net-enabled sgml-current-tree))
|
|
|
753 "/"
|
|
|
754 ;; wing change: If there is more than one endable
|
|
|
755 ;; tag, we probably want the outermost one rather
|
|
|
756 ;; than the innermost one. Thus, we end a </ul>
|
|
|
757 ;; even when a </li> is possible.
|
|
|
758 (sgml-end-tag-of
|
|
|
759 (car (last (sgml-current-list-of-endable-eltypes)))))))
|
|
0
|
760 (sgml-indent-line)))))
|
|
|
761
|
|
|
762 (defun sgml-insert-start-tag (name asl attlist &optional net)
|
|
2
|
763 (tempo-process-and-insert-string (concat "<" name))
|
|
0
|
764 (sgml-insert-attributes asl attlist)
|
|
|
765 (insert (if net "/" ">")))
|
|
|
766
|
|
|
767 (defun sgml-change-start-tag (element asl)
|
|
|
768 (let ((name (sgml-element-gi element))
|
|
|
769 (attlist (sgml-element-attlist element)))
|
|
|
770 (assert (sgml-bpos-p (sgml-element-stag-epos element)))
|
|
|
771 (goto-char (sgml-element-start element))
|
|
|
772 (delete-char (sgml-element-stag-len element))
|
|
|
773 (sgml-insert-start-tag name asl attlist
|
|
|
774 (eq t (sgml-element-net-enabled element)))))
|
|
|
775
|
|
|
776 (defun sgml-read-attribute-value (attdecl curvalue)
|
|
|
777 "Return the attribute value read from user.
|
|
|
778 ATTDECL is the attribute declaration for the attribute to read.
|
|
|
779 CURVALUE is nil or a string that will be used as default value."
|
|
|
780 (assert attdecl)
|
|
|
781 (let* ((name (sgml-attdecl-name attdecl))
|
|
|
782 (dv (sgml-attdecl-declared-value attdecl))
|
|
|
783 (tokens (sgml-declared-value-token-group dv))
|
|
|
784 (notations (sgml-declared-value-notation dv))
|
|
|
785 (type (cond (tokens "token")
|
|
|
786 (notations "notation")
|
|
|
787 (t (symbol-name dv))))
|
|
|
788 (prompt
|
|
|
789 (format "Value for %s (%s%s): "
|
|
|
790 name type
|
|
|
791 (if curvalue
|
|
|
792 (format " Default: %s" curvalue)
|
|
|
793 "")))
|
|
|
794 value)
|
|
|
795 (setq value
|
|
|
796 (if (or tokens notations)
|
|
|
797 (completing-read prompt
|
|
|
798 (mapcar 'list (or tokens notations))
|
|
|
799 nil t)
|
|
|
800 (read-string prompt)))
|
|
|
801 (if (and curvalue (equal value ""))
|
|
|
802 curvalue value)))
|
|
|
803
|
|
|
804 (defun sgml-non-fixed-attributes (attlist)
|
|
|
805 (loop for attdecl in attlist
|
|
|
806 unless (sgml-default-value-type-p 'fixed
|
|
|
807 (sgml-attdecl-default-value attdecl))
|
|
|
808 collect attdecl))
|
|
|
809
|
|
|
810 (defun sgml-insert-attribute (name value)
|
|
|
811 "Read attribute name and value from minibuffer and insert attribute spec."
|
|
|
812 (interactive
|
|
|
813 (let* ((el (sgml-find-attribute-element))
|
|
|
814 (name
|
|
|
815 (completing-read
|
|
|
816 "Attribute name: "
|
|
|
817 (mapcar (function (lambda (a) (list (sgml-attdecl-name a))))
|
|
|
818 (sgml-non-fixed-attributes (sgml-element-attlist el)))
|
|
|
819 nil t)))
|
|
|
820 (list name
|
|
|
821 (sgml-read-attribute-value
|
|
|
822 (sgml-lookup-attdecl name (sgml-element-attlist el))
|
|
|
823 (sgml-element-attval el name)))))
|
|
|
824 ;; Body
|
|
|
825 (assert (stringp name))
|
|
|
826 (assert (or (null value) (stringp value)))
|
|
|
827 (let* ((el (sgml-find-attribute-element))
|
|
|
828 (asl (cons (sgml-make-attspec name value)
|
|
|
829 (sgml-element-attribute-specification-list el)))
|
|
|
830 (in-tag (< (point) (sgml-element-stag-end el))))
|
|
|
831 (sgml-change-start-tag el asl)
|
|
|
832 (when in-tag (forward-char -1))))
|
|
|
833
|
|
|
834 (defun sgml-split-element ()
|
|
|
835 "Split the current element at point.
|
|
|
836 If repeated, the containing element will be split before the beginning
|
|
|
837 of then current element."
|
|
|
838 (interactive "*")
|
|
|
839 (setq sgml-split-level
|
|
|
840 (if (eq this-command last-command)
|
|
|
841 (1+ sgml-split-level)
|
|
|
842 0))
|
|
|
843 (let ((u (sgml-find-context-of (point)))
|
|
2
|
844 (start (point-marker)))
|
|
0
|
845 (loop repeat sgml-split-level do
|
|
|
846 (goto-char (sgml-element-start u))
|
|
|
847 (setq u (sgml-element-parent u)))
|
|
|
848 ;; Verify that a new element can be started
|
|
|
849 (unless (and (sgml-element-pstate u) ; in case of top element
|
|
|
850 (sgml-get-move (sgml-element-pstate u)
|
|
|
851 (sgml-element-name u)))
|
|
|
852
|
|
|
853 (sgml-error "The %s element can't be split"
|
|
|
854 (sgml-element-name u)))
|
|
|
855 ;; Do the split
|
|
|
856 (sgml-insert-end-tag)
|
|
|
857 (sgml-insert-tag (sgml-start-tag-of u) 'silent)
|
|
|
858 (skip-chars-forward " \t\n")
|
|
|
859 (sgml-indent-line)
|
|
|
860 (when (> sgml-split-level 0)
|
|
|
861 (goto-char start))
|
|
|
862 (or (eq sgml-top-tree
|
|
|
863 (setq u (sgml-element-parent u)))
|
|
|
864 (sgml-message
|
|
|
865 "Repeat the command to split the containing %s element"
|
|
|
866 (sgml-element-name u)))))
|
|
|
867
|
|
|
868 ;;; David Megginson's custom menus for keys
|
|
|
869
|
|
|
870 (defun sgml-custom-dtd (doctype)
|
|
|
871 "Insert a DTD declaration from the sgml-custom-dtd alist."
|
|
|
872 (interactive
|
|
|
873 (list (completing-read "Insert DTD: " sgml-custom-dtd nil t)))
|
|
|
874 (let ((entry (assoc doctype sgml-custom-dtd)))
|
|
|
875 (sgml-doctype-insert (second entry) (cddr entry))))
|
|
|
876
|
|
|
877 (defun sgml-custom-markup (markup)
|
|
|
878 "Insert markup from the sgml-custom-markup alist."
|
|
|
879 (interactive
|
|
|
880 (list (completing-read "Insert Markup: " sgml-custom-markup nil t)))
|
|
|
881 (sgml-insert-markup (cadr (assoc markup sgml-custom-markup))))
|
|
|
882
|
|
|
883
|
|
|
884 ;;;; SGML mode: Menu inserting
|
|
|
885
|
|
|
886 (defun sgml-tags-menu (event)
|
|
|
887 "Pop up a menu with valid tags and insert the choosen tag.
|
|
|
888 If the variable sgml-balanced-tag-edit is t, also inserts the
|
|
|
889 corresponding end tag. If sgml-leave-point-after-insert is t, the point
|
|
|
890 is left after the inserted tag(s), unless the element has som required
|
|
|
891 content. If sgml-leave-point-after-insert is nil the point is left
|
|
|
892 after the first tag inserted."
|
|
|
893 (interactive "*e")
|
|
|
894 (let ((end (sgml-mouse-region)))
|
|
|
895 (sgml-parse-to-here)
|
|
|
896 (cond
|
|
|
897 ((eq sgml-markup-type 'start-tag)
|
|
|
898 (sgml-attrib-menu event))
|
|
|
899 (t
|
|
|
900 (let ((what
|
|
|
901 (sgml-menu-ask event (if (or end sgml-balanced-tag-edit)
|
|
|
902 'element 'tags))))
|
|
|
903 (cond
|
|
|
904 ((null what))
|
|
|
905 (end
|
|
|
906 (sgml-tag-region what (point) end))
|
|
|
907 (sgml-balanced-tag-edit
|
|
|
908 (sgml-insert-element what))
|
|
|
909 (t
|
|
|
910 (sgml-insert-tag what))))))))
|
|
|
911
|
|
|
912 (defun sgml-element-menu (event)
|
|
|
913 "Pop up a menu with valid elements and insert choice.
|
|
|
914 If sgml-leave-point-after-insert is nil the point is left after the first
|
|
|
915 tag inserted."
|
|
|
916 (interactive "*e")
|
|
|
917 (let ((what (sgml-menu-ask event 'element)))
|
|
|
918 (and what (sgml-insert-element what))))
|
|
|
919
|
|
|
920 (defun sgml-start-tag-menu (event)
|
|
|
921 "Pop up a menu with valid start-tags and insert choice."
|
|
|
922 (interactive "*e")
|
|
|
923 (let ((what (sgml-menu-ask event 'start-tag)))
|
|
|
924 (and what (sgml-insert-tag what))))
|
|
|
925
|
|
|
926 (defun sgml-end-tag-menu (event)
|
|
|
927 "Pop up a menu with valid end-tags and insert choice."
|
|
|
928 (interactive "*e")
|
|
|
929 (let ((what (sgml-menu-ask event 'end-tag)))
|
|
|
930 (and what (sgml-insert-tag what))))
|
|
|
931
|
|
|
932 (defun sgml-tag-region-menu (event)
|
|
|
933 "Pop up a menu with valid elements and tag current region with the choice."
|
|
|
934 (interactive "*e")
|
|
|
935 (let ((what (sgml-menu-ask event 'element)))
|
|
|
936 (and what (sgml-tag-region what
|
|
|
937 (region-beginning)
|
|
|
938 (region-end)))))
|
|
|
939
|
|
|
940 (defun sgml-menu-ask (event type)
|
|
|
941 (sgml-parse-to-here)
|
|
|
942 (let (tab
|
|
|
943 (title (capitalize (symbol-name type))))
|
|
|
944 (cond
|
|
|
945 (sgml-markup-type)
|
|
|
946 ((eq type 'element)
|
|
|
947 (setq tab
|
|
|
948 (mapcar (function symbol-name)
|
|
|
949 (sgml-current-list-of-valid-eltypes))))
|
|
|
950 (t
|
|
|
951 (unless (eq type 'start-tag)
|
|
|
952 (setq tab
|
|
|
953 (mapcar (function sgml-end-tag-of)
|
|
|
954 (sgml-current-list-of-endable-eltypes))))
|
|
|
955 (unless (eq type 'end-tag)
|
|
|
956 (setq tab
|
|
|
957 (nconc tab
|
|
|
958 (mapcar (function sgml-start-tag-of)
|
|
|
959 (sgml-current-list-of-valid-eltypes)))))))
|
|
|
960 (or tab
|
|
|
961 (error "No valid %s at this point" type))
|
|
|
962 (or
|
|
|
963 (sgml-popup-menu event
|
|
|
964 title
|
|
|
965 (mapcar (function (lambda (x) (cons x x)))
|
|
|
966 tab))
|
|
|
967 (message nil))))
|
|
|
968
|
|
|
969 (defun sgml-entities-menu (event)
|
|
|
970 (interactive "*e")
|
|
|
971 (sgml-need-dtd)
|
|
|
972 (let ((menu
|
|
|
973 (mapcar (function (lambda (x) (cons x x)))
|
|
|
974 (sort (sgml-map-entities (function sgml-entity-name)
|
|
|
975 (sgml-dtd-entities sgml-dtd-info)
|
|
|
976 t)
|
|
|
977 (function string-lessp))))
|
|
|
978 choice)
|
|
|
979 (unless menu
|
|
|
980 (error "No entities defined"))
|
|
|
981 (setq choice (sgml-popup-menu event "Entities" menu))
|
|
|
982 (when choice
|
|
|
983 (insert "&" choice ";"))))
|
|
|
984
|
|
|
985 (defun sgml-doctype-insert (doctype vars)
|
|
|
986 "Insert string DOCTYPE (ignored if nil) and set variables in &rest VARS.
|
|
|
987 VARS should be a list of variables and values.
|
|
2
|
988 For backward compatibility a single string instead of a variable is
|
|
0
|
989 assigned to sgml-default-dtd-file.
|
|
|
990 All variables are made buffer local and are also added to the
|
|
|
991 buffers local variables list."
|
|
|
992 (when doctype
|
|
|
993 (unless (bolp)
|
|
|
994 (insert "\n"))
|
|
|
995 (unless (eolp)
|
|
|
996 (insert "\n")
|
|
|
997 (forward-char -1))
|
|
|
998 (sgml-insert-markup doctype))
|
|
|
999 (while vars
|
|
|
1000 (cond ((stringp (car vars))
|
|
|
1001 (sgml-set-local-variable 'sgml-default-dtd-file (car vars))
|
|
|
1002 (setq vars (cdr vars)))
|
|
|
1003 ((car vars) ; Avoid nil
|
|
|
1004 (sgml-set-local-variable (car vars) (cadr vars))
|
|
|
1005 (setq vars (cddr vars)))))
|
|
|
1006 (setq sgml-top-tree nil))
|
|
|
1007
|
|
|
1008 (defun sgml-attrib-menu (event)
|
|
|
1009 "Pop up a menu of the attributes of the current element
|
|
|
1010 \(or the element whith start-tag before point)."
|
|
|
1011 (interactive "e")
|
|
2
|
1012 (let ((menu (sgml-make-attrib-menu (sgml-find-attribute-element))))
|
|
|
1013 (sgml-popup-multi-menu event "Attributes" menu)))
|
|
|
1014
|
|
|
1015 (defun sgml-make-attrib-menu (el)
|
|
|
1016 (let ((attlist (sgml-non-fixed-attributes (sgml-element-attlist el))))
|
|
0
|
1017 (or attlist
|
|
|
1018 (error "No non-fixed attributes for element"))
|
|
2
|
1019 (loop for attdecl in attlist
|
|
|
1020 for name = (sgml-attdecl-name attdecl)
|
|
|
1021 for defval = (sgml-attdecl-default-value attdecl)
|
|
|
1022 for tokens = (or (sgml-declared-value-token-group
|
|
|
1023 (sgml-attdecl-declared-value attdecl))
|
|
|
1024 (sgml-declared-value-notation
|
|
|
1025 (sgml-attdecl-declared-value attdecl)))
|
|
|
1026 collect
|
|
|
1027 (cons
|
|
|
1028 (sgml-attdecl-name attdecl)
|
|
|
1029 (nconc
|
|
|
1030 (if tokens
|
|
|
1031 (loop for val in tokens collect
|
|
|
1032 (list val
|
|
|
1033 (list 'sgml-insert-attribute name val)))
|
|
|
1034 (list
|
|
|
1035 (list "Set attribute value"
|
|
|
1036 (list 'sgml-insert-attribute
|
|
|
1037 (sgml-attdecl-name attdecl)
|
|
|
1038 (list 'sgml-read-attribute-value
|
|
|
1039 (list 'quote attdecl)
|
|
|
1040 (sgml-element-attval el name))))))
|
|
|
1041 (if (sgml-default-value-type-p 'required defval)
|
|
|
1042 nil
|
|
|
1043 (list "--"
|
|
|
1044 (list (if (sgml-default-value-type-p nil defval)
|
|
|
1045 (format "Default: %s"
|
|
|
1046 (sgml-default-value-attval defval))
|
|
|
1047 "#IMPLIED")
|
|
|
1048 (list 'sgml-insert-attribute name nil))))))))
|
|
|
1049 )
|
|
0
|
1050
|
|
|
1051 ;;;; SGML mode: Fill
|
|
|
1052
|
|
|
1053 (defun sgml-fill-element (element)
|
|
|
1054 "Fill bigest enclosing element with mixed content.
|
|
|
1055 If current element has pure element content, recursively fill the
|
|
|
1056 subelements."
|
|
|
1057 (interactive (list (sgml-find-element-of (point))))
|
|
|
1058 ;;
|
|
|
1059 (message "Filling...")
|
|
|
1060 (when (sgml-element-mixed element)
|
|
|
1061 ;; Find bigest enclosing element with mixed content
|
|
|
1062 (while (sgml-element-mixed (sgml-element-parent element))
|
|
|
1063 (setq element (sgml-element-parent element))))
|
|
|
1064 ;;
|
|
|
1065 (sgml-do-fill element)
|
|
|
1066 (sgml-message "Done"))
|
|
|
1067
|
|
|
1068 (defun sgml-do-fill (element)
|
|
|
1069 (when sgml-debug
|
|
|
1070 (goto-char (sgml-element-start element))
|
|
|
1071 (sit-for 0))
|
|
|
1072 (save-excursion
|
|
|
1073 (cond
|
|
|
1074 ((sgml-element-mixed element)
|
|
|
1075 (let (last-pos
|
|
|
1076 (c (sgml-element-content element))
|
|
|
1077 (agenda nil)) ; regions to fill later
|
|
|
1078 (goto-char (sgml-element-stag-end element))
|
|
|
1079 (when (eolp) (forward-char 1))
|
|
|
1080 (setq last-pos (point))
|
|
|
1081 (while c
|
|
|
1082 (cond
|
|
|
1083 ((sgml-element-mixed c))
|
|
|
1084 (t
|
|
|
1085 ;; Put region before element on agenda. Can't fill it now
|
|
108
|
1086 ;; that would mangel the parse tree that is being traversed.
|
|
0
|
1087 (push (cons last-pos (sgml-element-start c))
|
|
|
1088 agenda)
|
|
|
1089 (goto-char (sgml-element-start c))
|
|
|
1090 (sgml-do-fill c)
|
|
|
1091 ;; Fill may change parse tree, get a fresh
|
|
|
1092 (setq c (sgml-find-element-of (point)))
|
|
|
1093 (setq last-pos (sgml-element-end c))))
|
|
|
1094 (setq c (sgml-element-next c)))
|
|
|
1095 ;; Fill the last region in content of element,
|
|
|
1096 ;; but get a fresh parse tree, if it has change due to other fills.
|
|
|
1097 (sgml-fill-region last-pos
|
|
|
1098 (sgml-element-etag-start
|
|
|
1099 (sgml-find-element-of
|
|
|
1100 (sgml-element-start element))))
|
|
|
1101 (while agenda
|
|
|
1102 (sgml-fill-region (caar agenda) (cdar agenda))
|
|
|
1103 (setq agenda (cdr agenda)))))
|
|
|
1104 (t
|
|
|
1105 ;; If element is not mixed, fill subelements recursively
|
|
|
1106 (let ((c (sgml-element-content element)))
|
|
|
1107 (while c
|
|
|
1108 (goto-char (sgml-element-start c))
|
|
|
1109 (sgml-do-fill c)
|
|
|
1110 (setq c (sgml-element-next (sgml-find-element-of (point))))))))))
|
|
|
1111
|
|
|
1112 (defun sgml-fill-region (start end)
|
|
|
1113 (sgml-message "Filling...")
|
|
|
1114 (save-excursion
|
|
|
1115 (goto-char end)
|
|
|
1116 (skip-chars-backward " \t\n")
|
|
|
1117 (while (progn (beginning-of-line 1)
|
|
|
1118 (< start (point)))
|
|
|
1119 (delete-horizontal-space)
|
|
|
1120 (delete-char -1)
|
|
|
1121 (insert " "))
|
|
|
1122 (end-of-line 1)
|
|
|
1123 (let (give-up prev-column opoint)
|
|
|
1124 (while (and (not give-up) (> (current-column) fill-column))
|
|
|
1125 (setq prev-column (current-column))
|
|
|
1126 (setq opoint (point))
|
|
|
1127 (move-to-column (1+ fill-column))
|
|
|
1128 (skip-chars-backward "^ \t\n")
|
|
|
1129 (if (bolp)
|
|
|
1130 (re-search-forward "[ \t]" opoint t))
|
|
|
1131 (setq opoint (point))
|
|
|
1132 (skip-chars-backward " \t")
|
|
|
1133 (if (bolp)
|
|
|
1134 (setq give-up t)
|
|
|
1135 (delete-region (point) opoint)
|
|
|
1136 (newline)
|
|
|
1137 (sgml-indent-line)
|
|
|
1138 (end-of-line 1)
|
|
|
1139 (setq give-up (>= (current-column) prev-column)))))))
|
|
|
1140
|
|
|
1141 ;;;; SGML mode: Attribute editing
|
|
|
1142
|
|
|
1143 (defvar sgml-start-attributes nil)
|
|
|
1144 (defvar sgml-main-buffer nil)
|
|
|
1145 (defvar sgml-attlist nil)
|
|
|
1146
|
|
|
1147 (defun sgml-edit-attributes ()
|
|
|
1148 "Edit attributes of current element.
|
|
|
1149 Editing is done in a separate window."
|
|
|
1150 (interactive)
|
|
|
1151 (let ((element (sgml-find-attribute-element)))
|
|
|
1152 (unless (sgml-bpos-p (sgml-element-stag-epos element))
|
|
|
1153 (error "Element's start-tag is not in the buffer"))
|
|
|
1154 (push-mark)
|
|
|
1155 (goto-char (sgml-element-start element))
|
|
|
1156 (let* ((start (point-marker))
|
|
|
1157 (asl (sgml-element-attribute-specification-list element))
|
|
|
1158 (cb (current-buffer))
|
|
|
1159 (quote sgml-always-quote-attributes))
|
|
|
1160 (switch-to-buffer-other-window
|
|
|
1161 (sgml-attribute-buffer element asl))
|
|
|
1162 (sgml-edit-attrib-mode)
|
|
|
1163 (make-local-variable 'sgml-attlist)
|
|
|
1164 (setq sgml-attlist (sgml-element-attlist element))
|
|
|
1165 (make-local-variable 'sgml-start-attributes)
|
|
|
1166 (setq sgml-start-attributes start)
|
|
|
1167 (make-local-variable 'sgml-always-quote-attributes)
|
|
|
1168 (setq sgml-always-quote-attributes quote)
|
|
|
1169 (make-local-variable 'sgml-main-buffer)
|
|
|
1170 (setq sgml-main-buffer cb))))
|
|
|
1171
|
|
|
1172 (defun sgml-attribute-buffer (element asl)
|
|
|
1173 (let ((bname "*Edit attributes*")
|
|
|
1174 (buf nil)
|
|
|
1175 (inhibit-read-only t))
|
|
|
1176 (save-excursion
|
|
|
1177 (when (setq buf (get-buffer bname))
|
|
|
1178 (kill-buffer buf))
|
|
|
1179 (setq buf (get-buffer-create bname))
|
|
|
1180 (set-buffer buf)
|
|
|
1181 (erase-buffer)
|
|
|
1182 (sgml-insert '(read-only t rear-nonsticky (read-only))
|
|
|
1183 "<%s -- Edit values and finish with C-c C-c --\n"
|
|
|
1184 (sgml-element-name element))
|
|
|
1185 (loop
|
|
|
1186 for attr in (sgml-element-attlist element) do
|
|
|
1187 ;; Produce text like
|
|
|
1188 ;; name = value
|
|
|
1189 ;; -- declaration : default --
|
|
|
1190 (let* ((aname (sgml-attdecl-name attr))
|
|
|
1191 (dcl-value (sgml-attdecl-declared-value attr))
|
|
|
1192 (def-value (sgml-attdecl-default-value attr))
|
|
|
1193 (cur-value (sgml-lookup-attspec aname asl)))
|
|
|
1194 (sgml-insert ; atribute name
|
|
|
1195 '(read-only t rear-nonsticky (read-only))
|
|
|
1196 " %s = " aname)
|
|
|
1197 (cond ; attribute value
|
|
|
1198 ((sgml-default-value-type-p 'fixed def-value)
|
|
|
1199 (sgml-insert '(read-only t category sgml-fixed
|
|
|
1200 rear-nonsticky (category))
|
|
|
1201 "#FIXED %s"
|
|
|
1202 (sgml-default-value-attval def-value)))
|
|
|
1203 ((and (null cur-value)
|
|
|
1204 (or (memq def-value '(implied conref current))
|
|
|
1205 (sgml-default-value-attval def-value)))
|
|
|
1206 (sgml-insert '(category sgml-default rear-nonsticky (category))
|
|
|
1207 "#DEFAULT"))
|
|
|
1208 ((not (null cur-value))
|
|
|
1209 (sgml-insert nil "%s" (sgml-attspec-attval cur-value))))
|
|
|
1210 (sgml-insert
|
|
|
1211 '(read-only 1)
|
|
|
1212 "\n\t-- %s: %s --\n"
|
|
|
1213 (cond ((sgml-declared-value-token-group dcl-value))
|
|
|
1214 ((sgml-declared-value-notation dcl-value)
|
|
|
1215 (format "NOTATION %s"
|
|
|
1216 (sgml-declared-value-notation dcl-value)))
|
|
|
1217 (t
|
|
|
1218 dcl-value))
|
|
|
1219 (cond ((sgml-default-value-attval def-value))
|
|
|
1220 (t
|
|
|
1221 (concat "#" (upcase (symbol-name def-value))))))))
|
|
|
1222 (sgml-insert '(read-only t) ">")
|
|
|
1223 (goto-char (point-min))
|
|
|
1224 (sgml-edit-attrib-next))
|
|
|
1225 buf))
|
|
|
1226
|
|
|
1227 (defvar sgml-edit-attrib-mode-map (make-sparse-keymap))
|
|
|
1228 (define-key sgml-edit-attrib-mode-map "\C-c\C-c" 'sgml-edit-attrib-finish)
|
|
|
1229 (define-key sgml-edit-attrib-mode-map "\C-c\C-d" 'sgml-edit-attrib-default)
|
|
|
1230 (define-key sgml-edit-attrib-mode-map "\C-c\C-k" 'sgml-edit-attrib-clear)
|
|
|
1231
|
|
|
1232 (define-key sgml-edit-attrib-mode-map "\C-a" 'sgml-edit-attrib-field-start)
|
|
|
1233 (define-key sgml-edit-attrib-mode-map "\C-e" 'sgml-edit-attrib-field-end)
|
|
|
1234 (define-key sgml-edit-attrib-mode-map "\t" 'sgml-edit-attrib-next)
|
|
|
1235
|
|
|
1236 (defun sgml-edit-attrib-mode ()
|
|
|
1237 "Major mode to edit attribute specification list.\\<sgml-edit-attrib-mode-map>
|
|
|
1238 Use \\[sgml-edit-attrib-next] to move between input fields. Use
|
|
|
1239 \\[sgml-edit-attrib-default] to make an attribute have its default
|
|
|
1240 value. To abort edit kill buffer (\\[kill-buffer]) and remove window
|
|
|
1241 (\\[delete-window]). To finsh edit use \\[sgml-edit-attrib-finish].
|
|
|
1242
|
|
|
1243 \\{sgml-edit-attrib-mode-map}"
|
|
|
1244 (kill-all-local-variables)
|
|
|
1245 (setq mode-name "SGML edit attributes"
|
|
|
1246 major-mode 'sgml-edit-attrib-mode)
|
|
|
1247 (use-local-map sgml-edit-attrib-mode-map)
|
|
|
1248 (run-hooks 'text-mode-hook 'sgml-edit-attrib-mode-hook))
|
|
|
1249
|
|
|
1250 (defun sgml-edit-attrib-finish ()
|
|
|
1251 "Finish editing and insert attribute values in original buffer."
|
|
|
1252 (interactive)
|
|
|
1253 (let ((cb (current-buffer))
|
|
|
1254 (asl (sgml-edit-attrib-specification-list))
|
|
|
1255 ;; save buffer local variables
|
|
|
1256 (start sgml-start-attributes))
|
|
|
1257 (when (markerp start)
|
|
|
1258 (delete-windows-on cb)
|
|
|
1259 (switch-to-buffer (marker-buffer start))
|
|
|
1260 (kill-buffer cb)
|
|
|
1261 (goto-char start)
|
|
|
1262 (let ((element (sgml-find-element-of start)))
|
|
|
1263 ;; *** Should the it be verified that this element
|
|
|
1264 ;; is the one edited?
|
|
|
1265 (sgml-change-start-tag element asl)))))
|
|
|
1266
|
|
|
1267
|
|
|
1268 (defun sgml-edit-attrib-specification-list ()
|
|
|
1269 (goto-char (point-min))
|
|
|
1270 (forward-line 1)
|
|
|
1271 (sgml-with-parser-syntax
|
|
|
1272 (let ((asl nil)
|
|
|
1273 (al sgml-attlist))
|
|
|
1274 (while (not (eq ?> (following-char)))
|
|
|
1275 (sgml-parse-s)
|
|
2
|
1276 (sgml-check-nametoken) ; attribute name, should match head of al
|
|
|
1277 (forward-char 3)
|
|
|
1278 (unless (memq (get-text-property (point) 'category)
|
|
|
1279 '(sgml-default sgml-fixed))
|
|
|
1280 (push
|
|
|
1281 (sgml-make-attspec (sgml-attdecl-name (car al))
|
|
|
1282 (sgml-extract-attribute-value
|
|
|
1283 (sgml-attdecl-declared-value (car al))))
|
|
|
1284 asl))
|
|
|
1285 (while (progn (beginning-of-line 2)
|
|
|
1286 (or (eolp)
|
|
|
1287 (not (get-text-property (point) 'read-only)))))
|
|
|
1288
|
|
0
|
1289 (forward-line 1)
|
|
|
1290 (setq al (cdr al)))
|
|
|
1291 asl)))
|
|
|
1292
|
|
|
1293
|
|
|
1294 (defun sgml-extract-attribute-value (type)
|
|
|
1295 (save-excursion
|
|
|
1296 (save-restriction
|
|
|
1297 (narrow-to-region (point)
|
|
|
1298 (progn (sgml-edit-attrib-field-end)
|
|
|
1299 (point)))
|
|
|
1300 (unless (eq type 'cdata)
|
|
|
1301 (subst-char-in-region (point-min) (point-max) ?\n ? )
|
|
|
1302 (goto-char (point-min))
|
|
|
1303 (delete-horizontal-space))
|
|
|
1304 (goto-char (point-min))
|
|
|
1305 (when (search-forward "\"" nil t) ; don't allow both " and '
|
|
|
1306 (goto-char (point-min))
|
|
|
1307 (while (search-forward "'" nil t) ; replace ' with char ref
|
|
|
1308 (replace-match "'")))
|
|
|
1309 (buffer-string))))
|
|
|
1310
|
|
|
1311 (defun sgml-edit-attrib-default ()
|
|
|
1312 "Set current attribute value to default."
|
|
|
1313 (interactive)
|
|
|
1314 (sgml-edit-attrib-clear)
|
|
|
1315 (save-excursion
|
|
|
1316 (sgml-insert '(category sgml-default)
|
|
|
1317 "#DEFAULT")))
|
|
|
1318
|
|
|
1319 (defun sgml-edit-attrib-clear ()
|
|
|
1320 "Kill the value of current attribute."
|
|
|
1321 (interactive)
|
|
|
1322 (kill-region
|
|
|
1323 (progn (sgml-edit-attrib-field-start) (point))
|
|
|
1324 (progn (sgml-edit-attrib-field-end) (point))))
|
|
|
1325
|
|
|
1326 (defun sgml-edit-attrib-field-start ()
|
|
|
1327 "Go to the start of the attribute value field."
|
|
|
1328 (interactive)
|
|
|
1329 (let (start)
|
|
|
1330 (beginning-of-line 1)
|
|
|
1331 (while (not (eq t (get-text-property (point) 'read-only)))
|
|
|
1332 (beginning-of-line 0))
|
|
|
1333 (setq start (next-single-property-change (point) 'read-only))
|
|
|
1334 (unless start (error "No attribute value here"))
|
|
|
1335 (assert (number-or-marker-p start))
|
|
|
1336 (goto-char start)))
|
|
|
1337
|
|
|
1338 (defun sgml-edit-attrib-field-end ()
|
|
|
1339 "Go to the end of the attribute value field."
|
|
|
1340 (interactive)
|
|
|
1341 (sgml-edit-attrib-field-start)
|
|
|
1342 (let ((end (if (and (eolp)
|
|
|
1343 (get-text-property (1+ (point)) 'read-only))
|
|
|
1344 (point)
|
|
|
1345 (next-single-property-change (point) 'read-only))))
|
|
|
1346 (assert (number-or-marker-p end))
|
|
|
1347 (goto-char end)))
|
|
|
1348
|
|
|
1349 (defun sgml-edit-attrib-next ()
|
|
|
1350 "Move to next attribute value."
|
|
|
1351 (interactive)
|
|
|
1352 (or (search-forward-regexp "^ *[.A-Za-z0-9---]+ *= ?" nil t)
|
|
|
1353 (goto-char (point-min))))
|
|
|
1354
|
|
|
1355
|
|
|
1356 ;;;; SGML mode: Hiding tags/attributes
|
|
|
1357
|
|
|
1358 (defconst sgml-tag-regexp
|
|
|
1359 "\\(</?>\\|</?[A-Za-z][---A-Za-z0-9.]*\\(\\([^'\"></]\\|'[^']*'\\|\"[^\"]*\"\\)*\\)>?\\)")
|
|
|
1360
|
|
|
1361 (defun sgml-operate-on-tags (action &optional attr-p)
|
|
|
1362 (let ((buffer-modified-p (buffer-modified-p))
|
|
|
1363 (inhibit-read-only t)
|
|
|
1364 (buffer-read-only nil)
|
|
|
1365 (before-change-function nil)
|
|
|
1366 (markup-index ; match-data index in tag regexp
|
|
|
1367 (if attr-p 2 1))
|
|
|
1368 (tagcount ; number tags to give them uniq
|
|
|
1369 ; invisible properties
|
|
|
1370 1))
|
|
|
1371 (unwind-protect
|
|
|
1372 (save-excursion
|
|
|
1373 (goto-char (point-min))
|
|
|
1374 (while (re-search-forward sgml-tag-regexp nil t)
|
|
|
1375 (cond
|
|
|
1376 ((eq action 'hide)
|
|
|
1377 (let ((tag (downcase
|
|
2
|
1378 (buffer-substring-no-properties
|
|
|
1379 (1+ (match-beginning 0))
|
|
|
1380 (match-beginning 2)))))
|
|
0
|
1381 (if (or attr-p (not (member tag sgml-exposed-tags)))
|
|
|
1382 (add-text-properties
|
|
|
1383 (match-beginning markup-index) (match-end markup-index)
|
|
|
1384 (list 'invisible tagcount
|
|
|
1385 'rear-nonsticky '(invisible face))))))
|
|
|
1386 ((eq action 'show) ; ignore markup-index
|
|
|
1387 (remove-text-properties (match-beginning 0) (match-end 0)
|
|
|
1388 '(invisible nil)))
|
|
|
1389 (t (error "Invalid action: %s" action)))
|
|
|
1390 (incf tagcount)))
|
|
|
1391 (set-buffer-modified-p buffer-modified-p))))
|
|
|
1392
|
|
|
1393 (defun sgml-hide-tags ()
|
|
|
1394 "Hide all tags in buffer."
|
|
|
1395 (interactive)
|
|
|
1396 (sgml-operate-on-tags 'hide))
|
|
|
1397
|
|
|
1398 (defun sgml-show-tags ()
|
|
|
1399 "Show hidden tags in buffer."
|
|
|
1400 (interactive)
|
|
|
1401 (sgml-operate-on-tags 'show))
|
|
|
1402
|
|
|
1403 (defun sgml-hide-attributes ()
|
|
|
1404 "Hide all attribute specifications in the buffer."
|
|
|
1405 (interactive)
|
|
|
1406 (sgml-operate-on-tags 'hide 'attributes))
|
|
|
1407
|
|
|
1408 (defun sgml-show-attributes ()
|
|
|
1409 "Show all attribute specifications in the buffer."
|
|
|
1410 (interactive)
|
|
|
1411 (sgml-operate-on-tags 'show 'attributes))
|
|
|
1412
|
|
|
1413
|
|
|
1414 ;;;; SGML mode: Normalize (and misc manipulations)
|
|
|
1415
|
|
|
1416 (defun sgml-expand-shortref-to-text (name)
|
|
|
1417 (let (before-change-function
|
|
|
1418 (entity (sgml-lookup-entity name (sgml-dtd-entities sgml-dtd-info))))
|
|
|
1419 (cond
|
|
|
1420 ((null entity) (sgml-error "Undefined entity %s" name))
|
|
|
1421 ((sgml-entity-data-p entity)
|
|
|
1422 (sgml-expand-shortref-to-entity name))
|
|
|
1423 (t
|
|
|
1424 (delete-region sgml-markup-start (point))
|
|
|
1425 (sgml-entity-insert-text entity)
|
|
|
1426 (setq sgml-goal (point-max)) ; May have changed size of buffer
|
|
|
1427 ;; now parse the entity text
|
|
2
|
1428 (setq sgml-rs-ignore-pos sgml-markup-start)
|
|
|
1429 (goto-char sgml-markup-start)))))
|
|
0
|
1430
|
|
|
1431 (defun sgml-expand-shortref-to-entity (name)
|
|
|
1432 (let ((end (point))
|
|
|
1433 (re-found nil)
|
|
|
1434 before-change-function)
|
|
|
1435 (goto-char sgml-markup-start)
|
|
|
1436 (setq re-found (search-forward "\n" end t))
|
|
|
1437 (delete-region sgml-markup-start end)
|
|
|
1438 (insert "&" name (if re-found "\n" ";"))
|
|
|
1439 (setq sgml-goal (point-max)) ; May have changed size of buffer
|
|
|
1440 (goto-char (setq sgml-rs-ignore-pos sgml-markup-start))))
|
|
|
1441
|
|
|
1442 (defun sgml-expand-all-shortrefs (to-entity)
|
|
|
1443 "Expand all short references in the buffer.
|
|
|
1444 Short references to text entities are expanded to the replacement text
|
|
|
1445 of the entity other short references are expanded into general entity
|
|
|
1446 references. If argument, TO-ENTITY, is non-nil, or if called
|
|
|
1447 interactive with numeric prefix argument, all short references are
|
|
|
1448 replaced by generaly entity references."
|
|
|
1449 (interactive "*P")
|
|
|
1450 (sgml-reparse-buffer
|
|
|
1451 (if to-entity
|
|
|
1452 (function sgml-expand-shortref-to-entity)
|
|
|
1453 (function sgml-expand-shortref-to-text))))
|
|
|
1454
|
|
|
1455 (defun sgml-normalize (to-entity &optional element)
|
|
|
1456 "Normalize buffer by filling in omitted tags and expanding empty tags.
|
|
|
1457 Argument TO-ENTITY controls how short references are expanded as with
|
|
|
1458 `sgml-expand-all-shortrefs'. An optional argument ELEMENT can be the
|
|
|
1459 element to normalize insted of the whole buffer, if used no short
|
|
|
1460 references will be expanded."
|
|
|
1461 (interactive "*P")
|
|
|
1462 (unless element
|
|
|
1463 (sgml-expand-all-shortrefs to-entity))
|
|
|
1464 (let ((only-one (not (null element))))
|
|
|
1465 (setq element (or element (sgml-top-element)))
|
|
|
1466 (goto-char (sgml-element-end element))
|
|
|
1467 (let ((before-change-function nil))
|
|
|
1468 (sgml-normalize-content element only-one)))
|
|
|
1469 (sgml-note-change-at (sgml-element-start element))
|
|
|
1470 (sgml-message "Done"))
|
|
|
1471
|
|
|
1472 (defun sgml-normalize-element ()
|
|
|
1473 (interactive "*")
|
|
|
1474 (sgml-normalize nil (sgml-find-element-of (point))))
|
|
|
1475
|
|
|
1476 (defun sgml-normalize-content (element only-first)
|
|
|
1477 "Normalize all elements in a content where ELEMENT is first element.
|
|
|
1478 If sgml-normalize-trims is non-nil, trim off white space from ends of
|
|
|
1479 elements with omitted end-tags."
|
|
|
1480 (let ((content nil))
|
|
|
1481 (while element ; Build list of content elements
|
|
|
1482 (push element content)
|
|
|
1483 (setq element (if only-first
|
|
|
1484 nil
|
|
|
1485 (sgml-element-next element))))
|
|
|
1486 (while content
|
|
|
1487 (setq element (car content))
|
|
|
1488 ;; Progress report
|
|
|
1489 (sgml-lazy-message "Normalizing %d%% left"
|
|
|
1490 (/ (point) (/ (+ (point-max) 100) 100)))
|
|
|
1491 ;; Fix the end-tag
|
|
|
1492 (sgml-normalize-end-tag element)
|
|
|
1493 ;; Fix tags of content
|
|
|
1494 (sgml-normalize-content (sgml-tree-content element) nil)
|
|
|
1495 ;; Fix the start-tag
|
|
|
1496 (sgml-normalize-start-tag element)
|
|
|
1497 ;; Next content element
|
|
|
1498 (setq content (cdr content)))))
|
|
|
1499
|
|
|
1500 (defun sgml-normalize-start-tag (element)
|
|
|
1501 (when (sgml-bpos-p (sgml-element-stag-epos element))
|
|
|
1502 (goto-char (min (point) (sgml-element-start element)))
|
|
|
1503 (let ((name (sgml-element-gi element))
|
|
|
1504 (attlist (sgml-element-attlist element))
|
|
|
1505 (asl (sgml-element-attribute-specification-list element)))
|
|
|
1506 (save-excursion
|
|
|
1507 (assert (or (zerop (sgml-element-stag-len element))
|
|
|
1508 (= (point) (sgml-element-start element))))
|
|
|
1509 (delete-char (sgml-element-stag-len element))
|
|
|
1510 (sgml-insert-start-tag name asl attlist nil)))))
|
|
|
1511
|
|
|
1512 (defun sgml-normalize-end-tag (element)
|
|
|
1513 (unless (sgml-element-empty element)
|
|
|
1514 (when (sgml-bpos-p (sgml-element-etag-epos element))
|
|
|
1515 (goto-char (min (point) (sgml-element-etag-start element)))
|
|
|
1516 (if (and (zerop (sgml-element-etag-len element))
|
|
|
1517 sgml-normalize-trims)
|
|
|
1518 (skip-chars-backward " \t\n\r"))
|
|
|
1519 (delete-char (sgml-tree-etag-len element))
|
|
2
|
1520 (save-excursion (tempo-process-and-insert-string (sgml-end-tag-of element))))))
|
|
0
|
1521
|
|
|
1522
|
|
|
1523 (defun sgml-make-character-reference (&optional invert)
|
|
|
1524 "Convert character after point into a character reference.
|
|
|
1525 If called with a numeric argument, convert a character reference back
|
|
|
1526 to a normal character. If called from a program, set optional
|
|
|
1527 argument INVERT to non-nil."
|
|
|
1528 (interactive "*P")
|
|
|
1529 (cond
|
|
|
1530 (invert
|
|
|
1531 (or (looking-at "&#\\([0-9]+\\)[;\n]?")
|
|
|
1532 (error "No character reference after point"))
|
|
|
1533 (let ((c (string-to-int (buffer-substring (match-beginning 1)
|
|
|
1534 (match-end 1)))))
|
|
|
1535 (delete-region (match-beginning 0)
|
|
|
1536 (match-end 0))
|
|
|
1537 (insert c)))
|
|
|
1538 ;; Convert character to &#nn;
|
|
|
1539 (t
|
|
|
1540 (let ((c (following-char)))
|
|
|
1541 (delete-char 1)
|
|
|
1542 (insert (format "&#%d;" c))))))
|
|
|
1543
|
|
|
1544 (defun sgml-expand-entity-reference ()
|
|
|
1545 "Insert the text of the entity referenced at point."
|
|
|
1546 (interactive)
|
|
|
1547 (sgml-with-parser-syntax
|
|
|
1548 (setq sgml-markup-start (point))
|
|
|
1549 (sgml-check-delim "ERO")
|
|
|
1550 (let* ((ename (sgml-check-name t))
|
|
|
1551 (entity (sgml-lookup-entity ename
|
|
|
1552 (sgml-dtd-entities
|
|
|
1553 (sgml-pstate-dtd
|
|
|
1554 sgml-buffer-parse-state)))))
|
|
|
1555 (unless entity
|
|
|
1556 (error "Undefined entity %s" ename))
|
|
|
1557 (or (sgml-parse-delim "REFC")
|
|
|
1558 (sgml-parse-RE))
|
|
|
1559 (delete-region sgml-markup-start (point))
|
|
|
1560 (sgml-entity-insert-text entity))))
|
|
|
1561
|
|
|
1562
|
|
|
1563 ;;;; SGML mode: TAB completion
|
|
|
1564
|
|
|
1565 (defun sgml-complete ()
|
|
|
1566 "Complete the word/tag/entity before point.
|
|
|
1567 If it is a tag (starts with < or </) complete with valid tags.
|
|
|
1568 If it is an entity (starts with &) complete with declared entities.
|
|
|
1569 If it is a markup declaration (starts with <!) complete with markup
|
|
|
1570 declaration names.
|
|
|
1571 If it is something else complete with ispell-complete-word."
|
|
|
1572 (interactive "*")
|
|
|
1573 (let ((tab ; The completion table
|
|
|
1574 nil)
|
|
|
1575 (pattern nil)
|
|
|
1576 (c nil)
|
|
|
1577 (here (point)))
|
|
|
1578 (skip-chars-backward "^ \n\t</!&%")
|
|
|
1579 (setq pattern (buffer-substring (point) here))
|
|
|
1580 (setq c (char-after (1- (point))))
|
|
|
1581 (cond
|
|
|
1582 ;; entitiy
|
|
|
1583 ((eq c ?&)
|
|
|
1584 (sgml-need-dtd)
|
|
|
1585 (setq tab
|
|
|
1586 (sgml-entity-completion-table
|
|
|
1587 (sgml-dtd-entities (sgml-pstate-dtd sgml-buffer-parse-state)))))
|
|
|
1588 ;; start-tag
|
|
|
1589 ((eq c ?<)
|
|
|
1590 (save-excursion
|
|
|
1591 (backward-char 1)
|
|
|
1592 (sgml-parse-to-here)
|
|
|
1593 (setq tab (sgml-eltype-completion-table
|
|
|
1594 (sgml-current-list-of-valid-eltypes)))))
|
|
|
1595 ;; end-tag
|
|
|
1596 ((eq c ?/)
|
|
|
1597 (save-excursion
|
|
|
1598 (backward-char 2)
|
|
|
1599 (sgml-parse-to-here)
|
|
|
1600 (setq tab (sgml-eltype-completion-table
|
|
|
1601 (sgml-current-list-of-endable-eltypes)))))
|
|
|
1602 ;; markup declaration
|
|
|
1603 ((eq c ?!)
|
|
|
1604 (setq tab sgml-markup-declaration-table))
|
|
|
1605 (t
|
|
|
1606 (goto-char here)
|
|
|
1607 (ispell-complete-word)))
|
|
|
1608 (when tab
|
|
|
1609 (let ((completion (try-completion pattern tab)))
|
|
|
1610 (cond ((null completion)
|
|
|
1611 (goto-char here)
|
|
|
1612 (message "Can't find completion for \"%s\"" pattern)
|
|
|
1613 (ding))
|
|
|
1614 ((eq completion t)
|
|
|
1615 (goto-char here)
|
|
|
1616 (message "[Complete]"))
|
|
|
1617 ((not (string= pattern completion))
|
|
|
1618 (delete-char (length pattern))
|
|
|
1619 (insert completion))
|
|
|
1620 (t
|
|
|
1621 (goto-char here)
|
|
|
1622 (message "Making completion list...")
|
|
|
1623 (let ((list (all-completions pattern tab)))
|
|
|
1624 (with-output-to-temp-buffer " *Completions*"
|
|
|
1625 (display-completion-list list)))
|
|
|
1626 (message "Making completion list...%s" "done")))))))
|
|
|
1627
|
|
|
1628
|
|
|
1629 ;;;; SGML mode: Options menu
|
|
|
1630
|
|
|
1631 (defun sgml-file-options-menu (&optional event)
|
|
|
1632 (interactive "e")
|
|
|
1633 (sgml-options-menu event sgml-file-options))
|
|
|
1634
|
|
|
1635 (defun sgml-user-options-menu (&optional event)
|
|
|
1636 (interactive "e")
|
|
|
1637 (sgml-options-menu event sgml-user-options))
|
|
|
1638
|
|
|
1639 (defun sgml-options-menu (event vars)
|
|
|
1640 (let ((var
|
|
|
1641 (let ((maxlen
|
|
|
1642 (loop for var in vars
|
|
|
1643 maximize (length (sgml-variable-description var)))))
|
|
|
1644 (sgml-popup-menu
|
|
|
1645 event "Options"
|
|
|
1646 (loop for var in vars
|
|
|
1647 for desc = (sgml-variable-description var)
|
|
|
1648 collect
|
|
|
1649 (cons
|
|
|
1650 (format "%s%s [%s]"
|
|
|
1651 desc
|
|
|
1652 (make-string (- maxlen (length desc)) ? )
|
|
|
1653 (sgml-option-value-indicator var))
|
|
|
1654 var))))))
|
|
|
1655 (when var
|
|
|
1656 (sgml-do-set-option var event))))
|
|
|
1657
|
|
|
1658 (defun sgml-do-set-option (var &optional event)
|
|
|
1659 (let ((type (sgml-variable-type var))
|
|
|
1660 (val (symbol-value var)))
|
|
|
1661 (cond
|
|
|
1662 ((eq 'toggle type)
|
|
|
1663 (message "%s set to %s" var (not val))
|
|
|
1664 (set var (not val)))
|
|
|
1665 ((eq 'string type)
|
|
|
1666 (describe-variable var)
|
|
|
1667 (setq val (read-string (concat (sgml-variable-description var) ": ")))
|
|
|
1668 (when (stringp val)
|
|
|
1669 (set var val)))
|
|
|
1670 ((consp type)
|
|
|
1671 (let ((val
|
|
|
1672 (sgml-popup-menu event
|
|
|
1673 (sgml-variable-description var)
|
|
|
1674 (loop for c in type collect
|
|
|
1675 (cons
|
|
|
1676 (if (consp c) (car c) (format "%s" c))
|
|
|
1677 (if (consp c) (cdr c) c))))))
|
|
|
1678 (set var val)
|
|
|
1679 (message "%s set to %s" var val)))
|
|
|
1680 (t
|
|
|
1681 (describe-variable var)
|
|
|
1682 (setq val (read-string (concat (sgml-variable-description var)
|
|
|
1683 " (sexp): ")))
|
|
|
1684 (when (stringp val)
|
|
|
1685 (set var (car (read-from-string val)))))))
|
|
|
1686 (force-mode-line-update))
|
|
|
1687
|
|
|
1688 (defun sgml-option-value-indicator (var)
|
|
|
1689 (let ((type (sgml-variable-type var))
|
|
|
1690 (val (symbol-value var)))
|
|
|
1691 (cond
|
|
|
1692 ((eq type 'toggle)
|
|
|
1693 (if val "Yes" "No"))
|
|
|
1694 ((eq type 'string)
|
|
|
1695 (if (stringp val)
|
|
|
1696 (substring val 0 4)
|
|
|
1697 "-"))
|
|
|
1698 ((and (atom type) val)
|
|
|
1699 "...")
|
|
|
1700 ((consp type)
|
|
|
1701 (or (car (rassq val type))
|
|
|
1702 val))
|
|
|
1703 (t
|
|
|
1704 "-"))))
|
|
|
1705
|
|
|
1706 ;;;; NEW
|
|
|
1707
|
|
|
1708 (defun sgml-trim-and-leave-element ()
|
|
|
1709 (interactive)
|
|
|
1710 (goto-char (sgml-element-etag-start (sgml-last-element)))
|
|
|
1711 (while (progn (forward-char -1)
|
|
|
1712 (looking-at "\\s-"))
|
|
|
1713 (delete-char 1))
|
|
|
1714 (sgml-up-element))
|
|
|
1715
|
|
|
1716
|
|
|
1717 ;;; psgml-edit.el ends here
|
