Mercurial > hg > xemacs-beta

comparison lisp/vm/vm-toolbar.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 49a24b4fd526
comparison
equal deleted inserted replaced
-1:000000000000 0:376386a54a3c
1 ;;; Toolbar related functions and commands
2 ;;; Copyright (C) 1995 Kyle E. Jones
3 ;;;
4 ;;; This program is free software; you can redistribute it and/or modify
5 ;;; it under the terms of the GNU General Public License as published by
6 ;;; the Free Software Foundation; either version 1, or (at your option)
7 ;;; any later version.
8 ;;;
9 ;;; This program is distributed in the hope that it will be useful,
10 ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
11 ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
12 ;;; GNU General Public License for more details.
13 ;;;
14 ;;; You should have received a copy of the GNU General Public License
15 ;;; along with this program; if not, write to the Free Software
16 ;;; Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
17
18 (provide 'vm-toolbar)
19
20 (defvar vm-toolbar-specifier nil)
21 (defvar vm-toolbar nil)
22
23 (defvar vm-toolbar-next-button
24 [vm-toolbar-next-icon
25 vm-toolbar-next-command
26 (vm-toolbar-any-messages-p)
27 "Go to the next message.\n
28 The command `vm-toolbar-next-command' is run, which is normally
29 bound to `vm-next-message'.
30 You can make this button run some other command by using a Lisp
31 s-expression like this one in your .vm file:
32 (fset 'vm-toolbar-next-command 'some-other-command)"])
33 (defvar vm-toolbar-next-icon nil)
34 (or (fboundp 'vm-toolbar-next-command)
35 (fset 'vm-toolbar-next-command 'vm-next-message))
36
37 (defvar vm-toolbar-previous-button
38 [vm-toolbar-previous-icon
39 vm-toolbar-previous-command
40 (vm-toolbar-any-messages-p)
41 "Go to the previous message.\n
42 The command `vm-toolbar-previous-command' is run, which is normally
43 bound to `vm-previous-message'.
44 You can make this button run some other command by using a Lisp
45 s-expression like this one in your .vm file:
46 (fset 'vm-toolbar-previous-command 'some-other-command)"])
47 (defvar vm-toolbar-previous-icon nil)
48 (or (fboundp 'vm-toolbar-previous-command)
49 (fset 'vm-toolbar-previous-command 'vm-previous-message))
50
51 (defvar vm-toolbar-autofile-button
52 [vm-toolbar-autofile-icon
53 vm-toolbar-autofile-message
54 (vm-toolbar-can-autofile-p)
55 "Save the current message to a folder selected using vm-auto-folder-alist."])
56 (defvar vm-toolbar-autofile-icon nil)
57
58 (defvar vm-toolbar-file-button
59 [vm-toolbar-file-icon vm-toolbar-file-command (vm-toolbar-any-messages-p)
60 "Save the current message to a folder.\n
61 The command `vm-toolbar-file-command' is run, which is normally
62 bound to `vm-save-message'.
63 You can make this button run some other command by using a Lisp
64 s-expression like this one in your .vm file:
65 (fset 'vm-toolbar-file-command 'some-other-command)"])
66 (defvar vm-toolbar-file-icon nil)
67 (or (fboundp 'vm-toolbar-file-command)
68 (fset 'vm-toolbar-file-command 'vm-save-message))
69
70 (defvar vm-toolbar-print-button
71 [vm-toolbar-print-icon
72 vm-toolbar-print-command
73 (vm-toolbar-any-messages-p)
74 "Print the current message.\n
75 The command `vm-toolbar-print-command' is run, which is normally
76 bound to `vm-print-message'.
77 You can make this button run some other command by using a Lisp
78 s-expression like this one in your .vm file:
79 (fset 'vm-toolbar-print-command 'some-other-command)"])
80 (defvar vm-toolbar-print-icon nil)
81 (or (fboundp 'vm-toolbar-print-command)
82 (fset 'vm-toolbar-print-command 'vm-print-message))
83
84 (defvar vm-toolbar-visit-button
85 [vm-toolbar-visit-icon vm-toolbar-visit-command t
86 "Visit a different folder.\n
87 The command `vm-toolbar-visit-command' is run, which is normally
88 bound to `vm-visit-folder'.
89 You can make this button run some other command by using a Lisp
90 s-expression like this one in your .vm file:
91 (fset 'vm-toolbar-visit-command 'some-other-command)"])
92 (defvar vm-toolbar-visit-icon nil)
93 (or (fboundp 'vm-toolbar-visit-command)
94 (fset 'vm-toolbar-visit-command 'vm-visit-folder))
95
96 (defvar vm-toolbar-reply-button
97 [vm-toolbar-reply-icon
98 vm-toolbar-reply-command
99 (vm-toolbar-any-messages-p)
100 "Reply to the current message.\n
101 The command `vm-toolbar-reply-command' is run, which is normally
102 bound to `vm-followup-include-text'.
103 You can make this button run some other command by using a Lisp
104 s-expression like this one in your .vm file:
105 (fset 'vm-toolbar-reply-command 'some-other-command)"])
106 (defvar vm-toolbar-reply-icon nil)
107 (or (fboundp 'vm-toolbar-reply-command)
108 (fset 'vm-toolbar-reply-command 'vm-followup-include-text))
109
110 (defvar vm-toolbar-compose-button
111 [vm-toolbar-compose-icon vm-toolbar-compose-command t
112 "Compose a new message.\n
113 The command `vm-toolbar-compose-command' is run, which is normally
114 bound to `vm-mail'.
115 You can make this button run some other command by using a Lisp
116 s-expression like this one in your .vm file:
117 (fset 'vm-toolbar-compose-command 'some-other-command)"])
118 (defvar vm-toolbar-compose-icon nil)
119 (or (fboundp 'vm-toolbar-compose-command)
120 (fset 'vm-toolbar-compose-command 'vm-mail))
121
122 (defvar vm-toolbar-delete-icon nil)
123
124 (defvar vm-toolbar-undelete-icon nil)
125
126 (defvar vm-toolbar-delete/undelete-button
127 [vm-toolbar-delete/undelete-icon
128 vm-toolbar-delete/undelete-message
129 (vm-toolbar-any-messages-p)
130 "Delete the current message, or undelete it if it is already deleted."])
131 (defvar vm-toolbar-delete/undelete-icon nil)
132 (make-variable-buffer-local 'vm-toolbar-delete/undelete-icon)
133
134 (defvar vm-toolbar-help-icon nil)
135
136 (defvar vm-toolbar-recover-icon nil)
137
138 (defvar vm-toolbar-helper-icon nil)
139 (make-variable-buffer-local 'vm-toolbar-helper-icon)
140
141 (defvar vm-toolbar-help-button
142 [vm-toolbar-helper-icon vm-toolbar-helper-command t
143 "Don't Panic.\n
144 VM uses this button to offer help if you're in trouble.
145 Under normal circumstances, this button runs `vm-help'.\n
146 If the current folder looks out-of-date relative to its auto-save
147 file then this button will run `recover-file'."])
148
149 (defvar vm-toolbar-helper-command nil)
150 (make-variable-buffer-local 'vm-toolbar-helper-command)
151
152 (defun vm-toolbar-helper-command ()
153 (interactive)
154 (setq this-command vm-toolbar-helper-command)
155 (call-interactively vm-toolbar-helper-command))
156
157 (defvar vm-toolbar-quit-button
158 [vm-toolbar-quit-icon vm-toolbar-quit-command t
159 "Quit VM.\n
160 The command `vm-toolbar-quit-command' is run, which is normally
161 bound to `vm-quit'.
162 You can make this button run some other command by using a Lisp
163 s-expression like this one in your .vm file:
164 (fset 'vm-toolbar-quit-command 'some-other-command)"])
165 (defvar vm-toolbar-quit-icon nil)
166 (or (fboundp 'vm-toolbar-quit-command)
167 (fset 'vm-toolbar-quit-command 'vm-quit))
168
169 (defun vm-toolbar-any-messages-p ()
170 (save-excursion
171 (vm-check-for-killed-folder)
172 (vm-select-folder-buffer)
173 vm-message-list))
174
175 (defun vm-toolbar-delete/undelete-message (&optional prefix-arg)
176 (interactive "P")
177 (vm-follow-summary-cursor)
178 (vm-select-folder-buffer)
179 (vm-check-for-killed-summary)
180 (vm-error-if-folder-read-only)
181 (vm-error-if-folder-empty)
182 (let ((current-prefix-arg prefix-arg))
183 (if (vm-deleted-flag (car vm-message-pointer))
184 (call-interactively 'vm-undelete-message)
185 (call-interactively 'vm-delete-message))))
186
187 (defun vm-toolbar-can-autofile-p ()
188 (interactive)
189 (save-excursion
190 (vm-check-for-killed-folder)
191 (vm-select-folder-buffer)
192 (and vm-message-pointer
193 (vm-auto-select-folder vm-message-pointer vm-auto-folder-alist))))
194
195 (defun vm-toolbar-autofile-message ()
196 (interactive)
197 (vm-follow-summary-cursor)
198 (vm-select-folder-buffer)
199 (vm-check-for-killed-summary)
200 (vm-error-if-folder-read-only)
201 (vm-error-if-folder-empty)
202 (let ((file (vm-auto-select-folder vm-message-pointer vm-auto-folder-alist)))
203 (if file
204 (progn
205 (vm-save-message file 1)
206 (message "Message saved to %s" file))
207 (error "No match for message in vm-auto-folder-alist."))))
208
209 (defun vm-toolbar-can-recover-p ()
210 (save-excursion
211 (vm-check-for-killed-folder)
212 (vm-select-folder-buffer)
213 (and vm-folder-read-only
214 buffer-file-name
215 buffer-auto-save-file-name
216 (null (buffer-modified-p))
217 (file-newer-than-file-p
218 buffer-auto-save-file-name
219 buffer-file-name))))
220
221 (defun vm-toolbar-update-toolbar ()
222 (if (and vm-message-pointer (vm-deleted-flag (car vm-message-pointer)))
223 (setq vm-toolbar-delete/undelete-icon vm-toolbar-undelete-icon)
224 (setq vm-toolbar-delete/undelete-icon vm-toolbar-delete-icon))
225 (cond ((vm-toolbar-can-recover-p)
226 (setq vm-toolbar-helper-command 'recover-file
227 vm-toolbar-helper-icon vm-toolbar-recover-icon))
228 (t
229 (setq vm-toolbar-helper-command 'vm-help
230 vm-toolbar-helper-icon vm-toolbar-help-icon)))
231 (if vm-summary-buffer
232 (vm-copy-local-variables vm-summary-buffer
233 'vm-toolbar-delete/undelete-icon
234 'vm-toolbar-helper-command
235 'vm-toolbar-helper-icon))
236 (and vm-toolbar-specifier
237 (progn
238 (let ((locale (if (memq 'vm-delete-buffer-frame kill-buffer-hook)
239 (selected-frame)
240 (current-buffer))))
241 (set-specifier vm-toolbar-specifier (cons locale nil))
242 (set-specifier vm-toolbar-specifier (cons locale vm-toolbar))))))
243
244 (defun vm-toolbar-install-toolbar ()
245 (vm-toolbar-initialize)
246 (let ((toolbar (vm-toolbar-make-toolbar-spec))
247 (height (+ 4 (glyph-height (car vm-toolbar-help-icon))))
248 (width (+ 4 (glyph-width (car vm-toolbar-help-icon))))
249 (locale (if (memq 'vm-delete-buffer-frame kill-buffer-hook)
250 (selected-frame)
251 (current-buffer))))
252 (setq vm-toolbar toolbar)
253 (cond ((eq vm-toolbar-orientation 'right)
254 (setq vm-toolbar-specifier right-toolbar)
255 (set-specifier right-toolbar (cons locale toolbar))
256 (set-specifier right-toolbar-width (cons (selected-frame) width)))
257 ((eq vm-toolbar-orientation 'left)
258 (setq vm-toolbar-specifier left-toolbar)
259 (set-specifier left-toolbar (cons locale toolbar))
260 (set-specifier left-toolbar-width (cons (selected-frame) width)))
261 ((eq vm-toolbar-orientation 'bottom)
262 (setq vm-toolbar-specifier bottom-toolbar)
263 (set-specifier bottom-toolbar (cons locale toolbar))
264 (set-specifier bottom-toolbar-height (cons (selected-frame)
265 height)))
266 (t
267 (setq vm-toolbar-specifier top-toolbar)
268 (set-specifier top-toolbar (cons locale toolbar))
269 (set-specifier top-toolbar-height (cons (selected-frame)
270 height))))))
271
272 (defun vm-toolbar-make-toolbar-spec ()
273 (let ((button-alist '(
274 (autofile . vm-toolbar-autofile-button)
275 (compose . vm-toolbar-compose-button)
276 (delete/undelete . vm-toolbar-delete/undelete-button)
277 (file . vm-toolbar-file-button)
278 (help . vm-toolbar-help-button)
279 (next . vm-toolbar-next-button)
280 (previous . vm-toolbar-previous-button)
281 (print . vm-toolbar-print-button)
282 (quit . vm-toolbar-quit-button)
283 (reply . vm-toolbar-reply-button)
284 (visit . vm-toolbar-visit-button)
285 ))
286 (button-list vm-use-toolbar)
287 cons
288 (toolbar nil))
289 (while button-list
290 (if (null (car button-list))
291 (setq toolbar (cons nil toolbar))
292 (setq cons (assq (car button-list) button-alist))
293 (if cons
294 (setq toolbar (cons (symbol-value (cdr cons)) toolbar))))
295 (setq button-list (cdr button-list)))
296 (nreverse toolbar) ))
297
298 (defun vm-toolbar-initialize ()
299 ;; drag these in now instead of waiting for them to be
300 ;; autoloaded. the "loading..." messages could come at a bad
301 ;; moment and wipe an important echo area message, like "Auto
302 ;; save file is newer..."
303 (require 'vm-save)
304 (require 'vm-summary)
305 (cond
306 ((null vm-toolbar-help-icon)
307 (let ((tuples
308 (if (featurep 'xpm)
309 '(
310 (vm-toolbar-next-icon "next-up.xpm" "next-dn.xpm" "next-dn.xpm")
311 (vm-toolbar-previous-icon "previous-up.xpm" "previous-dn.xpm"
312 "previous-dn.xpm")
313 (vm-toolbar-delete-icon "delete-up.xpm" "delete-dn.xpm" "delete-dn.xpm")
314 (vm-toolbar-undelete-icon "undelete-up.xpm" "undelete-dn.xpm"
315 "undelete-dn.xpm")
316 (vm-toolbar-autofile-icon "autofile-up.xpm" "autofile-dn.xpm"
317 "autofile-dn.xpm")
318 (vm-toolbar-file-icon "file-up.xpm" "file-dn.xpm" "file-dn.xpm")
319 (vm-toolbar-reply-icon "reply-up.xpm" "reply-dn.xpm" "reply-dn.xpm")
320 (vm-toolbar-compose-icon "compose-up.xpm" "compose-dn.xpm" "compose-dn.xpm")
321 (vm-toolbar-print-icon "print-up.xpm" "print-dn.xpm" "print-dn.xpm")
322 (vm-toolbar-visit-icon "visit-up.xpm" "visit-dn.xpm" "visit-dn.xpm")
323 (vm-toolbar-quit-icon "quit-up.xpm" "quit-dn.xpm" "quit-dn.xpm")
324 (vm-toolbar-help-icon "help-up.xpm" "help-dn.xpm" "help-dn.xpm")
325 (vm-toolbar-recover-icon "recover-up.xpm" "recover-dn.xpm" "recover-dn.xpm")
326 )
327 '(
328 (vm-toolbar-next-icon "next-up.xbm" "next-dn.xbm" "next-xx.xbm")
329 (vm-toolbar-previous-icon "previous-up.xbm" "previous-dn.xbm"
330 "previous-xx.xbm")
331 (vm-toolbar-delete-icon "delete-up.xbm" "delete-dn.xbm" "delete-xx.xbm")
332 (vm-toolbar-undelete-icon "undelete-up.xbm" "undelete-dn.xbm"
333 "undelete-xx.xbm")
334 (vm-toolbar-autofile-icon "autofile-up.xbm" "autofile-dn.xbm"
335 "autofile-xx.xbm")
336 (vm-toolbar-file-icon "file-up.xbm" "file-dn.xbm" "file-xx.xbm")
337 (vm-toolbar-reply-icon "reply-up.xbm" "reply-dn.xbm" "reply-xx.xbm")
338 (vm-toolbar-compose-icon "compose-up.xbm" "compose-dn.xbm" "compose-xx.xbm")
339 (vm-toolbar-print-icon "print-up.xbm" "print-dn.xbm" "print-xx.xbm")
340 (vm-toolbar-visit-icon "visit-up.xbm" "visit-dn.xbm" "visit-xx.xbm")
341 (vm-toolbar-quit-icon "quit-up.xbm" "quit-dn.xbm" "quit-xx.xbm")
342 (vm-toolbar-help-icon "help-up.xbm" "help-dn.xbm" "help-xx.xpm")
343 (vm-toolbar-recover-icon "recover-up.xbm" "recover-dn.xbm" "recover-xx.xpm")
344 )))
345 tuple files var)
346 (if (not (file-directory-p vm-toolbar-pixmap-directory))
347 (error "Bad toolbar pixmap directory: %s"
348 vm-toolbar-pixmap-directory)
349 (while tuples
350 (setq tuple (car tuples)
351 var (car tuple)
352 files (cdr tuple))
353 (set var (mapcar
354 (function
355 (lambda (f)
356 (make-glyph
357 (expand-file-name f vm-toolbar-pixmap-directory))))
358 files))
359 (setq tuples (cdr tuples)))))))
360 (setq vm-toolbar-delete/undelete-icon vm-toolbar-delete-icon)
361 (setq vm-toolbar-helper-command 'vm-help)
362 (setq vm-toolbar-helper-icon vm-toolbar-help-icon))