comparison lisp/toolbar-items.el @ 282:c42ec1d1cded r21-0b39

Import from CVS: tag r21-0b39
author cvs
date Mon, 13 Aug 2007 10:33:18 +0200
parents
children 558f606b08ae
comparison
equal deleted inserted replaced
281:090b52736db2 282:c42ec1d1cded
1 ;;; toolbar-items.el -- Static initialization of XEmacs toolbar
2
3 ;; Copyright (C) 1997 Free Software Foundation, Inc.
4 ;; Copyright (C) 1994 Andy Piper <andyp@parallax.demon.co.uk>
5 ;; Copyright (C) 1995 Board of Trustees, University of Illinois
6 ;; Copyright (C) 1996 Ben Wing <wing@666.com>
7
8 ;; Maintainer: XEmacs development team
9 ;; Keywords: frames, dumped
10
11 ;; This file is part of XEmacs.
12
13 ;; XEmacs is free software; you can redistribute it and/or modify it
14 ;; under the terms of the GNU General Public License as published by
15 ;; the Free Software Foundation; either version 2, or (at your option)
16 ;; any later version.
17
18 ;; XEmacs is distributed in the hope that it will be useful, but
19 ;; WITHOUT ANY WARRANTY; without even the implied warranty of
20 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
21 ;; General Public License for more details.
22
23 ;; You should have received a copy of the GNU General Public License
24 ;; along with XEmacs; see the file COPYING. If not, write to the
25 ;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
26 ;; Boston, MA 02111-1307, USA.
27
28 ;;; Synched up: Not in FSF
29
30 ;;; Commentary:
31
32 ;; This file is dumped with XEmacs (when window system and toolbar support
33 ;; is compiled in).
34
35 ;; Miscellaneous toolbar functions, useful for users to redefine, in
36 ;; order to get different behaviour.
37
38 ;;; Code:
39
40 ;; Suppress warning message from bytecompiler
41 (eval-when-compile
42 (defvar pending-delete-mode))
43
44 (defgroup toolbar nil
45 "Configure XEmacs Toolbar functions and properties"
46 :group 'environment)
47
48
49 (defun toolbar-not-configured ()
50 (interactive)
51 ;; Note: we don't use `susbtitute-command-keys' here, because
52 ;; Customize is bound to `C-h C' by default, and that binding is not
53 ;; familiar to people. This is more descriptive.
54 (error
55 "Configure the item via `M-x customize RET toolbar RET'"))
56
57 (defcustom toolbar-open-function 'find-file
58 "*Function to call when the open icon is selected."
59 :type '(radio (function-item find-file)
60 (function :tag "Other"))
61 :group 'toolbar)
62
63 (defun toolbar-open ()
64 (interactive)
65 (call-interactively toolbar-open-function))
66
67 (defcustom toolbar-dired-function 'dired
68 "*Function to call when the dired icon is selected."
69 :type '(radio (function-item dired)
70 (function :tag "Other"))
71 :group 'toolbar)
72
73 (defun toolbar-dired ()
74 (interactive)
75 (call-interactively toolbar-dired-function))
76
77 (defcustom toolbar-save-function 'save-buffer
78 "*Function to call when the save icon is selected."
79 :type '(radio (function-item save-buffer)
80 (function :tag "Other"))
81 :group 'toolbar)
82
83 (defun toolbar-save ()
84 (interactive)
85 (call-interactively toolbar-save-function))
86
87 (defcustom toolbar-print-function 'lpr-buffer
88 "*Function to call when the print icon is selected."
89 :type '(radio (function-item lpr-buffer)
90 (function :tag "Other"))
91 :group 'toolbar)
92
93 (defun toolbar-print ()
94 (interactive)
95 (call-interactively toolbar-print-function))
96
97 (defcustom toolbar-cut-function 'kill-primary-selection
98 "*Function to call when the cut icon is selected."
99 :type '(radio (function-item kill-primary-selection)
100 (function :tag "Other"))
101 :group 'toolbar)
102
103 (defun toolbar-cut ()
104 (interactive)
105 (call-interactively toolbar-cut-function))
106
107 (defcustom toolbar-copy-function 'copy-primary-selection
108 "*Function to call when the copy icon is selected."
109 :type '(radio (function-item copy-primary-selection)
110 (function :tag "Other"))
111 :group 'toolbar)
112
113 (defun toolbar-copy ()
114 (interactive)
115 (call-interactively toolbar-copy-function))
116
117 (defcustom toolbar-paste-function 'yank-clipboard-selection
118 "*Function to call when the paste icon is selected."
119 :type '(radio (function-item yank-clipboard-selection)
120 (function :tag "Other"))
121 :group 'toolbar)
122
123 (defun toolbar-paste ()
124 (interactive)
125 ;; This horrible kludge is for pending-delete to work correctly.
126 (and (boundp 'pending-delete-mode)
127 pending-delete-mode
128 (let ((this-command toolbar-paste-function))
129 (pending-delete-pre-hook)))
130 (call-interactively toolbar-paste-function))
131
132 (defcustom toolbar-undo-function 'undo
133 "*Function to call when the undo icon is selected."
134 :type '(radio (function-item undo)
135 (function :tag "Other"))
136 :group 'toolbar)
137
138 (defun toolbar-undo ()
139 (interactive)
140 (call-interactively toolbar-undo-function))
141
142 (defcustom toolbar-replace-function 'query-replace
143 "*Function to call when the replace icon is selected."
144 :type '(radio (function-item query-replace)
145 (function :tag "Other"))
146 :group 'toolbar)
147
148 (defun toolbar-replace ()
149 (interactive)
150 (call-interactively toolbar-replace-function))
151
152 ;;
153 ;; toolbar ispell variables and defuns
154 ;;
155
156 (defun toolbar-ispell-internal ()
157 (interactive)
158 (cond
159 ((region-active-p) (ispell-region (region-beginning) (region-end)))
160 ((eq major-mode 'mail-mode) (ispell-message))
161 ((eq major-mode 'message-mode) (ispell-message))
162 (t (ispell-buffer))))
163
164 (defcustom toolbar-ispell-function 'toolbar-ispell-internal
165 "*Function to call when the ispell icon is selected."
166 :type '(radio (function-item toolbar-ispell-internal)
167 (function :tag "Other"))
168 :group 'toolbar)
169
170 (defun toolbar-ispell ()
171 "Intelligently spell the region or buffer."
172 (interactive)
173 (call-interactively toolbar-ispell-function))
174
175 ;;
176 ;; toolbar mail variables and defuns
177 ;;
178
179 ;; This used to be a macro that expanded its arguments to a form that
180 ;; called `call-process'. With the advent of customize, it's better
181 ;; to have it as a defun, to make customization easier.
182 (defun toolbar-external (process &rest args)
183 (interactive)
184 (apply 'call-process process nil 0 nil args))
185
186 (defcustom toolbar-mail-commands-alist
187 `((not-configured . toolbar-not-configured)
188 (vm . vm)
189 (gnus . gnus-no-server)
190 (rmail . rmail)
191 (mh . mh-rmail)
192 (pine . (toolbar-external "xterm" "-e" "pine")) ; *gag*
193 (elm . (toolbar-external "xterm" "-e" "elm"))
194 (mutt . (toolbar-external "xterm" "-e" "mutt"))
195 (exmh . (toolbar-external "exmh"))
196 (netscape . (toolbar-external "netscape" "mailbox:"))
197 (send . mail))
198 "*Alist of mail readers and their commands.
199 The car of each alist element is the mail reader, and the cdr is the form
200 used to start it."
201 :type '(repeat (cons :format "%v"
202 (symbol :tag "Mailer") (function :tag "Start with")))
203 :group 'toolbar)
204
205 (defcustom toolbar-mail-reader 'not-configured
206 "*Mail reader toolbar will invoke.
207 The legal values are the keys from `toolbar-mail-command-alist', which
208 should be used to add new mail readers.
209 Mail readers known by default are vm, gnus, rmail, mh, pine, elm,
210 mutt, exmh, netscape and send."
211 :type '(choice (const :tag "Not Configured" not-configured)
212 (const vm) (const gnus) (const rmail) (const mh)
213 (const pine) (const elm) (const mutt) (const exmh)
214 (const netscape)
215 (const send)
216 (symbol :tag "Other"
217 :validate (lambda (wid)
218 (if (assq (widget-value wid)
219 toolbar-mail-commands-alist)
220 nil
221 (widget-put wid :error
222 "Unknown mail reader")
223 wid))))
224 :group 'toolbar)
225
226
227 (defun toolbar-mail ()
228 "Run mail in a separate frame."
229 (interactive)
230 (let ((command (cdr (assq toolbar-mail-reader toolbar-mail-commands-alist))))
231 (or command
232 (error "Uknown mail reader %s" toolbar-mail-reader))
233 (if (symbolp command)
234 (call-interactively command)
235 (eval command))))
236
237 ;;
238 ;; toolbar info variables and defuns
239 ;;
240
241 (defcustom toolbar-info-use-separate-frame t
242 "*Whether Info is invoked in a separate frame."
243 :type 'boolean
244 :group 'toolbar)
245
246 (defcustom toolbar-info-frame-plist
247 ;; Info pages are 80 characters wide, so it makes a good default.
248 `(width 80 ,@(let ((h (plist-get default-frame-plist 'height)))
249 (and h `(height ,h))))
250 "*The properties of the frame in which news is displayed."
251 :type 'plist
252 :group 'info)
253
254 (define-obsolete-variable-alias 'Info-frame-plist
255 'toolbar-info-frame-plist)
256
257 (defvar toolbar-info-frame nil
258 "The frame in which info is displayed.")
259
260 (defun toolbar-info ()
261 "Run info in a separate frame."
262 (interactive)
263 (when toolbar-info-use-separate-frame
264 (cond ((or (not toolbar-info-frame)
265 (not (frame-live-p toolbar-info-frame)))
266 ;; We used to raise frame here, but it's a bad idea,
267 ;; because raising is a matter of WM policy. However, we
268 ;; *must* select it, to ensure that the info buffer goes to
269 ;; the right frame.
270 (setq toolbar-info-frame (make-frame toolbar-info-frame-plist))
271 (select-frame toolbar-info-frame))
272 (t
273 ;; However, if the frame already exists, and the user
274 ;; clicks on info, it's OK to raise it.
275 (select-frame toolbar-info-frame)
276 (raise-frame toolbar-info-frame)))
277 (when (frame-iconified-p toolbar-info-frame)
278 (deiconify-frame toolbar-info-frame)))
279 (info))
280
281 ;;
282 ;; toolbar debug variables and defuns
283 ;;
284
285 (defun toolbar-debug ()
286 (interactive)
287 (if (featurep 'eos-debugger)
288 (call-interactively 'eos::start-debugger)
289 (require 'gdbsrc)
290 (call-interactively 'gdbsrc)))
291
292 (defvar compile-command)
293 (defvar toolbar-compile-already-run nil)
294
295 (defun toolbar-compile ()
296 "Run compile without having to touch the keyboard."
297 (interactive)
298 (require 'compile)
299 (if toolbar-compile-already-run
300 (compile compile-command)
301 (setq toolbar-compile-already-run t)
302 (popup-dialog-box
303 `(,(concat "Compile:\n " compile-command)
304 ["Compile" (compile compile-command) t]
305 ["Edit command" compile t]
306 nil
307 ["Cancel" (message "Quit") t]))))
308
309 ;;
310 ;; toolbar news variables and defuns
311 ;;
312
313 (defcustom toolbar-news-commands-alist
314 `((not-configured . toolbar-not-configured)
315 (gnus . toolbar-gnus) ; M-x all-hail-gnus
316 (rn . (toolbar-external "xterm" "-e" "rn"))
317 (nn . (toolbar-external "xterm" "-e" "nn"))
318 (trn . (toolbar-external "xterm" "-e" "trn"))
319 (xrn . (toolbar-external "xrn"))
320 (slrn . (toolbar-external "xterm" "-e" "slrn"))
321 (pine . (toolbar-external "xterm" "-e" "pine")) ; *gag*
322 (tin . (toolbar-external "xterm" "-e" "tin")) ; *gag*
323 (netscape . (toolbar-external "netscape" "news:")))
324 "*Alist of news readers and their commands.
325 The car of each alist element the pair is the news reader, and the cdr
326 is the form used to start it."
327 :type '(repeat (cons :format "%v"
328 (symbol :tag "Reader") (sexp :tag "Start with")))
329 :group 'toolbar)
330
331 (defcustom toolbar-news-reader 'not-configured
332 "*News reader toolbar will invoke.
333 The legal values are the keys from `toolbar-news-command-alist', which should
334 be used to add new news readers.
335 Newsreaders known by default are gnus, rn, nn, trn, xrn, slrn, pine
336 and netscape."
337 :type '(choice (const :tag "Not Configured" not-configured)
338 (const gnus) (const rn) (const nn) (const trn)
339 (const xrn) (const slrn) (const pine) (const tin)
340 (const netscape)
341 (symbol :tag "Other"
342 :validate (lambda (wid)
343 (if (assq (widget-value wid)
344 toolbar-news-commands-alist)
345 nil
346 (widget-put wid :error
347 "Unknown news reader")
348 wid))))
349 :group 'toolbar)
350
351 (defcustom toolbar-news-use-separate-frame t
352 "*Whether Gnus is invoked in a separate frame."
353 :type 'boolean
354 :group 'toolbar)
355
356 (defvar toolbar-news-frame nil
357 "The frame in which news is displayed.")
358
359 (defcustom toolbar-news-frame-plist nil
360 "*The properties of the frame in which news is displayed."
361 :type 'plist
362 :group 'toolbar)
363
364 (define-obsolete-variable-alias 'toolbar-news-frame-properties
365 'toolbar-news-frame-plist)
366
367 (defun toolbar-gnus ()
368 "Run Gnus in a separate frame."
369 (interactive)
370 (if (not toolbar-news-use-separate-frame)
371 (gnus)
372 (unless (frame-live-p toolbar-news-frame)
373 (setq toolbar-news-frame (make-frame toolbar-news-frame-properties))
374 (add-hook 'gnus-exit-gnus-hook
375 (lambda ()
376 (when (frame-live-p toolbar-news-frame)
377 (if (cdr (frame-list))
378 (delete-frame toolbar-news-frame))
379 (setq toolbar-news-frame nil))))
380 (select-frame toolbar-news-frame)
381 (gnus))
382 (when (framep toolbar-news-frame)
383 (when (frame-iconified-p toolbar-news-frame)
384 (deiconify-frame toolbar-news-frame))
385 (select-frame toolbar-news-frame)
386 (raise-frame toolbar-news-frame))))
387
388 (defun toolbar-news ()
389 "Run News."
390 (interactive)
391 (let ((command (cdr-safe
392 (assq toolbar-news-reader toolbar-news-commands-alist))))
393 (or command
394 (error "Unkown news reader %s" toolbar-news-reader))
395 (if (symbolp command)
396 (call-interactively command)
397 (eval command))))
398
399 (defvar toolbar-last-win-icon nil "A `last-win' icon set.")
400 (defvar toolbar-next-win-icon nil "A `next-win' icon set.")
401 (defvar toolbar-file-icon nil "A `file' icon set.")
402 (defvar toolbar-folder-icon nil "A `folder' icon set")
403 (defvar toolbar-disk-icon nil "A `disk' icon set.")
404 (defvar toolbar-printer-icon nil "A `printer' icon set.")
405 (defvar toolbar-cut-icon nil "A `cut' icon set.")
406 (defvar toolbar-copy-icon nil "A `copy' icon set.")
407 (defvar toolbar-paste-icon nil "A `paste' icon set.")
408 (defvar toolbar-undo-icon nil "An `undo' icon set.")
409 (defvar toolbar-spell-icon nil "A `spell' icon set.")
410 (defvar toolbar-replace-icon nil "A `replace' icon set.")
411 (defvar toolbar-mail-icon nil "A `mail' icon set.")
412 (defvar toolbar-info-icon nil "An `info' icon set.")
413 (defvar toolbar-compile-icon nil "A `compile' icon set.")
414 (defvar toolbar-debug-icon nil "A `debugger' icon set.")
415 (defvar toolbar-news-icon nil "A `news' icon set.")
416
417 ;;; each entry maps a variable to the prefix used.
418
419 (defvar init-x-toolbar-list
420 '((toolbar-last-win-icon . "last-win")
421 (toolbar-next-win-icon . "next-win")
422 (toolbar-file-icon . "file")
423 (toolbar-folder-icon . "folder")
424 (toolbar-disk-icon . "disk")
425 (toolbar-printer-icon . "printer")
426 (toolbar-cut-icon . "cut")
427 (toolbar-copy-icon . "copy")
428 (toolbar-paste-icon . "paste")
429 (toolbar-undo-icon . "undo")
430 (toolbar-spell-icon . "spell")
431 (toolbar-replace-icon . "replace")
432 (toolbar-mail-icon . "mail")
433 (toolbar-info-icon . "info-def")
434 (toolbar-compile-icon . "compile")
435 (toolbar-debug-icon . "debug")
436 (toolbar-news-icon . "news")))
437
438 (defun init-x-toolbar ()
439 (toolbar-add-item-data init-x-toolbar-list )
440 ;; do this now because errors will occur if the icon symbols
441 ;; are not initted
442 (set-specifier default-toolbar initial-toolbar-spec))
443
444 (defun toolbar-add-item-data ( icon-list &optional icon-dir )
445 (if (eq icon-dir nil)
446 (setq icon-dir toolbar-icon-directory))
447 (mapcar
448 (lambda (cons)
449 (let ((prefix (expand-file-name (cdr cons) icon-dir)))
450 (set (car cons)
451 (if (featurep 'xpm)
452 (toolbar-make-button-list
453 (concat prefix "-up.xpm")
454 nil
455 (concat prefix "-xx.xpm")
456 (concat prefix "-cap-up.xpm")
457 nil
458 (concat prefix "-cap-xx.xpm"))
459 (toolbar-make-button-list
460 (concat prefix "-up.xbm")
461 (concat prefix "-dn.xbm")
462 (concat prefix "-xx.xbm")
463 )))))
464 icon-list )
465 )
466
467 (defvar toolbar-vector-open
468 [toolbar-file-icon toolbar-open t "Open a file"]
469 "Define the vector for the \"Open\" toolbar button")
470
471 (defvar toolbar-vector-dired
472 [toolbar-folder-icon toolbar-dired t "View directory"]
473 "Define the vector for the \"Dired\" toolbar button")
474
475 (defvar toolbar-vector-save
476 [toolbar-disk-icon toolbar-save t "Save buffer"]
477 "Define the vector for the \"Save\" toolbar button")
478
479 (defvar toolbar-vector-print
480 [toolbar-printer-icon toolbar-print t "Print buffer"]
481 "Define the vector for the \"Printer\" toolbar button")
482
483 (defvar toolbar-vector-cut
484 [toolbar-cut-icon toolbar-cut t "Kill region"]
485 "Define the vector for the \"Cut\" toolbar button")
486
487 (defvar toolbar-vector-copy
488 [toolbar-copy-icon toolbar-copy t "Copy region"]
489 "Define the vector for the \"Copy\" toolbar button")
490
491 (defvar toolbar-vector-paste
492 [toolbar-paste-icon toolbar-paste t "Paste from clipboard"]
493 "Define the vector for the \"Paste\" toolbar button")
494
495 (defvar toolbar-vector-undo
496 [toolbar-undo-icon toolbar-undo t "Undo edit"]
497 "Define the vector for the \"Undo\" toolbar button")
498
499 (defvar toolbar-vector-spell
500 [toolbar-spell-icon toolbar-ispell t "Spellcheck"]
501 "Define the vector for the \"Spell\" toolbar button")
502
503 (defvar toolbar-vector-replace
504 [toolbar-replace-icon toolbar-replace t "Replace text"]
505 "Define the vector for the \"Replace\" toolbar button")
506
507 (defvar toolbar-vector-mail
508 [toolbar-mail-icon toolbar-mail t "Mail"]
509 "Define the vector for the \"Mail\" toolbar button")
510
511 (defvar toolbar-vector-info
512 [toolbar-info-icon toolbar-info t "Information"]
513 "Define the vector for the \"Info\" toolbar button")
514
515 (defvar toolbar-vector-compile
516 [toolbar-compile-icon toolbar-compile t "Compile"]
517 "Define the vector for the \"Compile\" toolbar button")
518
519 (defvar toolbar-vector-debug
520 [toolbar-debug-icon toolbar-debug t "Debug"]
521 "Define the vector for the \"Debug\" toolbar button")
522
523 (defvar toolbar-vector-news
524 [toolbar-news-icon toolbar-news t "News"]
525 "Define the vector for the \"News\" toolbar button")
526
527 (defvar initial-toolbar-spec
528 (list
529 ;;[toolbar-last-win-icon pop-window-configuration
530 ;;(frame-property (selected-frame)
531 ;; 'window-config-stack) t "Most recent window config"]
532 ;; #### Illicit knowledge?
533 ;; #### These don't work right - not consistent!
534 ;; I don't know what's wrong; perhaps `selected-frame' is wrong
535 ;; sometimes when this is evaluated. Note that I even tried to
536 ;; kludge-fix this by calls to `set-specifier-dirty-flag' in
537 ;; pop-window-configuration and such.
538
539 ;;[toolbar-next-win-icon unpop-window-configuration
540 ;;(frame-property (selected-frame)
541 ;; 'window-config-unpop-stack) t "Undo \"Most recent window config\""]
542 ;; #### Illicit knowledge?
543 toolbar-vector-open
544 toolbar-vector-dired
545 toolbar-vector-save
546 toolbar-vector-print
547 toolbar-vector-cut
548 toolbar-vector-copy
549 toolbar-vector-paste
550 toolbar-vector-undo
551 toolbar-vector-spell
552 toolbar-vector-replace
553 toolbar-vector-mail
554 toolbar-vector-info
555 toolbar-vector-compile
556 toolbar-vector-debug
557 toolbar-vector-news
558 )
559 "The initial toolbar for a buffer.")
560
561 (defun x-init-toolbar-from-resources (locale)
562 (x-init-specifier-from-resources
563 top-toolbar-height 'natnum locale
564 '("topToolBarHeight" . "TopToolBarHeight"))
565 (x-init-specifier-from-resources
566 bottom-toolbar-height 'natnum locale
567 '("bottomToolBarHeight" . "BottomToolBarHeight"))
568 (x-init-specifier-from-resources
569 left-toolbar-width 'natnum locale
570 '("leftToolBarWidth" . "LeftToolBarWidth"))
571 (x-init-specifier-from-resources
572 right-toolbar-width 'natnum locale
573 '("rightToolBarWidth" . "RightToolBarWidth"))
574 (x-init-specifier-from-resources
575 top-toolbar-border-width 'natnum locale
576 '("topToolBarBorderWidth" . "TopToolBarBorderWidth"))
577 (x-init-specifier-from-resources
578 bottom-toolbar-border-width 'natnum locale
579 '("bottomToolBarBorderWidth" . "BottomToolBarBorderWidth"))
580 (x-init-specifier-from-resources
581 left-toolbar-border-width 'natnum locale
582 '("leftToolBarBorderWidth" . "LeftToolBarBorderWidth"))
583 (x-init-specifier-from-resources
584 right-toolbar-border-width 'natnum locale
585 '("rightToolBarBorderWidth" . "RightToolBarBorderWidth")))
586
587 ;;; toolbar-items.el ends here