« back to all changes in this revision
Viewing changes to vm-toolbar.el
- browse files at revision 2
- compare with another revision
- download diff
- download tarball
- view history from revision 2
- Committer: Robert Widhopf
- Date: 2004-05-02 21:30:26 UTC
- Revision ID: Arch-1:hack@robf.de--testing%vm--main--7--patch-1
Initial Import of VM 7.18
- files added:
- COPYING
- pixmaps
added
removed
vm-toolbar.el
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
18
;;(provide 'vm-toolbar)
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)))))
697
698
(provide 'vm-toolbar)
Loggerhead is a web-based interface for Breezy
Version: 2.0.1