|
1
by Manoj Srivastava
Import upstream version 7.03 |
1 |
;;; Toolbar related functions and commands
|
2 |
;;; Copyright (C) 1995-1997, 2000, 2001 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 |
||
|
1.1.1
by Manoj Srivastava
Import upstream version 7.18 |
18 |
;;(provide 'vm-toolbar)
|
|
1
by Manoj Srivastava
Import upstream version 7.03 |
19 |
|
20 |
(defvar vm-toolbar-specifier nil) |
|
21 |
||
22 |
(defvar vm-toolbar-next-button |
|
23 |
[vm-toolbar-next-icon |
|
24 |
vm-toolbar-next-command
|
|
25 |
(vm-toolbar-any-messages-p) |
|
26 |
"Go to the next message.\n
|
|
27 |
The command `vm-toolbar-next-command' is run, which is normally |
|
28 |
fbound to `vm-next-message'. |
|
29 |
You can make this button run some other command by using a Lisp
|
|
30 |
s-expression like this one in your .vm file:
|
|
31 |
(fset 'vm-toolbar-next-command 'some-other-command)"]) |
|
32 |
(defvar vm-toolbar-next-icon nil) |
|
33 |
(or (fboundp 'vm-toolbar-next-command) |
|
34 |
(fset 'vm-toolbar-next-command 'vm-next-message)) |
|
35 |
||
36 |
(defvar vm-toolbar-previous-button |
|
37 |
[vm-toolbar-previous-icon |
|
38 |
vm-toolbar-previous-command
|
|
39 |
(vm-toolbar-any-messages-p) |
|
40 |
"Go to the previous message.\n
|
|
41 |
The command `vm-toolbar-previous-command' is run, which is normally |
|
42 |
fbound to `vm-previous-message'. |
|
43 |
You can make this button run some other command by using a Lisp
|
|
44 |
s-expression like this one in your .vm file:
|
|
45 |
(fset 'vm-toolbar-previous-command 'some-other-command)"]) |
|
46 |
(defvar vm-toolbar-previous-icon nil) |
|
47 |
(or (fboundp 'vm-toolbar-previous-command) |
|
48 |
(fset 'vm-toolbar-previous-command 'vm-previous-message)) |
|
49 |
||
50 |
(defvar vm-toolbar-autofile-button |
|
51 |
[vm-toolbar-autofile-icon |
|
52 |
vm-toolbar-autofile-message
|
|
53 |
(vm-toolbar-can-autofile-p) |
|
54 |
"Save the current message to a folder selected using vm-auto-folder-alist."]) |
|
55 |
(defvar vm-toolbar-autofile-icon nil) |
|
56 |
||
57 |
(defvar vm-toolbar-file-button |
|
58 |
[vm-toolbar-file-icon vm-toolbar-file-command (vm-toolbar-any-messages-p) |
|
59 |
"Save the current message to a folder.\n
|
|
60 |
The command `vm-toolbar-file-command' is run, which is normally |
|
61 |
fbound to `vm-save-message'. |
|
62 |
You can make this button run some other command by using a Lisp
|
|
63 |
s-expression like this one in your .vm file:
|
|
64 |
(fset 'vm-toolbar-file-command 'some-other-command)"]) |
|
65 |
(defvar vm-toolbar-file-icon nil) |
|
66 |
(or (fboundp 'vm-toolbar-file-command) |
|
67 |
(fset 'vm-toolbar-file-command 'vm-save-message)) |
|
68 |
||
69 |
(defvar vm-toolbar-getmail-button |
|
70 |
[vm-toolbar-getmail-icon vm-toolbar-getmail-command |
|
71 |
(vm-toolbar-mail-waiting-p) |
|
72 |
"Retrieve spooled mail for the current folder.\n
|
|
73 |
The command `vm-toolbar-getmail-command' is run, which is normally |
|
74 |
fbound to `vm-get-new-mail'. |
|
75 |
You can make this button run some other command by using a Lisp
|
|
76 |
s-expression like this one in your .vm file:
|
|
77 |
(fset 'vm-toolbar-getmail-command 'some-other-command)"]) |
|
78 |
(defvar vm-toolbar-getmail-icon nil) |
|
79 |
(or (fboundp 'vm-toolbar-getmail-command) |
|
80 |
(fset 'vm-toolbar-getmail-command 'vm-get-new-mail)) |
|
81 |
||
82 |
(defvar vm-toolbar-print-button |
|
83 |
[vm-toolbar-print-icon |
|
84 |
vm-toolbar-print-command
|
|
85 |
(vm-toolbar-any-messages-p) |
|
86 |
"Print the current message.\n
|
|
87 |
The command `vm-toolbar-print-command' is run, which is normally |
|
88 |
fbound to `vm-print-message'. |
|
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-print-command 'some-other-command)"]) |
|
92 |
(defvar vm-toolbar-print-icon nil) |
|
93 |
(or (fboundp 'vm-toolbar-print-command) |
|
94 |
(fset 'vm-toolbar-print-command 'vm-print-message)) |
|
95 |
||
96 |
(defvar vm-toolbar-visit-button |
|
97 |
[vm-toolbar-visit-icon vm-toolbar-visit-command t |
|
98 |
"Visit a different folder.\n
|
|
99 |
The command `vm-toolbar-visit-command' is run, which is normally |
|
100 |
fbound to `vm-visit-folder'. |
|
101 |
You can make this button run some other command by using a Lisp
|
|
102 |
s-expression like this one in your .vm file:
|
|
103 |
(fset 'vm-toolbar-visit-command 'some-other-command)"]) |
|
104 |
(defvar vm-toolbar-visit-icon nil) |
|
105 |
(or (fboundp 'vm-toolbar-visit-command) |
|
106 |
(fset 'vm-toolbar-visit-command 'vm-visit-folder)) |
|
107 |
||
108 |
(defvar vm-toolbar-reply-button |
|
109 |
[vm-toolbar-reply-icon |
|
110 |
vm-toolbar-reply-command
|
|
111 |
(vm-toolbar-any-messages-p) |
|
112 |
"Reply to the current message.\n
|
|
113 |
The command `vm-toolbar-reply-command' is run, which is normally |
|
114 |
fbound to `vm-followup-include-text'. |
|
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-reply-command 'some-other-command)"]) |
|
118 |
(defvar vm-toolbar-reply-icon nil) |
|
119 |
(or (fboundp 'vm-toolbar-reply-command) |
|
120 |
(fset 'vm-toolbar-reply-command 'vm-followup-include-text)) |
|
121 |
||
122 |
(defvar vm-toolbar-compose-button |
|
123 |
[vm-toolbar-compose-icon vm-toolbar-compose-command t |
|
124 |
"Compose a new message.\n
|
|
125 |
The command `vm-toolbar-compose-command' is run, which is normally |
|
126 |
fbound to `vm-mail'. |
|
127 |
You can make this button run some other command by using a Lisp
|
|
128 |
s-expression like this one in your .vm file:
|
|
129 |
(fset 'vm-toolbar-compose-command 'some-other-command)"]) |
|
130 |
(defvar vm-toolbar-compose-icon nil) |
|
131 |
(or (fboundp 'vm-toolbar-compose-command) |
|
132 |
(fset 'vm-toolbar-compose-command 'vm-mail)) |
|
133 |
||
134 |
(defvar vm-toolbar-decode-mime-button |
|
135 |
[vm-toolbar-decode-mime-icon vm-toolbar-decode-mime-command |
|
136 |
(vm-toolbar-can-decode-mime-p) |
|
137 |
"Decode the MIME objects in the current message.\n
|
|
138 |
The objects might be displayed immediately, or buttons might be
|
|
139 |
displayed that you need to click on to view the object. See the
|
|
140 |
documentation for the variables vm-mime-internal-content-types
|
|
141 |
and vm-mime-external-content-types-alist to see how to control
|
|
142 |
whether you see buttons or objects.\n
|
|
143 |
The command `vm-toolbar-decode-mime-command' is run, which is normally |
|
144 |
fbound to `vm-decode-mime-messages'. |
|
145 |
You can make this button run some other command by using a Lisp
|
|
146 |
s-expression like this one in your .vm file:
|
|
147 |
(fset 'vm-toolbar-decode-mime-command 'some-other-command)"]) |
|
148 |
(defvar vm-toolbar-decode-mime-icon nil) |
|
149 |
(or (fboundp 'vm-toolbar-decode-mime-command) |
|
150 |
(fset 'vm-toolbar-decode-mime-command 'vm-decode-mime-message)) |
|
151 |
||
152 |
;; The values of these two are used by the FSF Emacs toolbar
|
|
153 |
;; code. The values don't matter as long as they are different
|
|
154 |
;; (as compared with eq). Under XEmacs these values are ignored
|
|
155 |
;; and overwritten.
|
|
156 |
(defvar vm-toolbar-delete-icon t) |
|
157 |
(defvar vm-toolbar-undelete-icon nil) |
|
158 |
||
159 |
(defvar vm-toolbar-delete/undelete-button |
|
160 |
[vm-toolbar-delete/undelete-icon |
|
161 |
vm-toolbar-delete/undelete-message
|
|
162 |
(vm-toolbar-any-messages-p) |
|
163 |
"Delete the current message, or undelete it if it is already deleted."]) |
|
164 |
(defvar vm-toolbar-delete/undelete-icon nil) |
|
165 |
(make-variable-buffer-local 'vm-toolbar-delete/undelete-icon) |
|
166 |
||
167 |
(defvar vm-toolbar-help-icon nil) |
|
168 |
||
169 |
(defvar vm-toolbar-recover-icon nil) |
|
170 |
||
171 |
(defvar vm-toolbar-helper-icon nil) |
|
172 |
(make-variable-buffer-local 'vm-toolbar-helper-icon) |
|
173 |
||
174 |
(defvar vm-toolbar-help-button |
|
175 |
[vm-toolbar-helper-icon vm-toolbar-helper-command |
|
176 |
(vm-toolbar-can-help-p) |
|
177 |
"Don't Panic.\n
|
|
178 |
VM uses this button to offer help if you're in trouble.
|
|
179 |
Under normal circumstances, this button runs `vm-help'. |
|
180 |
If the current folder looks out-of-date relative to its auto-save
|
|
181 |
file then this button will run `recover-file' |
|
182 |
If there is mail waiting in one of the spool files associated
|
|
183 |
with the current folder, and the `getmail' button is not on the |
|
184 |
toolbar, this button will run `vm-get-new-mail'. |
|
185 |
If the current message needs to be MIME decoded then this button
|
|
186 |
will run 'vm-decode-mime-message'."]) |
|
187 |
||
188 |
(defvar vm-toolbar-helper-command nil) |
|
189 |
(make-variable-buffer-local 'vm-toolbar-helper-command) |
|
190 |
||
191 |
(defun vm-toolbar-helper-command () |
|
192 |
(interactive) |
|
193 |
(setq this-command vm-toolbar-helper-command) |
|
194 |
(call-interactively vm-toolbar-helper-command)) |
|
195 |
||
196 |
(defvar vm-toolbar-quit-button |
|
197 |
[vm-toolbar-quit-icon vm-toolbar-quit-command |
|
198 |
(vm-toolbar-can-quit-p) |
|
199 |
"Quit visiting this folder.\n
|
|
200 |
The command `vm-toolbar-quit-command' is run, which is normally |
|
201 |
fbound to `vm-quit'. |
|
202 |
You can make this button run some other command by using a Lisp
|
|
203 |
s-expression like this one in your .vm file:
|
|
204 |
(fset 'vm-toolbar-quit-command 'some-other-command)"]) |
|
205 |
(defvar vm-toolbar-quit-icon nil) |
|
206 |
(or (fboundp 'vm-toolbar-quit-command) |
|
207 |
(fset 'vm-toolbar-quit-command 'vm-quit)) |
|
208 |
||
209 |
(defun vm-toolbar-any-messages-p () |
|
210 |
(condition-case nil |
|
211 |
(save-excursion |
|
212 |
(vm-check-for-killed-folder) |
|
213 |
(vm-select-folder-buffer-if-possible) |
|
214 |
vm-message-list) |
|
215 |
(error nil))) |
|
216 |
||
217 |
(defun vm-toolbar-delete/undelete-message (&optional prefix-arg) |
|
218 |
(interactive "P") |
|
219 |
(vm-follow-summary-cursor) |
|
220 |
(vm-select-folder-buffer) |
|
221 |
(vm-check-for-killed-summary) |
|
222 |
(vm-error-if-folder-read-only) |
|
223 |
(vm-error-if-folder-empty) |
|
224 |
(let ((current-prefix-arg prefix-arg)) |
|
225 |
(if (vm-deleted-flag (car vm-message-pointer)) |
|
226 |
(call-interactively 'vm-undelete-message) |
|
227 |
(call-interactively 'vm-delete-message)))) |
|
228 |
||
229 |
(defun vm-toolbar-can-autofile-p () |
|
230 |
(interactive) |
|
231 |
(condition-case nil |
|
232 |
(save-excursion |
|
233 |
(vm-check-for-killed-folder) |
|
234 |
(vm-select-folder-buffer-if-possible) |
|
235 |
(and vm-message-pointer |
|
236 |
(vm-auto-select-folder vm-message-pointer vm-auto-folder-alist))) |
|
237 |
(error nil))) |
|
238 |
||
239 |
(defun vm-toolbar-autofile-message () |
|
240 |
(interactive) |
|
241 |
(vm-follow-summary-cursor) |
|
242 |
(vm-select-folder-buffer) |
|
243 |
(vm-check-for-killed-summary) |
|
244 |
(vm-error-if-folder-read-only) |
|
245 |
(vm-error-if-folder-empty) |
|
246 |
(let ((file (vm-auto-select-folder vm-message-pointer vm-auto-folder-alist))) |
|
247 |
(if file |
|
248 |
(progn |
|
249 |
(vm-save-message file 1) |
|
250 |
(message "Message saved to %s" file)) |
|
251 |
(error "No match for message in vm-auto-folder-alist.")))) |
|
252 |
||
253 |
(defun vm-toolbar-can-recover-p () |
|
254 |
(condition-case nil |
|
255 |
(save-excursion |
|
256 |
(vm-select-folder-buffer) |
|
257 |
(and vm-folder-read-only |
|
258 |
buffer-file-name
|
|
259 |
buffer-auto-save-file-name
|
|
260 |
(null (buffer-modified-p)) |
|
261 |
(file-newer-than-file-p |
|
262 |
buffer-auto-save-file-name
|
|
263 |
buffer-file-name))) |
|
264 |
(error nil))) |
|
265 |
||
266 |
(defun vm-toolbar-can-decode-mime-p () |
|
267 |
(condition-case nil |
|
268 |
(save-excursion |
|
269 |
(vm-select-folder-buffer) |
|
270 |
(and |
|
271 |
vm-display-using-mime
|
|
272 |
vm-message-pointer
|
|
273 |
vm-presentation-buffer
|
|
274 |
(not (vm-mime-plain-message-p (car vm-message-pointer))))) |
|
275 |
(error nil))) |
|
276 |
||
277 |
(defun vm-toolbar-can-quit-p () |
|
278 |
(condition-case nil |
|
279 |
(save-excursion |
|
280 |
(vm-select-folder-buffer) |
|
281 |
(memq major-mode '(vm-mode vm-virtual-mode))) |
|
282 |
(error nil))) |
|
283 |
||
284 |
(defun vm-toolbar-mail-waiting-p () |
|
285 |
(condition-case nil |
|
286 |
(save-excursion |
|
287 |
(vm-select-folder-buffer) |
|
288 |
(or (not (natnump vm-mail-check-interval)) |
|
289 |
vm-spooled-mail-waiting)) |
|
290 |
(error nil))) |
|
291 |
||
292 |
(fset 'vm-toolbar-can-help-p 'vm-toolbar-can-quit-p) |
|
293 |
||
294 |
(defun vm-toolbar-update-toolbar () |
|
295 |
(if (and vm-message-pointer (vm-deleted-flag (car vm-message-pointer))) |
|
296 |
(setq vm-toolbar-delete/undelete-icon vm-toolbar-undelete-icon) |
|
297 |
(setq vm-toolbar-delete/undelete-icon vm-toolbar-delete-icon)) |
|
298 |
(cond ((vm-toolbar-can-recover-p) |
|
299 |
(setq vm-toolbar-helper-command 'recover-file |
|
300 |
vm-toolbar-helper-icon vm-toolbar-recover-icon)) |
|
301 |
((and (vm-toolbar-mail-waiting-p) |
|
302 |
(not (memq 'getmail vm-use-toolbar))) |
|
303 |
(setq vm-toolbar-helper-command 'vm-get-new-mail |
|
304 |
vm-toolbar-helper-icon vm-toolbar-getmail-icon)) |
|
305 |
((and (vm-toolbar-can-decode-mime-p) (not vm-mime-decoded) |
|
306 |
(not (memq 'mime vm-use-toolbar))) |
|
307 |
(setq vm-toolbar-helper-command 'vm-decode-mime-message |
|
308 |
vm-toolbar-helper-icon vm-toolbar-decode-mime-icon)) |
|
309 |
(t |
|
310 |
(setq vm-toolbar-helper-command 'vm-help |
|
311 |
vm-toolbar-helper-icon vm-toolbar-help-icon))) |
|
312 |
(if vm-summary-buffer |
|
313 |
(vm-copy-local-variables vm-summary-buffer |
|
314 |
'vm-toolbar-delete/undelete-icon
|
|
315 |
'vm-toolbar-helper-command
|
|
316 |
'vm-toolbar-helper-icon)) |
|
317 |
(if vm-presentation-buffer |
|
318 |
(vm-copy-local-variables vm-presentation-buffer |
|
319 |
'vm-toolbar-delete/undelete-icon
|
|
320 |
'vm-toolbar-helper-command
|
|
321 |
'vm-toolbar-helper-icon)) |
|
322 |
(and vm-toolbar-specifier |
|
323 |
(progn |
|
324 |
(set-specifier vm-toolbar-specifier (cons (current-buffer) nil)) |
|
325 |
(set-specifier vm-toolbar-specifier (cons (current-buffer) |
|
326 |
vm-toolbar))))) |
|
327 |
||
328 |
(defun vm-toolbar-install-or-uninstall-toolbar () |
|
329 |
(and (vm-toolbar-support-possible-p) vm-use-toolbar |
|
330 |
(vm-toolbar-install-toolbar)) |
|
331 |
(if (and vm-fsfemacs-p (not vm-use-toolbar)) |
|
332 |
(vm-toolbar-fsfemacs-uninstall-toolbar))) |
|
333 |
||
334 |
(defun vm-toolbar-install-toolbar () |
|
335 |
;; drag these in now instead of waiting for them to be
|
|
336 |
;; autoloaded. the "loading..." messages could come at a bad
|
|
337 |
;; moment and wipe an important echo area message, like "Auto
|
|
338 |
;; save file is newer..."
|
|
339 |
(require 'vm-save) |
|
340 |
(require 'vm-summary) |
|
341 |
(if vm-fsfemacs-p |
|
342 |
(if (not vm-fsfemacs-toolbar-installed-p) |
|
343 |
(vm-toolbar-fsfemacs-install-toolbar)) |
|
344 |
(if (not (and (stringp vm-toolbar-pixmap-directory) |
|
345 |
(file-directory-p vm-toolbar-pixmap-directory))) |
|
346 |
(progn |
|
347 |
(message "Bad toolbar pixmap directory, can't setup toolbar.") |
|
348 |
(sit-for 2)) |
|
349 |
(vm-toolbar-initialize) |
|
350 |
(let ((height (+ 4 (glyph-height (car vm-toolbar-help-icon)))) |
|
351 |
(width (+ 4 (glyph-width (car vm-toolbar-help-icon)))) |
|
352 |
(frame (selected-frame)) |
|
353 |
(buffer (current-buffer)) |
|
354 |
(tag-set '(win)) |
|
355 |
(myframe (vm-created-this-frame-p)) |
|
356 |
toolbar ) |
|
357 |
;; glyph-width and glyph-height return 0 at startup sometimes
|
|
358 |
;; use reasonable values if they fail.
|
|
359 |
(if (= width 4) |
|
360 |
(setq width 68)) |
|
361 |
(if (= height 4) |
|
362 |
(setq height 46)) |
|
363 |
;; honor user setting of vm-toolbar if they are daring enough
|
|
364 |
;; to set it.
|
|
365 |
(if vm-toolbar |
|
366 |
(setq toolbar vm-toolbar) |
|
367 |
(setq toolbar (vm-toolbar-make-toolbar-spec) |
|
368 |
vm-toolbar toolbar)) |
|
369 |
(cond ((eq vm-toolbar-orientation 'right) |
|
370 |
(setq vm-toolbar-specifier right-toolbar) |
|
371 |
(if myframe |
|
372 |
(set-specifier right-toolbar toolbar frame tag-set)) |
|
373 |
(set-specifier right-toolbar toolbar buffer) |
|
374 |
(set-specifier right-toolbar-width width frame tag-set)) |
|
375 |
((eq vm-toolbar-orientation 'left) |
|
376 |
(setq vm-toolbar-specifier left-toolbar) |
|
377 |
(if myframe |
|
378 |
(set-specifier left-toolbar toolbar frame tag-set)) |
|
379 |
(set-specifier left-toolbar toolbar buffer) |
|
380 |
(set-specifier left-toolbar-width width frame tag-set)) |
|
381 |
((eq vm-toolbar-orientation 'bottom) |
|
382 |
(setq vm-toolbar-specifier bottom-toolbar) |
|
383 |
(if myframe |
|
384 |
(set-specifier bottom-toolbar toolbar frame tag-set)) |
|
385 |
(set-specifier bottom-toolbar toolbar buffer) |
|
386 |
(set-specifier bottom-toolbar-height height frame tag-set)) |
|
387 |
(t |
|
388 |
(setq vm-toolbar-specifier top-toolbar) |
|
389 |
(if myframe |
|
390 |
(set-specifier top-toolbar toolbar frame tag-set)) |
|
391 |
(set-specifier top-toolbar toolbar buffer) |
|
392 |
(set-specifier top-toolbar-height height frame tag-set))))))) |
|
393 |
||
394 |
(defun vm-toolbar-make-toolbar-spec () |
|
395 |
(let ((button-alist '( |
|
396 |
(autofile . vm-toolbar-autofile-button) |
|
397 |
(compose . vm-toolbar-compose-button) |
|
398 |
(delete/undelete . vm-toolbar-delete/undelete-button) |
|
399 |
(file . vm-toolbar-file-button) |
|
400 |
(getmail . vm-toolbar-getmail-button) |
|
401 |
(help . vm-toolbar-help-button) |
|
402 |
(mime . vm-toolbar-decode-mime-button) |
|
403 |
(next . vm-toolbar-next-button) |
|
404 |
(previous . vm-toolbar-previous-button) |
|
405 |
(print . vm-toolbar-print-button) |
|
406 |
(quit . vm-toolbar-quit-button) |
|
407 |
(reply . vm-toolbar-reply-button) |
|
408 |
(visit . vm-toolbar-visit-button) |
|
409 |
))
|
|
410 |
(button-list vm-use-toolbar) |
|
411 |
cons
|
|
412 |
(toolbar nil)) |
|
413 |
(while button-list |
|
414 |
(cond ((null (car button-list)) |
|
415 |
(setq toolbar (cons nil toolbar))) |
|
416 |
((integerp (car button-list)) |
|
417 |
(if (< 0 (car button-list)) |
|
418 |
(setq toolbar (cons (vector ':size (car button-list) |
|
419 |
':style '2d) |
|
420 |
toolbar)))) |
|
421 |
(t |
|
422 |
(setq cons (assq (car button-list) button-alist)) |
|
423 |
(if cons |
|
424 |
(setq toolbar (cons (symbol-value (cdr cons)) toolbar))))) |
|
425 |
(setq button-list (cdr button-list))) |
|
426 |
(nreverse toolbar) )) |
|
427 |
||
428 |
(defun vm-toolbar-initialize () |
|
429 |
(cond |
|
430 |
(vm-fsfemacs-p nil) |
|
431 |
((null vm-toolbar-help-icon) |
|
432 |
(let ((tuples |
|
433 |
(if (featurep 'xpm) |
|
434 |
(list |
|
435 |
(if (and (device-on-window-system-p) |
|
436 |
(>= (device-bitplanes) 16)) |
|
437 |
'(vm-toolbar-decode-mime-icon "mime-colorful-up.xpm" |
|
438 |
"mime-colorful-dn.xpm"
|
|
439 |
"mime-colorful-xx.xpm") |
|
440 |
'(vm-toolbar-decode-mime-icon "mime-simple-up.xpm" |
|
441 |
"mime-simple-dn.xpm"
|
|
442 |
"mime-simple-xx.xpm")) |
|
443 |
'(vm-toolbar-next-icon "next-up.xpm" "next-dn.xpm" "next-dn.xpm") |
|
444 |
'(vm-toolbar-previous-icon "previous-up.xpm" "previous-dn.xpm" |
|
445 |
"previous-dn.xpm") |
|
446 |
'(vm-toolbar-delete-icon "delete-up.xpm" "delete-dn.xpm" "delete-dn.xpm") |
|
447 |
'(vm-toolbar-undelete-icon "undelete-up.xpm" "undelete-dn.xpm" |
|
448 |
"undelete-dn.xpm") |
|
449 |
'(vm-toolbar-autofile-icon "autofile-up.xpm" "autofile-dn.xpm" |
|
450 |
"autofile-dn.xpm") |
|
451 |
'(vm-toolbar-getmail-icon "getmail-up.xpm" "getmail-dn.xpm" "getmail-dn.xpm") |
|
452 |
'(vm-toolbar-file-icon "file-up.xpm" "file-dn.xpm" "file-dn.xpm") |
|
453 |
'(vm-toolbar-reply-icon "reply-up.xpm" "reply-dn.xpm" "reply-dn.xpm") |
|
454 |
'(vm-toolbar-compose-icon "compose-up.xpm" "compose-dn.xpm" "compose-dn.xpm") |
|
455 |
'(vm-toolbar-print-icon "print-up.xpm" "print-dn.xpm" "print-dn.xpm") |
|
456 |
'(vm-toolbar-visit-icon "visit-up.xpm" "visit-dn.xpm" "visit-dn.xpm") |
|
457 |
'(vm-toolbar-quit-icon "quit-up.xpm" "quit-dn.xpm" "quit-dn.xpm") |
|
458 |
'(vm-toolbar-help-icon "help-up.xpm" "help-dn.xpm" "help-dn.xpm") |
|
459 |
'(vm-toolbar-recover-icon "recover-up.xpm" "recover-dn.xpm" "recover-dn.xpm") |
|
460 |
)
|
|
461 |
'( |
|
462 |
(vm-toolbar-decode-mime-icon "mime-up.xbm" "mime-dn.xbm" "mime-xx.xbm") |
|
463 |
(vm-toolbar-next-icon "next-up.xbm" "next-dn.xbm" "next-xx.xbm") |
|
464 |
(vm-toolbar-previous-icon "previous-up.xbm" "previous-dn.xbm" |
|
465 |
"previous-xx.xbm") |
|
466 |
(vm-toolbar-delete-icon "delete-up.xbm" "delete-dn.xbm" "delete-xx.xbm") |
|
467 |
(vm-toolbar-undelete-icon "undelete-up.xbm" "undelete-dn.xbm" |
|
468 |
"undelete-xx.xbm") |
|
469 |
(vm-toolbar-autofile-icon "autofile-up.xbm" "autofile-dn.xbm" |
|
470 |
"autofile-xx.xbm") |
|
471 |
(vm-toolbar-getmail-icon "getmail-up.xbm" "getmail-dn.xbm" "getmail-xx.xbm") |
|
472 |
(vm-toolbar-file-icon "file-up.xbm" "file-dn.xbm" "file-xx.xbm") |
|
473 |
(vm-toolbar-reply-icon "reply-up.xbm" "reply-dn.xbm" "reply-xx.xbm") |
|
474 |
(vm-toolbar-compose-icon "compose-up.xbm" "compose-dn.xbm" "compose-xx.xbm") |
|
475 |
(vm-toolbar-print-icon "print-up.xbm" "print-dn.xbm" "print-xx.xbm") |
|
476 |
(vm-toolbar-visit-icon "visit-up.xbm" "visit-dn.xbm" "visit-xx.xbm") |
|
477 |
(vm-toolbar-quit-icon "quit-up.xbm" "quit-dn.xbm" "quit-xx.xbm") |
|
478 |
(vm-toolbar-help-icon "help-up.xbm" "help-dn.xbm" "help-xx.xpm") |
|
479 |
(vm-toolbar-recover-icon "recover-up.xbm" "recover-dn.xbm" "recover-xx.xpm") |
|
480 |
)))
|
|
481 |
tuple files var) |
|
482 |
(while tuples |
|
483 |
(setq tuple (car tuples) |
|
484 |
var (car tuple) |
|
485 |
files (cdr tuple)) |
|
486 |
(set var (mapcar |
|
487 |
(function |
|
488 |
(lambda (f) |
|
489 |
(make-glyph |
|
490 |
(expand-file-name f vm-toolbar-pixmap-directory)))) |
|
491 |
files)) |
|
492 |
(setq tuples (cdr tuples)))))) |
|
493 |
(setq vm-toolbar-delete/undelete-icon vm-toolbar-delete-icon) |
|
494 |
(setq-default vm-toolbar-delete/undelete-icon vm-toolbar-delete-icon) |
|
495 |
(setq vm-toolbar-helper-command 'vm-help) |
|
496 |
(setq vm-toolbar-helper-icon vm-toolbar-help-icon) |
|
497 |
(setq-default vm-toolbar-helper-icon vm-toolbar-help-icon)) |
|
498 |
||
499 |
(defun vm-toolbar-fsfemacs-uninstall-toolbar () |
|
500 |
(define-key vm-mode-map [toolbar] nil) |
|
501 |
(setq vm-fsfemacs-toolbar-installed-p nil)) |
|
502 |
||
503 |
(defun vm-toolbar-fsfemacs-install-toolbar () |
|
504 |
(let ((button-list (reverse vm-use-toolbar)) |
|
505 |
(dir vm-toolbar-pixmap-directory) |
|
506 |
(extension (if (and (display-color-p) |
|
507 |
(image-type-available-p 'xpm)) |
|
508 |
"xpm"
|
|
509 |
"xbm")) |
|
510 |
item t-spec sym name images) |
|
511 |
(defvar tool-bar-map) |
|
512 |
;; hide the toolbar entries that are in the global keymap so
|
|
513 |
;; VM has full control of the toolbar in its buffers.
|
|
514 |
(if (and (boundp 'tool-bar-map) |
|
515 |
(consp tool-bar-map)) |
|
516 |
(let ((map (cdr tool-bar-map)) |
|
517 |
(v [tool-bar x])) |
|
518 |
(while map |
|
519 |
(aset v 1 (car (car map))) |
|
520 |
(define-key vm-mode-map v 'undefined) |
|
521 |
(setq map (cdr map))))) |
|
522 |
(while button-list |
|
523 |
(setq sym (car button-list)) |
|
524 |
(cond ((null sym) |
|
525 |
;; can't do flushright in FSF Emacs
|
|
526 |
t) |
|
527 |
((integerp sym) |
|
528 |
;; can't do separators in FSF Emacs
|
|
529 |
t) |
|
530 |
((memq sym '(autofile compose file getmail |
|
531 |
mime next previous print quit reply visit)) |
|
532 |
(setq t-spec (symbol-value |
|
533 |
(intern (format "vm-toolbar-%s-button" |
|
534 |
(if (eq sym 'mime) |
|
535 |
'decode-mime
|
|
536 |
sym))))) |
|
537 |
(if (and (eq sym 'mime) (string= extension "xpm")) |
|
538 |
(setq name "mime-colorful") |
|
539 |
(setq name (symbol-name sym))) |
|
540 |
(setq images (vm-toolbar-make-fsfemacs-toolbar-image-spec |
|
541 |
name extension dir |
|
542 |
(if (eq sym 'mime) nil 'heuristic))) |
|
543 |
(setq item |
|
544 |
(list 'menu-item |
|
545 |
(aref t-spec 3) |
|
546 |
(aref t-spec 1) |
|
547 |
':enable (aref t-spec 2) |
|
548 |
':button '(:toggle nil) |
|
549 |
':image images)) |
|
550 |
(define-key vm-mode-map (vector 'tool-bar sym) item)) |
|
551 |
((eq sym 'delete/undelete) |
|
552 |
(setq t-spec vm-toolbar-delete/undelete-button) |
|
553 |
(setq name "delete") |
|
554 |
(setq images (vm-toolbar-make-fsfemacs-toolbar-image-spec |
|
555 |
name extension dir 'heuristic)) |
|
556 |
(setq item |
|
557 |
(list 'menu-item |
|
558 |
(aref t-spec 3) |
|
559 |
(aref t-spec 1) |
|
560 |
':visible '(eq vm-toolbar-delete/undelete-icon |
|
561 |
vm-toolbar-delete-icon) |
|
562 |
':enable (aref t-spec 2) |
|
563 |
':button '(:toggle nil) |
|
564 |
':image images)) |
|
565 |
(define-key vm-mode-map (vector 'tool-bar 'delete) item) |
|
566 |
(setq name "undelete") |
|
567 |
(setq images (vm-toolbar-make-fsfemacs-toolbar-image-spec |
|
568 |
name extension dir 'heuristic)) |
|
569 |
(setq item |
|
570 |
(list 'menu-item |
|
571 |
(aref t-spec 3) |
|
572 |
(aref t-spec 1) |
|
573 |
':visible '(eq vm-toolbar-delete/undelete-icon |
|
574 |
vm-toolbar-undelete-icon) |
|
575 |
':enable (aref t-spec 2) |
|
576 |
':button '(:toggle nil) |
|
577 |
':image images)) |
|
578 |
(define-key vm-mode-map (vector 'tool-bar 'undelete) item)) |
|
579 |
((eq sym 'help) |
|
580 |
(setq t-spec vm-toolbar-help-button) |
|
581 |
(setq name "help") |
|
582 |
(setq images (vm-toolbar-make-fsfemacs-toolbar-image-spec |
|
583 |
name extension dir 'heuristic)) |
|
584 |
(setq item |
|
585 |
(list 'menu-item |
|
586 |
(aref t-spec 3) |
|
587 |
(aref t-spec 1) |
|
588 |
':visible '(eq vm-toolbar-helper-command 'vm-help) |
|
589 |
':enable (aref t-spec 2) |
|
590 |
':button '(:toggle nil) |
|
591 |
':image images)) |
|
592 |
(define-key vm-mode-map (vector 'tool-bar 'help-help) item) |
|
593 |
(setq name "recover") |
|
594 |
(setq images (vm-toolbar-make-fsfemacs-toolbar-image-spec |
|
595 |
name extension dir 'heuristic)) |
|
596 |
(setq item |
|
597 |
(list 'menu-item |
|
598 |
(aref t-spec 3) |
|
599 |
(aref t-spec 1) |
|
600 |
':visible '(eq vm-toolbar-helper-command |
|
601 |
'recover-file) |
|
602 |
':enable (aref t-spec 2) |
|
603 |
':button '(:toggle nil) |
|
604 |
':image images)) |
|
605 |
(define-key vm-mode-map (vector 'tool-bar 'help-recover) item) |
|
606 |
(setq name "getmail") |
|
607 |
(setq images (vm-toolbar-make-fsfemacs-toolbar-image-spec |
|
608 |
name extension dir 'heuristic)) |
|
609 |
(setq item |
|
610 |
(list 'menu-item |
|
611 |
(aref t-spec 3) |
|
612 |
(aref t-spec 1) |
|
613 |
':visible '(eq vm-toolbar-helper-command |
|
614 |
'vm-get-new-mail) |
|
615 |
':enable (aref t-spec 2) |
|
616 |
':button '(:toggle nil) |
|
617 |
':image images)) |
|
618 |
(define-key vm-mode-map (vector 'tool-bar 'help-getmail) item) |
|
619 |
(if (string= extension "xpm") |
|
620 |
(setq name "mime-colorful") |
|
621 |
(setq name "mime")) |
|
622 |
(setq images (vm-toolbar-make-fsfemacs-toolbar-image-spec |
|
623 |
name extension dir nil)) |
|
624 |
(setq item |
|
625 |
(list 'menu-item |
|
626 |
(aref t-spec 3) |
|
627 |
(aref t-spec 1) |
|
628 |
':visible '(eq vm-toolbar-helper-command |
|
629 |
'vm-decode-mime-message) |
|
630 |
':enable (aref t-spec 2) |
|
631 |
':button '(:toggle nil) |
|
632 |
':image images)) |
|
633 |
(define-key vm-mode-map (vector 'tool-bar 'help-mime) item))) |
|
634 |
(setq button-list (cdr button-list)))) |
|
635 |
(setq vm-fsfemacs-toolbar-installed-p t)) |
|
636 |
||
637 |
(defun vm-toolbar-make-fsfemacs-toolbar-image-spec (name extension dir mask) |
|
638 |
(if (string= extension "xpm") |
|
639 |
(vector |
|
640 |
(list 'image |
|
641 |
':type (intern extension) |
|
642 |
':mask mask |
|
643 |
':file (expand-file-name |
|
644 |
(format "%s-dn.%s" |
|
645 |
name extension) |
|
646 |
dir)) |
|
647 |
(list 'image |
|
648 |
':type (intern extension) |
|
649 |
':mask mask |
|
650 |
':file (expand-file-name |
|
651 |
(format "%s-up.%s" |
|
652 |
name extension) |
|
653 |
dir)) |
|
654 |
(list 'image |
|
655 |
':type (intern extension) |
|
656 |
':mask mask |
|
657 |
':file (expand-file-name |
|
658 |
(format "%s-dn.%s" |
|
659 |
name extension) |
|
660 |
dir)) |
|
661 |
(list 'image |
|
662 |
':type (intern extension) |
|
663 |
':mask mask |
|
664 |
':file (expand-file-name |
|
665 |
(format "%s-dn.%s" |
|
666 |
name extension) |
|
667 |
dir))) |
|
668 |
(vector |
|
669 |
(list 'image |
|
670 |
':type (intern extension) |
|
671 |
':mask mask |
|
672 |
':file (expand-file-name |
|
673 |
(format "%s-dn.%s" |
|
674 |
name extension) |
|
675 |
dir)) |
|
676 |
(list 'image |
|
677 |
':type (intern extension) |
|
678 |
':mask mask |
|
679 |
':file (expand-file-name |
|
680 |
(format "%s-up.%s" |
|
681 |
name extension) |
|
682 |
dir)) |
|
683 |
(list 'image |
|
684 |
':type (intern extension) |
|
685 |
':mask mask |
|
686 |
':file (expand-file-name |
|
687 |
(format "%s-xx.%s" |
|
688 |
name extension) |
|
689 |
dir)) |
|
690 |
(list 'image |
|
691 |
':type (intern extension) |
|
692 |
':mask mask |
|
693 |
':file (expand-file-name |
|
694 |
(format "%s-xx.%s" |
|
695 |
name extension) |
|
696 |
dir))))) |
|
|
1.1.1
by Manoj Srivastava
Import upstream version 7.18 |
697 |
|
698 |
(provide 'vm-toolbar) |