Mercurial > hg > xemacs-beta

comparison lisp/psgml/psgml-xemacs.el @ 0:376386a54a3c r19-14

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
Import from CVS: tag r19-14
author cvs
date Mon, 13 Aug 2007 08:45:50 +0200
parents
children ac2d302a0011
comparison
equal deleted inserted replaced
-1:000000000000 0:376386a54a3c
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