Mercurial > hg > xemacs-beta

comparison lisp/utils/edit-toolbar.el @ 173:8eaf7971accc r20-3b13

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
Import from CVS: tag r20-3b13
author cvs
date Mon, 13 Aug 2007 09:49:09 +0200
parents
children e121b013d1f0
comparison
equal deleted inserted replaced
172:a38aed19690b 173:8eaf7971accc
1 ;;; edit-toolbar.el --- Interactive toolbar editing mode for XEmacs
2
3 ;; Copyright (C) 1996 Peter D. Pezaris
4
5 ;; Author: Peter D. Pezaris <pez@dwwc.com>
6 ;; Keywords: tools
7
8 ;; This file is part of XEmacs.
9
10 ;; XEmacs is free software; you can redistribute it and/or modify it
11 ;; under the terms of the GNU General Public License as published by
12 ;; the Free Software Foundation; either version 2, or (at your option)
13 ;; any later version.
14
15 ;; XEmacs is distributed in the hope that it will be useful, but
16 ;; WITHOUT ANY WARRANTY; without even the implied warranty of
17 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
18 ;; General Public License for more details.
19
20 ;; You should have received a copy of the GNU General Public License
21 ;; along with XEmacs; see the file COPYING. If not, write to the Free
22 ;; Software Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA
23 ;; 02111-1307, USA.
24
25 ;;; Synched up with: Not in FSF
26
27 ;;; Commentary:
28
29 ;; To use edit-toolbar.el, simply type M-x edit-toolbar RET
30
31 ;; For help on the various commands you can type ? in a edit-toolbar
32 ;; buffer. To save a modified toolbar type C-x C-s in an edit-toolbar
33 ;; buffer. If you want to use a saved toolbar in your future XEmacs
34 ;; sessions, add the following line of code to your .emacs file:
35
36 ;; (load "~/.xemacs/.toolbar")
37
38 ;; Acknowledgements:
39
40 ;; Many thanks to Stig <stig@hackvan.com> and Ben Wing <wing@666.com>
41 ;; for writing edit-faces.el, on which much of this code is based.
42
43 ;; To do:
44
45 ;; o It would be nice if edit-toolbar could edit *any* toolbar, not just
46 ;; the default one.
47 ;; o The function edit-toolbar-quit should do something other than just
48 ;; bury the buffer.
49 ;; o Dynamically add new items to edit-toolbar-button-alist as new buttons
50 ;; are added.
51
52 ;;; Code:
53
54 (defvar edit-toolbar-version "1.01"
55 "Version of Edit Toolbar.")
56
57 (defvar edit-toolbar-default-toolbar (specifier-instance default-toolbar)
58 "Default toolbar used when reverting.")
59
60 (defvar edit-toolbar-file-name (concat "~"
61 (if (boundp 'emacs-user-extension-dir)
62 emacs-user-extension-dir
63 "/")
64 ".toolbar")
65 "File name to save toolbars to. Defaults to \"~/.xemacs/.toolbar\"")
66
67 (defvar edit-toolbar-menu
68 '("Edit Toolbar"
69 ["Move This Item Up" edit-toolbar-up t]
70 ["Move This Item Down" edit-toolbar-down t]
71 ["Set Function" edit-toolbar-set-function t]
72 ["Set Help String" edit-toolbar-set-help t]
73 ["Remove This Item" edit-toolbar-kill t]
74 "----"
75 ["Add Button..." edit-toolbar-add-button t]
76 ("Add Separator"
77 ["2D (narrow) " edit-toolbar-add-separator-2D-narrow t]
78 ["3D (narrow)" edit-toolbar-add-separator-3D-narrow t]
79 ["2D (wide)" edit-toolbar-add-separator-2D-wide t]
80 ["3D (wide)" edit-toolbar-add-separator-3D-wide t]
81 )
82 "----"
83 ["Restore Default Toolbar " edit-toolbar-restore t]
84 ["Save This Toolbar" edit-toolbar-save t]
85 "----"
86 ["Help" describe-mode t]
87 "----"
88 ["Quit" edit-toolbar-quit t]
89 )
90 )
91
92 (defvar edit-toolbar-map
93 (let ((map (make-sparse-keymap)))
94 (suppress-keymap map)
95 (define-key map "q" 'edit-toolbar-quit)
96 (define-key map "n" 'edit-toolbar-next)
97 (define-key map "p" 'edit-toolbar-previous)
98 (define-key map " " 'edit-toolbar-next)
99 (define-key map "?" 'describe-mode)
100 (define-key map "f" 'edit-toolbar-set-function)
101 (define-key map "h" 'edit-toolbar-set-help)
102 (define-key map "a" 'edit-toolbar-add-button)
103 (define-key map "2" 'edit-toolbar-add-separator-2D-narrow)
104 (define-key map "@" 'edit-toolbar-add-separator-2D-wide)
105 (define-key map "3" 'edit-toolbar-add-separator-3D-narrow)
106 (define-key map "#" 'edit-toolbar-add-separator-3D-wide)
107 (define-key map "c" 'edit-toolbar-copy)
108 (define-key map "d" 'edit-toolbar-down)
109 (define-key map "u" 'edit-toolbar-up)
110 (define-key map "k" 'edit-toolbar-kill)
111 (define-key map "s" 'edit-toolbar-save)
112 (define-key map "\C-x\C-s" 'edit-toolbar-save)
113 (define-key map "r" 'edit-toolbar-restore)
114 (define-key map 'return 'edit-toolbar-next)
115 (define-key map 'delete 'edit-toolbar-previous)
116 map
117 ))
118
119 ;;;###autoload
120 (defun edit-toolbar ()
121 "Alter toolbar characteristics by editing a buffer representing the current toolbar.
122 Pops up a buffer containing a list of the current toobar."
123 (interactive)
124 (pop-to-buffer (get-buffer-create "*Edit Toolbar*"))
125 (edit-toolbar-list)
126 (set-buffer-modified-p nil)
127 (edit-toolbar-mode)
128 (set-face-foreground 'default "black" (current-buffer))
129 (set-face-background 'default "grey75" (current-buffer))
130 (set-face-foreground 'list-mode-item-selected "yellow" (current-buffer))
131 (set-face-background 'list-mode-item-selected "black" (current-buffer)))
132
133 (define-derived-mode edit-toolbar-mode list-mode "Edit-Toolbar"
134 "Major mode for 'edit-toolbar' buffers.
135
136 Editing commands:
137
138 \\{edit-toolbar-map}"
139 (setq mode-popup-menu edit-toolbar-menu)
140 (if current-menubar
141 (progn
142 (set (make-local-variable 'current-menubar)
143 (copy-sequence current-menubar))
144 (add-submenu nil edit-toolbar-menu)))
145 (use-local-map edit-toolbar-map)
146 (setq buffer-read-only nil)
147 (message "Edit Toolbar Version %s. Type \"?\" for help." edit-toolbar-version))
148
149 (defun edit-toolbar-list ()
150 (erase-buffer)
151 (edit-toolbar-insert-item 'header)
152 (let ((ilist (specifier-instance default-toolbar)))
153 (while (setq item (car ilist))
154 (edit-toolbar-insert-item item)
155 (setq ilist (cdr ilist))))
156 (goto-char (point-min)))
157
158 (defun edit-toolbar-quit ()
159 "Quit an Edit Toolbar session. This simply buries the buffer."
160 (interactive)
161 ;;FIXME
162 (bury-buffer))
163
164 (defun edit-toolbar-next ()
165 "Move to the next line in the Edit Toolbar buffer."
166 (interactive)
167 (next-line 1))
168
169 (defun edit-toolbar-previous ()
170 "Move to the previous line in the Edit Toolbar buffer."
171 (interactive)
172 (next-line -1))
173
174 (defun edit-toolbar-set-function (func)
175 "Set the function for the selected toolbar button."
176 (interactive "aNew Function: ")
177 (let ((toolbar (specifier-instance default-toolbar))
178 (index (- (count-lines (point-min) (point)) 2)))
179 (setf (aref (nth index toolbar) 1) func)
180 (edit-toolbar-list)
181 (forward-line (+ index 2))))
182
183 (defun edit-toolbar-set-help (help)
184 "Set the help string for the selected toolbar button."
185 (interactive "sNew Help String: ")
186 (let ((toolbar (specifier-instance default-toolbar))
187 (index (- (count-lines (point-min) (point)) 2)))
188 (setf (aref (nth index toolbar) 3) help)
189 (edit-toolbar-list)
190 (forward-line (+ index 2))))
191
192 (defun edit-toolbar-copy ()
193 "Make a copy of the selected toolbar button."
194 (interactive)
195 (let* ((toolbar (specifier-instance default-toolbar))
196 (index (- (count-lines (point-min) (point)) 2))
197 (item (nth index toolbar)))
198 (setcdr (nthcdr index toolbar)
199 (cons item (nthcdr (1+ index) toolbar)))
200 (edit-toolbar-list)
201 (forward-line (+ index 3))))
202
203 (defun edit-toolbar-down ()
204 "Move the current toolbar button down (right) one position."
205 (interactive)
206 (let* ((toolbar (specifier-instance default-toolbar))
207 (index (- (count-lines (point-min) (point)) 2))
208 (item (nth index toolbar)))
209 (if (eq (1+ index) (length toolbar))
210 (error "Already at the bottom of the toolbar."))
211 (if (eq index 0)
212 (setq toolbar (cdr toolbar))
213 (setcdr (nthcdr (1- index) toolbar)
214 (nthcdr (1+ index) toolbar)))
215 (setcdr (nthcdr index toolbar)
216 (cons item (nthcdr (1+ index) toolbar)))
217 (set-specifier default-toolbar toolbar)
218 (edit-toolbar-list)
219 (forward-line (+ index 3))))
220
221 (defun edit-toolbar-up ()
222 "Move the current toolbar button up (left) one position."
223 (interactive)
224 (let* ((toolbar (specifier-instance default-toolbar))
225 (index (- (count-lines (point-min) (point)) 2))
226 (item (nth index toolbar)))
227 (if (eq index 0)
228 (error "Already at the top of the toolbar."))
229 (setcdr (nthcdr (1- index) toolbar)
230 (nthcdr (1+ index) toolbar))
231 (if (eq index 1)
232 (setq toolbar (cons item toolbar))
233 (setcdr (nthcdr (- index 2) toolbar)
234 (cons item (nthcdr (- index 1) toolbar))))
235 (set-specifier default-toolbar toolbar)
236 (edit-toolbar-list)
237 (forward-line (+ index 1))))
238
239 (defun edit-toolbar-kill ()
240 "Remove the current toolbar button."
241 (interactive)
242 (let* ((toolbar (specifier-instance default-toolbar))
243 (index (- (count-lines (point-min) (point)) 2))
244 (item (nth index toolbar)))
245 (if (eq index 0)
246 (setq toolbar (cdr toolbar))
247 (setcdr (nthcdr (1- index) toolbar)
248 (nthcdr (1+ index) toolbar)))
249 (set-specifier default-toolbar toolbar)
250 (edit-toolbar-list)
251 (forward-line (+ index 2))))
252
253 (defun edit-toolbar-insert-item (item)
254 (let ((line-format "%-30s %s\n")
255 icon function help)
256 (if (eq item 'header)
257 (progn
258 (setq function "Function"
259 help "Help String")
260 (insert-face "Icon\t" 'bold)
261 (insert-face (format line-format function help) 'bold))
262 (cond ((or (eq (aref item 0) :style)
263 (eq (aref item 0) :size))
264 (setq icon nil
265 function "----------------------------------------"
266 help ""))
267 (t
268 (setq icon (if (listp (aref item 0))
269 (car (aref item 0))
270 (car (symbol-value (aref item 0))))
271 function (aref item 1)
272 help (aref item 3))))
273 (let ((st (point))
274 (fn #'(lambda (str callback data)
275 (let ((st1 (point)))
276 (insert str)
277 (add-list-mode-item st1 (point) nil callback data)))))
278 (insert "\t")
279 (funcall fn (format line-format function help) nil item)
280 (set-extent-begin-glyph (make-extent st (point)) icon)))))
281
282 (defun edit-toolbar-create-button-alist ()
283 (let ((button-alist nil)
284 (buttons (specifier-instance default-toolbar)))
285 (while buttons
286 (setq button-alist
287 (cons (cons (symbol-name (aref (car buttons) 1)) (car buttons))
288 button-alist))
289 (setq buttons (cdr buttons)))
290 button-alist))
291
292 (defvar edit-toolbar-button-alist (edit-toolbar-create-button-alist))
293
294 (defun edit-toolbar-add-item (item)
295 "Add a toolbar item ITEM at the current location."
296 (let* ((toolbar (specifier-instance default-toolbar))
297 (index (- (count-lines (point-min) (point)) 2)))
298 (if (eq index 0)
299 (setq toolbar (cons item toolbar))
300 (setcdr (nthcdr (- index 1) toolbar)
301 (cons item (nthcdr index toolbar))))
302 (set-specifier default-toolbar toolbar)
303 (edit-toolbar-list)
304 (forward-line (+ index 2))))
305
306 ;(defun edit-toolbar-check-for-save ()
307 ; (if (not (buffer-modified-p))
308 ; ()
309 ; (if (yes-or-no-p-maybe-dialog-box "
310
311 (defun edit-toolbar-restore ()
312 "Restore the default toolbar."
313 (interactive)
314 ; (edit-toolbar-check-for-save)
315 (set-specifier default-toolbar edit-toolbar-default-toolbar)
316 (edit-toolbar-list)
317 (set-buffer-modified-p nil))
318
319 (defun edit-toolbar-add-separator-2D-narrow ()
320 "Add a narrow 2D separator at the current position."
321 (interactive)
322 (edit-toolbar-add-item [:style 2D]))
323
324 (defun edit-toolbar-add-separator-3D-narrow ()
325 "Add a narrow 3D separator at the current position."
326 (interactive)
327 (edit-toolbar-add-item [:style 3D]))
328
329 (defun edit-toolbar-add-separator-2D-wide ()
330 "Add a wide 2D separator at the current position."
331 (interactive)
332 (edit-toolbar-add-item [:style 2D :size 30]))
333
334 (defun edit-toolbar-add-separator-3D-wide ()
335 "Add a wide 3D separator at the current position."
336 (interactive)
337 (edit-toolbar-add-item [:style 3D :size 30]))
338
339 (defun edit-toolbar-add-button ()
340 "Add a new toolbar item at the current position.
341 Completion is available to the known toolbar buttons."
342 (interactive)
343 (let ((button (completing-read
344 "New Toolbar Button (RET to create a new button): "
345 edit-toolbar-button-alist nil t)))
346 (if (string-equal button "")
347 (let ((prompts '("UP glyph for button: "
348 "DOWN glyph (RET for no glyph): "
349 "DISABLED glyph (RET for no glyph): "
350 "UP CAPTIONED glyph (RET for no glyph): "
351 "DOWN CAPTIONED glyph (RET for no glyph): "
352 "DISABLED CAPTIONED glyph (RET for no glyph): "))
353 (glyphs nil)
354 (count 0))
355 (let ((glyph-file (read-file-name (car prompts) nil "")))
356 (if (string-equal glyph-file "")
357 (error "You must specify at least the UP glyph.")
358 (setq glyphs (list (make-glyph glyph-file)))
359 (setq prompts (cdr prompts))))
360 (while prompts
361 (let ((glyph-file (read-file-name (car prompts) nil "")))
362 (if (not (string-equal glyph-file ""))
363 (setq glyphs
364 (append glyphs (list (make-glyph glyph-file))))))
365 (setq prompts (cdr prompts)))
366 (let ((func (read-string "Function to call: "))
367 (help (read-string "Help String: ")))
368 (setq new-button (vector glyphs (intern func) t help))))
369 (let ((match (assoc button edit-toolbar-button-alist)))
370 (if match
371 (setq new-button (cdr match))
372 (error "Can't find button %s" button))))
373 (edit-toolbar-add-item new-button)))
374
375 (defun edit-toolbar-prompt-for-initialization ()
376 (popup-dialog-box
377 '("Edit Toolbar has created the file ~/.xemacs/.toolbar
378
379 In order for your changes to take effect the next time
380 you start XEmacs, you need to add the following line
381 to the end of your .emacs file:
382
383 (load \"~/.xemacs/.toolbar\")
384
385 Alternatively, I can do this for you now."
386 ["Yes, please\nadd the line\nof code for me." edit-toolbar-add-initialization t]
387 nil
388 ["No thanks,\nI'll take care\nof it myself." ignore t])))
389
390 (defun edit-toolbar-add-initialization ()
391 "Add a line to the end of the user's init file for edit-toolbar use."
392 (interactive)
393 (set-buffer (find-file-noselect user-init-file))
394 (goto-char (point-max))
395 (insert "
396 (if (and (featurep 'toolbar)
397 (fboundp 'console-on-window-system-p)
398 (console-on-window-system-p)
399 (file-exists-p \"" edit-toolbar-file-name "\"))
400 (load-file (expand-file-name \"" edit-toolbar-file-name "\")))
401 ")
402 (save-buffer))
403
404 (defun edit-toolbar-save ()
405 "Save the current toolbar in the file specified by edit-toolbar-file-name."
406 (interactive)
407 (save-excursion
408 (let* ((exists (file-exists-p edit-toolbar-file-name))
409 (buf (find-file-noselect edit-toolbar-file-name))
410 (standard-output buf))
411 (set-buffer buf)
412 (erase-buffer)
413 (insert "(set-specifier default-toolbar '")
414 (prin1 (specifier-instance default-toolbar))
415 (insert ")")
416 (save-buffer)
417 (kill-buffer (current-buffer))
418 (or exists (edit-toolbar-prompt-for-initialization))))
419 (set-buffer-modified-p nil))
420
421 (provide 'edit-toolbar)
422
423 ;;; edit-toolbar.el ends here