Mercurial > hg > xemacs-beta

comparison lisp/x-toolbar.el @ 209:41ff10fd062f r20-4b3

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
Import from CVS: tag r20-4b3
author cvs
date Mon, 13 Aug 2007 10:04:58 +0200
parents
children 1f0dabaa0855
comparison
equal deleted inserted replaced
208:f427b8ec4379 209:41ff10fd062f
1 ;;; x-toolbar.el -- Runtime 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 X and toolbar support is compiled in).
33
34 ;; Miscellaneous toolbar functions, useful for users to redefine, in
35 ;; order to get different behaviour.
36
37 ;;; Code:
38
39 (eval-when-compile
40 (require 'pending-del))
41
42 (defgroup toolbar nil
43 "Configure XEmacs Toolbar functions and properties"
44 :group 'environment)
45
46
47 (defun toolbar-not-configured ()
48 (ding)
49 (message "Configure the item via `M-x customize RET toolbar RET'"))
50
51 (defcustom toolbar-open-function 'find-file
52 "*Function to call when the open icon is selected."
53 :type '(radio (function-item find-file)
54 (function :tag "Other"))
55 :group 'toolbar)
56
57 (defun toolbar-open ()
58 (interactive)
59 (call-interactively toolbar-open-function))
60
61 (defcustom toolbar-dired-function 'dired
62 "*Function to call when the dired icon is selected."
63 :type '(radio (function-item dired)
64 (function :tag "Other"))
65 :group 'toolbar)
66
67 (defun toolbar-dired ()
68 (interactive)
69 (call-interactively toolbar-dired-function))
70
71 (defcustom toolbar-save-function 'save-buffer
72 "*Function to call when the save icon is selected."
73 :type '(radio (function-item save-buffer)
74 (function :tag "Other"))
75 :group 'toolbar)
76
77 (defun toolbar-save ()
78 (interactive)
79 (call-interactively toolbar-save-function))
80
81 (defcustom toolbar-print-function 'lpr-buffer
82 "*Function to call when the print icon is selected."
83 :type '(radio (function-item lpr-buffer)
84 (function :tag "Other"))
85 :group 'toolbar)
86
87 (defun toolbar-print ()
88 (interactive)
89 (call-interactively toolbar-print-function))
90
91 (defcustom toolbar-cut-function 'x-kill-primary-selection
92 "*Function to call when the cut icon is selected."
93 :type '(radio (function-item x-kill-primary-selection)
94 (function :tag "Other"))
95 :group 'toolbar)
96
97 (defun toolbar-cut ()
98 (interactive)
99 (call-interactively toolbar-cut-function))
100
101 (defcustom toolbar-copy-function 'x-copy-primary-selection
102 "*Function to call when the copy icon is selected."
103 :type '(radio (function-item x-copy-primary-selection)
104 (function :tag "Other"))
105 :group 'toolbar)
106
107 (defun toolbar-copy ()
108 (interactive)
109 (call-interactively toolbar-copy-function))
110
111 (defcustom toolbar-paste-function 'x-yank-clipboard-selection
112 "*Function to call when the paste icon is selected."
113 :type '(radio (function-item x-yank-clipboard-selection)
114 (function :tag "Other"))
115 :group 'toolbar)
116
117 (defun toolbar-paste ()
118 (interactive)
119 ;; This horrible kludge is for pending-delete to work correctly.
120 (and (boundp 'pending-delete)
121 pending-delete
122 (let ((this-command toolbar-paste-function))
123 (pending-delete-pre-hook)))
124 (call-interactively toolbar-paste-function))
125
126 (defcustom toolbar-undo-function 'undo
127 "*Function to call when the undo icon is selected."
128 :type '(radio (function-item undo)
129 (function :tag "Other"))
130 :group 'toolbar)
131
132 (defun toolbar-undo ()
133 (interactive)
134 (call-interactively toolbar-undo-function))
135
136 (defcustom toolbar-replace-function 'query-replace
137 "*Function to call when the replace icon is selected."
138 :type '(radio (function-item query-replace)
139 (function :tag "Other"))
140 :group 'toolbar)
141
142 (defun toolbar-replace ()
143 (interactive)
144 (call-interactively toolbar-replace-function))
145
146 ;;
147 ;; toolbar ispell variables and defuns
148 ;;
149
150 (defun toolbar-ispell-internal ()
151 (interactive)
152 (if (region-active-p)
153 (ispell-region (region-beginning) (region-end))
154 (ispell-buffer)))
155
156 (defcustom toolbar-ispell-function 'toolbar-ispell-internal
157 "*Function to call when the ispell icon is selected."
158 :type '(radio (function-item toolbar-ispell-internal)
159 (function :tag "Other"))
160 :group 'toolbar)
161
162 (defun toolbar-ispell ()
163 "Intelligently spell the region or buffer."
164 (interactive)
165 (call-interactively toolbar-ispell-function))
166
167 ;;
168 ;; toolbar mail variables and defuns
169 ;;
170
171 ;; This used to be a macro that expanded its arguments to a form that
172 ;; called `call-process'. With the advent of customize, it's better
173 ;; to have it as a defun, to make customization easier.
174 (defun toolbar-external (process &rest args)
175 (interactive)
176 (apply 'call-process process nil 0 nil args))
177
178 (defcustom toolbar-mail-commands-alist
179 `((not-configured . toolbar-not-configured)
180 (vm . vm)
181 (gnus . gnus-no-server)
182 (rmail . rmail)
183 (mh . mh-rmail)
184 (pine . (toolbar-external "xterm" "-e" "pine")) ; *gag*
185 (elm . (toolbar-external "xterm" "-e" "elm"))
186 (mutt . (toolbar-external "xterm" "-e" "mutt"))
187 (exmh . (toolbar-external "exmh"))
188 (netscape . (toolbar-external "netscape" "mailbox:")))
189 "*Alist of mail readers and their commands.
190 The car of each alist element is the mail reader, and the cdr is the form
191 used to start it."
192 :type '(repeat (cons :format "%v"
193 (symbol :tag "Mailer") (function :tag "Start with")))
194 :group 'toolbar)
195
196 (defcustom toolbar-mail-reader 'not-configured
197 "*Mail reader toolbar will invoke.
198 The legal values are the keys from `toolbar-mail-command-alist', which
199 should be used to add new mail readers.
200 Mail readers known by default are vm, gnus, rmail, mh, pine, elm,
201 mutt, exmh and netscape."
202 :type '(choice (const :tag "Not Configured" not-configured)
203 (const vm) (const gnus) (const rmail) (const mh)
204 (const pine) (const elm) (const mutt) (const exmh)
205 (const netscape)
206 (symbol :tag "Other"
207 :validate (lambda (wid)
208 (if (assq (widget-value wid)
209 toolbar-mail-commands-alist)
210 nil
211 (widget-put wid :error
212 "Unknown mail reader")
213 wid))))
214 :group 'toolbar)
215
216
217 (defun toolbar-mail ()
218 "Run mail in a separate frame."
219 (interactive)
220 (let ((command (assq toolbar-mail-reader toolbar-mail-commands-alist)))
221 (if (not command)
222 (error "Uknown mail reader %s" toolbar-mail-reader))
223 (funcall (cdr command))))
224
225 ;;
226 ;; toolbar info variables and defuns
227 ;;
228
229 (defvar toolbar-info-frame nil
230 "The frame in which info is displayed.")
231
232 (defcustom Info-frame-plist
233 (append (list 'width 80)
234 (let ((h (plist-get default-frame-plist 'height)))
235 (when h (list 'height h))))
236 "Frame plist for the Info frame."
237 :type '(repeat (group :inline t
238 (symbol :tag "Property")
239 (sexp :tag "Value")))
240 :group 'info)
241
242 (defun toolbar-info ()
243 "Run info in a separate frame."
244 (interactive)
245 (if (or (not toolbar-info-frame)
246 (not (frame-live-p toolbar-info-frame)))
247 (progn
248 (setq toolbar-info-frame (make-frame Info-frame-plist))
249 (select-frame toolbar-info-frame)
250 (raise-frame toolbar-info-frame)))
251 (if (frame-iconified-p toolbar-info-frame)
252 (deiconify-frame toolbar-info-frame))
253 (select-frame toolbar-info-frame)
254 (raise-frame toolbar-info-frame)
255 (info))
256
257 ;;
258 ;; toolbar debug variables and defuns
259 ;;
260
261 (defun toolbar-debug ()
262 (interactive)
263 (if (featurep 'eos-debugger)
264 (call-interactively 'eos::start-debugger)
265 (require 'gdbsrc)
266 (call-interactively 'gdbsrc)))
267
268 (defvar compile-command)
269
270 (defun toolbar-compile ()
271 "Run compile without having to touch the keyboard."
272 (interactive)
273 (require 'compile)
274 (popup-dialog-box
275 `(,(concat "Compile:\n " compile-command)
276 ["Compile" (compile compile-command) t]
277 ["Edit command" compile t]
278 nil
279 ["Cancel" (message "Quit") t])))
280
281 ;;
282 ;; toolbar news variables and defuns
283 ;;
284
285 (defcustom toolbar-news-commands-alist
286 `((not-configured . toolbar-not-configured)
287 (gnus . toolbar-gnus) ; M-x all-hail-gnus
288 (rn . (toolbar-external "xterm" "-e" "rn"))
289 (nn . (toolbar-external "xterm" "-e" "nn"))
290 (trn . (toolbar-external "xterm" "-e" "trn"))
291 (xrn . (toolbar-external "xrn"))
292 (slrn . (toolbar-external "xterm" "-e" "slrn"))
293 (pine . (toolbar-external "xterm" "-e" "pine")) ; *gag*
294 (tin . (toolbar-external "xterm" "-e" "tin")) ; *gag*
295 (netscape . (toolbar-external "netscape" "news:")))
296 "*Alist of news readers and their commands.
297 The car of each alist element the pair is the news reader, and the cdr
298 is the form used to start it."
299 :type '(repeat (cons :format "%v"
300 (symbol :tag "Reader") (sexp :tag "Start with")))
301 :group 'toolbar)
302
303 (defcustom toolbar-news-reader 'not-configured
304 "*News reader toolbar will invoke.
305 The legal values are the keys from `toolbar-news-command-alist', which should
306 be used to add new news readers.
307 Newsreaders known by default are gnus, rn, nn, trn, xrn, slrn, pine
308 and netscape."
309 :type '(choice (const :tag "Not Configured" not-configured)
310 (const gnus) (const rn) (const nn) (const trn)
311 (const xrn) (const slrn) (const pine) (const tin)
312 (const netscape)
313 (symbol :tag "Other"
314 :validate (lambda (wid)
315 (if (assq (widget-value wid)
316 toolbar-news-commands-alist)
317 nil
318 (widget-put wid :error
319 "Unknown news reader")
320 wid))))
321 :group 'toolbar)
322
323 (defcustom toolbar-news-use-separate-frame t
324 "*Whether Gnus is invoked in a separate frame."
325 :type 'boolean
326 :group 'toolbar)
327
328 (defvar toolbar-news-frame nil
329 "The frame in which news is displayed.")
330
331 (defvar toolbar-news-frame-properties nil
332 "The properties of the frame in which news is displayed.")
333
334 (defun toolbar-gnus ()
335 "Run Gnus in a separate frame."
336 (interactive)
337 (when (or (not toolbar-news-frame)
338 (not (frame-live-p toolbar-news-frame)))
339 (setq toolbar-news-frame (make-frame toolbar-news-frame-properties))
340 (add-hook 'gnus-exit-gnus-hook
341 (lambda ()
342 (when (frame-live-p toolbar-news-frame)
343 (if (cdr (frame-list))
344 (delete-frame toolbar-news-frame))
345 (setq toolbar-news-frame nil))))
346 (select-frame toolbar-news-frame)
347 (raise-frame toolbar-news-frame)
348 (gnus))
349 (if (frame-iconified-p toolbar-news-frame)
350 (deiconify-frame toolbar-news-frame))
351 (select-frame toolbar-news-frame)
352 (raise-frame toolbar-news-frame))
353
354 (defun toolbar-news ()
355 "Run News (in a separate frame??)."
356 (interactive)
357 (let ((command (assq toolbar-news-reader toolbar-news-commands-alist)))
358 (if (not command)
359 (error "Unknown news reader %s" toolbar-news-reader))
360 (funcall (cdr command))))
361
362 (defvar toolbar-last-win-icon nil "A `last-win' icon set.")
363 (defvar toolbar-next-win-icon nil "A `next-win' icon set.")
364 (defvar toolbar-file-icon nil "A `file' icon set.")
365 (defvar toolbar-folder-icon nil "A `folder' icon set")
366 (defvar toolbar-disk-icon nil "A `disk' icon set.")
367 (defvar toolbar-printer-icon nil "A `printer' icon set.")
368 (defvar toolbar-cut-icon nil "A `cut' icon set.")
369 (defvar toolbar-copy-icon nil "A `copy' icon set.")
370 (defvar toolbar-paste-icon nil "A `paste' icon set.")
371 (defvar toolbar-undo-icon nil "An `undo' icon set.")
372 (defvar toolbar-spell-icon nil "A `spell' icon set.")
373 (defvar toolbar-replace-icon nil "A `replace' icon set.")
374 (defvar toolbar-mail-icon nil "A `mail' icon set.")
375 (defvar toolbar-info-icon nil "An `info' icon set.")
376 (defvar toolbar-compile-icon nil "A `compile' icon set.")
377 (defvar toolbar-debug-icon nil "A `debugger' icon set.")
378 (defvar toolbar-news-icon nil "A `news' icon set.")
379
380 ;;; each entry maps a variable to the prefix used.
381
382 (defvar init-x-toolbar-list
383 '((toolbar-last-win-icon . "last-win")
384 (toolbar-next-win-icon . "next-win")
385 (toolbar-file-icon . "file")
386 (toolbar-folder-icon . "folder")
387 (toolbar-disk-icon . "disk")
388 (toolbar-printer-icon . "printer")
389 (toolbar-cut-icon . "cut")
390 (toolbar-copy-icon . "copy")
391 (toolbar-paste-icon . "paste")
392 (toolbar-undo-icon . "undo")
393 (toolbar-spell-icon . "spell")
394 (toolbar-replace-icon . "replace")
395 (toolbar-mail-icon . "mail")
396 (toolbar-info-icon . "info-def")
397 (toolbar-compile-icon . "compile")
398 (toolbar-debug-icon . "debug")
399 (toolbar-news-icon . "news")))
400
401 (defun init-x-toolbar ()
402 (toolbar-add-item-data init-x-toolbar-list )
403 ;; do this now because errors will occur if the icon symbols
404 ;; are not initted
405 (set-specifier default-toolbar initial-toolbar-spec))
406
407 (defun toolbar-add-item-data ( icon-list &optional icon-dir )
408 (if (eq icon-dir nil)
409 (setq icon-dir toolbar-icon-directory))
410 (mapcar
411 (lambda (cons)
412 (let ((prefix (expand-file-name (cdr cons) icon-dir)))
413 (set (car cons)
414 (if (featurep 'xpm)
415 (toolbar-make-button-list
416 (concat prefix "-up.xpm")
417 nil
418 (concat prefix "-xx.xpm")
419 (concat prefix "-cap-up.xpm")
420 nil
421 (concat prefix "-cap-xx.xpm"))
422 (toolbar-make-button-list
423 (concat prefix "-up.xbm")
424 (concat prefix "-dn.xbm")
425 (concat prefix "-xx.xbm")
426 )))))
427 icon-list )
428 )
429
430 (defvar initial-toolbar-spec
431 '(;;[toolbar-last-win-icon pop-window-configuration
432 ;;(frame-property (selected-frame)
433 ;; 'window-config-stack) t "Most recent window config"]
434 ;; #### Illicit knowledge?
435 ;; #### These don't work right - not consistent!
436 ;; I don't know what's wrong; perhaps `selected-frame' is wrong
437 ;; sometimes when this is evaluated. Note that I even tried to
438 ;; kludge-fix this by calls to `set-specifier-dirty-flag' in
439 ;; pop-window-configuration and such.
440
441 ;;[toolbar-next-win-icon unpop-window-configuration
442 ;;(frame-property (selected-frame)
443 ;; 'window-config-unpop-stack) t "Undo \"Most recent window config\""]
444 ;; #### Illicit knowledge?
445
446 [toolbar-file-icon toolbar-open t "Open a file"]
447 [toolbar-folder-icon toolbar-dired t "View directory"]
448 [toolbar-disk-icon toolbar-save t "Save buffer"]
449 [toolbar-printer-icon toolbar-print t "Print buffer"]
450 [toolbar-cut-icon toolbar-cut t "Kill region"]
451 [toolbar-copy-icon toolbar-copy t "Copy region"]
452 [toolbar-paste-icon toolbar-paste t "Paste from clipboard"]
453 [toolbar-undo-icon toolbar-undo t "Undo edit"]
454 [toolbar-spell-icon toolbar-ispell t "Spellcheck"]
455 [toolbar-replace-icon toolbar-replace t "Replace text"]
456 [toolbar-mail-icon toolbar-mail t "Mail"]
457 [toolbar-info-icon toolbar-info t "Information"]
458 [toolbar-compile-icon toolbar-compile t "Compile"]
459 [toolbar-debug-icon toolbar-debug t "Debug"]
460 [toolbar-news-icon toolbar-news t "News"]
461 )
462 "The initial toolbar for a buffer.")
463
464 (defun x-init-toolbar-from-resources (locale)
465 (x-init-specifier-from-resources
466 top-toolbar-height 'natnum locale
467 '("topToolBarHeight" . "TopToolBarHeight"))
468 (x-init-specifier-from-resources
469 bottom-toolbar-height 'natnum locale
470 '("bottomToolBarHeight" . "BottomToolBarHeight"))
471 (x-init-specifier-from-resources
472 left-toolbar-width 'natnum locale
473 '("leftToolBarWidth" . "LeftToolBarWidth"))
474 (x-init-specifier-from-resources
475 right-toolbar-width 'natnum locale
476 '("rightToolBarWidth" . "RightToolBarWidth")))
477
478 ;;; x-toolbar.el ends here