|
0
|
1 ;;;; psgml-xemacs.el --- Part of SGML-editing mode with parsing support
|
|
|
2 ;; $Id: psgml-xemacs.el,v 1.1.1.1 1996/12/18 03:35:23 steve Exp $
|
|
|
3
|
|
|
4 ;; Copyright (C) 1994 Lennart Staflin
|
|
|
5
|
|
|
6 ;; Author: Lennart Staflin <lenst@lysator.liu.se>
|
|
|
7 ;; William M. Perry <wmperry@indiana.edu>
|
|
|
8
|
|
|
9 ;;
|
|
|
10 ;; This program is free software; you can redistribute it and/or
|
|
|
11 ;; modify it under the terms of the GNU General Public License
|
|
|
12 ;; as published by the Free Software Foundation; either version 2
|
|
|
13 ;; of the License, or (at your option) any later version.
|
|
|
14 ;;
|
|
|
15 ;; This program is distributed in the hope that it will be useful,
|
|
|
16 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
|
|
|
17 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
|
|
|
18 ;; GNU General Public License for more details.
|
|
|
19 ;;
|
|
|
20 ;; You should have received a copy of the GNU General Public License
|
|
|
21 ;; along with this program; if not, write to the Free Software
|
|
|
22 ;; Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
|
|
|
23
|
|
|
24
|
|
|
25 ;;;; Commentary:
|
|
|
26
|
|
|
27 ;;; Part of psgml.el
|
|
|
28
|
|
|
29 ;;; Menus for use with XEmacs
|
|
|
30
|
|
|
31
|
|
|
32 ;;;; Code:
|
|
|
33
|
|
|
34 (require 'psgml)
|
|
|
35 ;;(require 'easymenu)
|
|
|
36
|
|
|
37 (eval-and-compile
|
|
|
38 (autoload 'sgml-do-set-option "psgml-edit"))
|
|
|
39
|
|
|
40 (defvar sgml-max-menu-size (/ (* (frame-height) 2) 3)
|
|
|
41 "*Max number of entries in Tags and Entities menus before they are split
|
|
|
42 into several panes.")
|
|
|
43
|
|
|
44 ;;;; Pop Up Menus
|
|
|
45
|
|
|
46 (defun sgml-popup-menu (event title entries)
|
|
|
47 "Display a popup menu."
|
|
|
48 (setq entries
|
|
|
49 (loop for ent in entries collect
|
|
|
50 (vector (car ent)
|
|
|
51 (list 'setq 'value (list 'quote (cdr ent)))
|
|
|
52 t)))
|
|
|
53 (cond ((> (length entries) sgml-max-menu-size)
|
|
|
54 (setq entries
|
|
|
55 (loop for i from 1 while entries collect
|
|
|
56 (let ((submenu
|
|
|
57 (subseq entries 0 (min (length entries)
|
|
|
58 sgml-max-menu-size))))
|
|
|
59 (setq entries (nthcdr sgml-max-menu-size
|
|
|
60 entries))
|
|
|
61 (cons
|
|
|
62 (format "%s '%s'-'%s'"
|
|
|
63 title
|
|
|
64 (sgml-range-indicator (aref (car submenu) 0))
|
|
|
65 (sgml-range-indicator
|
|
|
66 (aref (car (last submenu)) 0)))
|
|
|
67 submenu))))))
|
|
|
68 (sgml-xemacs-get-popup-value (cons title entries)))
|
|
|
69
|
|
|
70
|
|
|
71 (defun sgml-range-indicator (string)
|
|
|
72 (substring string
|
|
|
73 0
|
|
|
74 (min (length string) sgml-range-indicator-max-length)))
|
|
|
75
|
|
|
76
|
|
|
77 (defun sgml-xemacs-get-popup-value (menudesc)
|
|
|
78 (let ((value nil)
|
|
|
79 (event nil))
|
|
|
80 (popup-menu menudesc)
|
|
|
81 (while (popup-menu-up-p)
|
|
|
82 (setq event (next-command-event event))
|
|
|
83 (cond ((menu-event-p event)
|
|
|
84 (cond
|
|
|
85 ((eq (event-object event) 'abort)
|
|
|
86 (signal 'quit nil))
|
|
|
87 ((eq (event-object event) 'menu-no-selection-hook)
|
|
|
88 nil)
|
|
|
89 (t
|
|
|
90 (eval (event-object event)))))
|
|
|
91 ((button-release-event-p event) ; don't beep twice
|
|
|
92 nil)
|
|
|
93 ((and (fboundp 'event-matches-key-specifier-p)
|
|
|
94 (event-matches-key-specifier-p event (quit-char)))
|
|
|
95 (signal 'quit nil))
|
|
|
96 (t
|
|
|
97 (beep)
|
|
|
98 (message "please make a choice from the menu."))))
|
|
|
99 value))
|
|
|
100
|
|
|
101 (defun sgml-popup-multi-menu (pos title menudesc)
|
|
|
102 "Display a popup menu.
|
|
|
103 MENUS is a list of menus on the form (TITLE ITEM1 ITEM2 ...).
|
|
|
104 ITEM should have to form (STRING EXPR) or STRING. The EXPR gets evaluated
|
|
|
105 if the item is selected."
|
|
|
106 (popup-menu
|
|
|
107 (cons title
|
|
|
108 (loop for menu in menudesc collect
|
|
|
109 (cons (car menu) ; title
|
|
|
110 (loop for item in (cdr menu) collect
|
|
|
111 (if (stringp item)
|
|
|
112 item
|
|
|
113 (vector (car item) (cadr item) t))))))))
|
|
|
114
|
|
|
115
|
|
|
116 ;;;; XEmacs menu bar
|
|
|
117
|
|
|
118 (defvar sgml-dtd-menu
|
|
|
119 '("DTD"
|
|
|
120 ["Parse DTD" sgml-parse-prolog t]
|
|
|
121 ("Info"
|
|
|
122 ["Describe element type" sgml-describe-element-type t]
|
|
|
123 ["Describe entity" sgml-describe-entity t]
|
|
|
124 ["List elements" sgml-list-elements t]
|
|
|
125 ["List attributes" sgml-list-attributes t]
|
|
|
126 ["List terminals" sgml-list-terminals t]
|
|
|
127 ["List content elements" sgml-list-content-elements t]
|
|
|
128 ["List occur in elements" sgml-list-occur-in-elements t]
|
|
|
129 )
|
|
|
130 "---"
|
|
|
131 ["Load Parsed DTD" sgml-load-dtd t]
|
|
|
132 ["Save Parsed DTD" sgml-save-dtd t]
|
|
|
133 ))
|
|
|
134
|
|
|
135 (defvar sgml-fold-menu
|
|
|
136 '("Fold"
|
|
|
137 ["Fold Element" sgml-fold-element t]
|
|
|
138 ["Fold Subelement" sgml-fold-subelement t]
|
|
|
139 ["Fold Region" sgml-fold-region t]
|
|
|
140 ["Unfold Line" sgml-unfold-line t]
|
|
|
141 ["Unfold Element" sgml-unfold-element t]
|
|
|
142 ["Unfold All" sgml-unfold-all t]
|
|
|
143 ["Expand" sgml-expand-element t]
|
|
|
144 ))
|
|
|
145
|
|
|
146 (defvar sgml-markup-menu
|
|
|
147 '("Markup"
|
|
|
148 ["Insert Element" (sgml-element-menu last-command-event) t]
|
|
|
149 ["Insert Start-Tag" (sgml-start-tag-menu last-command-event) t]
|
|
|
150 ["Insert End-Tag" (sgml-end-tag-menu last-command-event) t]
|
|
|
151 ["Tag Region" (sgml-tag-region-menu last-command-event) t]
|
|
|
152 ["Insert Attribute" (sgml-attrib-menu last-command-event) t]
|
|
|
153 ["Insert Entity" (sgml-entities-menu last-command-event) t]
|
|
|
154 ))
|
|
|
155
|
|
|
156 (defvar
|
|
|
157 sgml-move-menu
|
|
|
158 '("Move"
|
|
|
159 ["Next trouble spot" sgml-next-trouble-spot t]
|
|
|
160 ["Next data field" sgml-next-data-field t]
|
|
|
161 ["Forward element" sgml-forward-element t]
|
|
|
162 ["Backward element" sgml-backward-element t]
|
|
|
163 ["Up element" sgml-up-element t]
|
|
|
164 ["Down element" sgml-down-element t]
|
|
|
165 ["Backward up element" sgml-backward-up-element t]
|
|
|
166 ["Beginning of element" sgml-beginning-of-element t]
|
|
|
167 ["End of element" sgml-end-of-element t]
|
|
|
168 )
|
|
|
169 "Menu of move commands"
|
|
|
170 )
|
|
|
171
|
|
|
172 (defvar
|
|
|
173 sgml-modify-menu
|
|
|
174 '("Modify"
|
|
|
175 ["Normalize" sgml-normalize t]
|
|
|
176 ["Expand All Short References" sgml-expand-all-shortrefs t]
|
|
|
177 ["Expand Entity Reference" sgml-expand-entity-reference t]
|
|
|
178 ["Normalize Element" sgml-normalize-element t]
|
|
|
179 ["Make Character Reference" sgml-make-character-reference t]
|
|
|
180 ["Unmake Character Reference" (sgml-make-character-reference t) t]
|
|
|
181 ["Fill Element" sgml-fill-element t]
|
|
|
182 ["Change Element Name..." sgml-change-element-name t]
|
|
|
183 ["Edit Attributes..." sgml-edit-attributes t]
|
|
|
184 ["Kill Markup" sgml-kill-markup t]
|
|
|
185 ["Kill Element" sgml-kill-element t]
|
|
|
186 ["Untag Element" sgml-untag-element t]
|
|
|
187 ["Decode Character Entities" sgml-charent-to-display-char t]
|
|
|
188 ["Encode Characters" sgml-display-char-to-charent t]
|
|
|
189 )
|
|
|
190 "Menu of modification commands"
|
|
|
191 )
|
|
|
192
|
|
|
193 (defun sgml-make-options-menu (vars)
|
|
|
194 (loop for var in vars
|
|
|
195 for type = (sgml-variable-type var)
|
|
|
196 for desc = (sgml-variable-description var)
|
|
|
197 collect
|
|
|
198 (cond
|
|
|
199 ((eq type 'toggle)
|
|
|
200 (vector desc (list 'setq var (list 'not var))
|
|
|
201 ':style 'toggle ':selected var))
|
|
|
202 ((consp type)
|
|
|
203 (cons desc
|
|
|
204 (loop for c in type collect
|
|
|
205 (if (atom c)
|
|
|
206 (vector (prin1-to-string c)
|
|
|
207 (`(setq (, var) (, c)))
|
|
|
208 :style 'toggle
|
|
|
209 :selected (`(eq (, var) '(, c))))
|
|
|
210 (vector (car c)
|
|
|
211 (`(setq (, var) '(,(cdr c))))
|
|
|
212 :style 'toggle
|
|
|
213 :selected (`(eq (, var) '(,(cdr c)))))))))
|
|
|
214 (t
|
|
|
215 (vector desc
|
|
|
216 (`(sgml-do-set-option '(, var)))
|
|
|
217 t)))))
|
|
|
218
|
|
|
219 (defvar sgml-sgml-menu
|
|
|
220 (append
|
|
|
221 '("SGML"
|
|
|
222 ["Reset Buffer" normal-mode t]
|
|
|
223 ["Show Context" sgml-show-context t]
|
|
|
224 ["What Element" sgml-what-element t]
|
|
|
225 ["Show Valid Tags" sgml-list-valid-tags t]
|
|
|
226 ["Show/Hide Warning Log" sgml-show-or-clear-log t]
|
|
|
227 ["Validate" sgml-validate t])
|
|
|
228 (if (or (not (boundp 'emacs-major-version))
|
|
|
229 (and (boundp 'emacs-minor-version)
|
|
|
230 (< emacs-minor-version 10)))
|
|
|
231 '(
|
|
|
232 ["File Options" sgml-file-options-menu t]
|
|
|
233 ["User Options" sgml-user-options-menu t]
|
|
|
234 )
|
|
|
235 (list
|
|
|
236 (cons "File Options" (sgml-make-options-menu sgml-file-options))
|
|
|
237 (cons "User Options" (sgml-make-options-menu sgml-user-options))))
|
|
|
238 '(["Save File Options" sgml-save-options t]
|
|
|
239 ["Submit Bug Report" sgml-submit-bug-report t]
|
|
|
240 )))
|
|
|
241
|
|
|
242 (defun sgml-install-xemacs-menus ()
|
|
|
243 "Install xemacs menus for psgml mode"
|
|
|
244 (set-buffer-menubar (copy-sequence current-menubar))
|
|
|
245 (add-menu nil (car sgml-sgml-menu) (cdr sgml-sgml-menu))
|
|
|
246 (add-menu nil (car sgml-markup-menu) (copy-sequence (cdr sgml-markup-menu)))
|
|
|
247 (add-menu nil (car sgml-modify-menu) (cdr sgml-modify-menu))
|
|
|
248 (add-menu nil (car sgml-move-menu) (cdr sgml-move-menu))
|
|
|
249 (add-menu nil (car sgml-fold-menu) (cdr sgml-fold-menu))
|
|
|
250 (add-menu nil (car sgml-dtd-menu) (cdr sgml-dtd-menu))
|
|
|
251 )
|
|
|
252
|
|
|
253
|
|
|
254 ;;;; Custom menus
|
|
|
255
|
|
|
256 (defun sgml-build-custom-menus ()
|
|
|
257 (and sgml-custom-markup (add-menu-item '("Markup") "------------" nil t
|
|
|
258 "Insert Element"))
|
|
|
259 (mapcar (function
|
|
|
260 (lambda (x)
|
|
|
261 (add-menu-item '("Markup") (nth 0 x)
|
|
|
262 (list 'sgml-insert-markup (nth 1 x))
|
|
|
263 t
|
|
|
264 "------------")))
|
|
|
265 sgml-custom-markup)
|
|
|
266 (and sgml-custom-dtd (add-menu-item '("DTD") "-------------" nil t))
|
|
|
267 (mapcar (function
|
|
|
268 (lambda (x)
|
|
|
269 (add-menu-item '("DTD") (nth 0 x)
|
|
|
270 (list 'apply ''sgml-doctype-insert
|
|
|
271 (cadr x)
|
|
|
272 (list 'quote (cddr x)))
|
|
|
273 t)))
|
|
|
274 sgml-custom-dtd))
|
|
|
275
|
|
|
276
|
|
|
277 ;;;; Key definitions
|
|
|
278
|
|
|
279 (define-key sgml-mode-map [button3] 'sgml-tags-menu)
|
|
|
280
|
|
|
281
|
|
|
282 ;;;; Insert with properties
|
|
|
283
|
|
|
284 (defun sgml-insert (props format &rest args)
|
|
|
285 (let ((start (point))
|
|
|
286 tem)
|
|
|
287 (insert (apply (function format)
|
|
|
288 format
|
|
|
289 args))
|
|
|
290 (remf props 'rear-nonsticky) ; not useful in XEmacs
|
|
|
291
|
|
|
292 ;; Copy face prop from category
|
|
|
293 (when (setq tem (getf props 'category))
|
|
|
294 (when (setq tem (get tem 'face))
|
|
|
295 (set-face-underline-p (make-face 'underline) t)
|
|
|
296 (setf (getf props 'face) tem)))
|
|
|
297
|
|
|
298 (add-text-properties start (point) props)
|
|
|
299
|
|
|
300 ;; A read-only value of 1 is used for the text after values
|
|
|
301 ;; and this should in XEmacs be open at the front.
|
|
|
302 (if (eq 1 (getf props 'read-only))
|
|
|
303 (set-extent-property
|
|
|
304 (extent-at start nil 'read-only)
|
|
|
305 'start-open t))))
|
|
|
306
|
|
|
307
|
|
|
308 ;;;; Set face of markup
|
|
|
309
|
|
|
310 (defun sgml-set-face-for (start end type)
|
|
|
311 (let ((face (cdr (assq type sgml-markup-faces)))
|
|
|
312 o)
|
|
|
313 (loop for e being the extents from start to end
|
|
|
314 do (when (extent-property e 'type)
|
|
|
315 (cond ((and (null o)
|
|
|
316 (eq type (extent-property e 'type)))
|
|
|
317 (setq o e))
|
|
|
318 (t (delete-extent e)))))
|
|
|
319
|
|
|
320 (cond (o
|
|
|
321 (set-extent-endpoints o start end))
|
|
|
322 (face
|
|
|
323 (setq o (make-extent start end))
|
|
|
324 (set-extent-property o 'type type)
|
|
|
325 (set-extent-property o 'face face)
|
|
|
326 (set-extent-face o face)))))
|
|
|
327
|
|
|
328 (defun sgml-set-face-after-change (start end &optional pre-len)
|
|
|
329 (when sgml-set-face
|
|
|
330 (let ((o (extent-at start nil 'type)))
|
|
|
331 (cond
|
|
|
332 ((null o))
|
|
|
333 ((= start (extent-start-position o))
|
|
|
334 (set-extent-endpoints o end (extent-end-position o)))
|
|
|
335 (t (delete-extent o))))))
|
|
|
336
|
|
|
337 ;(defalias 'next-overlay-at 'next-overlay-change) ; fix bug in cl.el
|
|
|
338
|
|
|
339 (defun sgml-clear-faces ()
|
|
|
340 (interactive)
|
|
|
341 (loop for o being the overlays
|
|
|
342 if (extent-property o 'type)
|
|
|
343 do (delete-extent o)))
|
|
|
344
|
|
|
345
|
|
|
346 ;;;; Functions not in XEmacs
|
|
|
347
|
|
|
348 (unless (fboundp 'frame-width)
|
|
|
349 (defalias 'frame-width 'screen-width))
|
|
|
350
|
|
|
351 (unless (fboundp 'frame-height)
|
|
|
352 (defalias 'frame-height 'screen-height))
|
|
|
353
|
|
|
354 (unless (fboundp 'buffer-substring-no-properties)
|
|
|
355 (defalias 'buffer-substring-no-properties 'buffer-substring))
|
|
|
356
|
|
|
357
|
|
|
358 ;;;; Provide
|
|
|
359
|
|
|
360 (provide 'psgml-xemacs)
|
|
|
361
|
|
|
362
|
|
|
363 ;;; psgml-xemacs.el ends here
|
