68465
|
1 ;;; mh-tool-bar.el --- MH-E tool bar support
|
|
2
|
|
3 ;; Copyright (C) 2002, 2003, 2005, 2006 Free Software Foundation, Inc.
|
|
4
|
|
5 ;; Author: Satyaki Das <satyaki@theforce.stanford.edu>
|
|
6 ;; Maintainer: Bill Wohler <wohler@newt.com>
|
|
7 ;; Keywords: mail
|
|
8 ;; See: mh-e.el
|
|
9
|
|
10 ;; This file is part of GNU Emacs.
|
|
11
|
|
12 ;; GNU Emacs is free software; you can redistribute it and/or modify
|
|
13 ;; it under the terms of the GNU General Public License as published by
|
|
14 ;; the Free Software Foundation; either version 2, or (at your option)
|
|
15 ;; any later version.
|
|
16
|
|
17 ;; GNU Emacs is distributed in the hope that it will be useful,
|
|
18 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
|
|
19 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
|
|
20 ;; GNU General Public License for more details.
|
|
21
|
|
22 ;; You should have received a copy of the GNU General Public License
|
|
23 ;; along with GNU Emacs; see the file COPYING. If not, write to the
|
|
24 ;; Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
|
|
25 ;; Boston, MA 02110-1301, USA.
|
|
26
|
|
27 ;;; Commentary:
|
|
28
|
|
29 ;;; Change Log:
|
|
30
|
|
31 ;;; Code:
|
|
32
|
|
33 (require 'mh-e)
|
|
34
|
|
35 ;;; Tool Bar Commands
|
|
36
|
|
37 (defun mh-tool-bar-search (&optional arg)
|
|
38 "Interactively call `mh-tool-bar-search-function'.
|
|
39 Optional argument ARG is not used."
|
|
40 (interactive "P")
|
|
41 (call-interactively mh-tool-bar-search-function))
|
|
42
|
|
43 (defun mh-tool-bar-customize ()
|
|
44 "Call `mh-customize' from the tool bar."
|
|
45 (interactive)
|
|
46 (mh-customize t))
|
|
47
|
|
48 (defun mh-tool-bar-folder-help ()
|
|
49 "Visit \"(mh-e)Top\"."
|
|
50 (interactive)
|
|
51 (info "(mh-e)Top")
|
|
52 (delete-other-windows))
|
|
53
|
|
54 (defun mh-tool-bar-letter-help ()
|
|
55 "Visit \"(mh-e)Editing Drafts\"."
|
|
56 (interactive)
|
|
57 (info "(mh-e)Editing Drafts")
|
|
58 (delete-other-windows))
|
|
59
|
|
60 (defmacro mh-tool-bar-reply-generator (function recipient folder-buffer-flag)
|
|
61 "Generate FUNCTION that replies to RECIPIENT.
|
|
62 If FOLDER-BUFFER-FLAG is nil then the function generated...
|
|
63 When INCLUDE-FLAG is non-nil, include message body being replied to."
|
|
64 `(defun ,function (&optional arg)
|
|
65 ,(format "Reply to \"%s\".\nWhen ARG is non-nil include message in reply."
|
|
66 recipient)
|
|
67 (interactive "P")
|
|
68 ,(if folder-buffer-flag nil '(set-buffer mh-show-folder-buffer))
|
|
69 (mh-reply (mh-get-msg-num nil) ,recipient arg)))
|
|
70
|
|
71 (mh-tool-bar-reply-generator mh-tool-bar-reply-from "from" t)
|
|
72 (mh-tool-bar-reply-generator mh-show-tool-bar-reply-from "from" nil)
|
|
73 (mh-tool-bar-reply-generator mh-tool-bar-reply-to "to" t)
|
|
74 (mh-tool-bar-reply-generator mh-show-tool-bar-reply-to "to" nil)
|
|
75 (mh-tool-bar-reply-generator mh-tool-bar-reply-all "all" t)
|
|
76 (mh-tool-bar-reply-generator mh-show-tool-bar-reply-all "all" nil)
|
|
77
|
|
78
|
|
79
|
|
80 ;;; Tool Bar Creation
|
|
81
|
|
82 (defmacro mh-tool-bar-define (defaults &rest buttons)
|
|
83 "Define a tool bar for MH-E.
|
|
84 DEFAULTS is the list of buttons that are present by default. It
|
|
85 is a list of lists where the sublists are of the following form:
|
|
86
|
|
87 (:KEYWORD FUNC1 FUNC2 FUNC3 ...)
|
|
88
|
|
89 Here :KEYWORD is one of :folder or :letter. If it is :folder then
|
|
90 the default buttons in the folder and show mode buffers are being
|
|
91 specified. If it is :letter then the default buttons in the
|
|
92 letter mode are listed. FUNC1, FUNC2, FUNC3, ... are the names of
|
|
93 the functions that the buttons would execute.
|
|
94
|
|
95 Each element of BUTTONS is a list consisting of four mandatory
|
|
96 items and one optional item as follows:
|
|
97
|
|
98 (FUNCTION MODES ICON DOC &optional ENABLE-EXPR)
|
|
99
|
|
100 where,
|
|
101
|
|
102 FUNCTION is the name of the function that will be executed when
|
|
103 the button is clicked.
|
|
104
|
|
105 MODES is a list of symbols. List elements must be from \"folder\",
|
|
106 \"letter\" and \"sequence\". If \"folder\" is present then the button is
|
|
107 available in the folder and show buffer. If the name of FUNCTION is
|
|
108 of the form \"mh-foo\", where foo is some arbitrary string, then we
|
|
109 check if the function `mh-show-foo' exists. If it exists then that
|
|
110 function is used in the show buffer. Otherwise the original function
|
|
111 `mh-foo' is used in the show buffer as well. Presence of \"sequence\"
|
|
112 is handled similar to the above. The only difference is that the
|
|
113 button is shown only when the folder is narrowed to a sequence. If
|
|
114 \"letter\" is present in MODES, then the button is available during
|
|
115 draft editing and runs FUNCTION when clicked.
|
|
116
|
|
117 ICON is the icon that is drawn in the button.
|
|
118
|
|
119 DOC is the documentation for the button. It is used in tool-tips and
|
|
120 in providing other help to the user. GNU Emacs uses only the first
|
|
121 line of the string. So the DOC should be formatted such that the
|
|
122 first line is useful and complete without the rest of the string.
|
|
123
|
|
124 Optional item ENABLE-EXPR is an arbitrary lisp expression. If it
|
|
125 evaluates to nil, then the button is deactivated, otherwise it is
|
|
126 active. If it isn't present then the button is always active."
|
|
127 ;; The following variable names have been carefully chosen to make code
|
|
128 ;; generation easier. Modifying the names should be done carefully.
|
|
129 (let (folder-buttons folder-docs folder-button-setter sequence-button-setter
|
|
130 show-buttons show-button-setter show-seq-button-setter
|
|
131 letter-buttons letter-docs letter-button-setter
|
|
132 folder-defaults letter-defaults
|
|
133 folder-vectors show-vectors letter-vectors)
|
|
134 (dolist (x defaults)
|
|
135 (cond ((eq (car x) :folder) (setq folder-defaults (cdr x)))
|
|
136 ((eq (car x) :letter) (setq letter-defaults (cdr x)))))
|
|
137 (dolist (button buttons)
|
|
138 (unless (and (listp button)
|
|
139 (or (equal (length button) 4) (equal (length button) 5)))
|
|
140 (error "Incorrect MH-E tool-bar button specification: %s" button))
|
|
141 (let* ((name (nth 0 button))
|
|
142 (name-str (symbol-name name))
|
|
143 (icon (nth 2 button))
|
|
144 (xemacs-icon (mh-do-in-xemacs
|
|
145 (cdr (assoc (intern icon) mh-xemacs-icon-map))))
|
|
146 (full-doc (nth 3 button))
|
|
147 (doc (if (string-match "\\(.*\\)\n" full-doc)
|
|
148 (match-string 1 full-doc)
|
|
149 full-doc))
|
|
150 (enable-expr (or (nth 4 button) t))
|
|
151 (modes (nth 1 button))
|
|
152 functions show-sym)
|
|
153 (when (memq 'letter modes) (setq functions `(:letter ,name)))
|
|
154 (when (or (memq 'folder modes) (memq 'sequence modes))
|
|
155 (setq functions
|
|
156 (append `(,(if (memq 'folder modes) :folder :sequence) ,name)
|
|
157 functions))
|
|
158 (setq show-sym
|
|
159 (if (string-match "^mh-\\(.*\\)$" name-str)
|
|
160 (intern (concat "mh-show-" (match-string 1 name-str)))
|
|
161 name))
|
|
162 (setq functions
|
|
163 (append `(,(if (memq 'folder modes) :show :show-seq)
|
|
164 ,(if (fboundp show-sym) show-sym name))
|
|
165 functions)))
|
|
166 (do ((functions functions (cddr functions)))
|
|
167 ((null functions))
|
|
168 (let* ((type (car functions))
|
|
169 (function (cadr functions))
|
|
170 (type1 (substring (symbol-name type) 1))
|
|
171 (vector-list (cond ((eq type :show) 'show-vectors)
|
|
172 ((eq type :show-seq) 'show-vectors)
|
|
173 ((eq type :letter) 'letter-vectors)
|
|
174 (t 'folder-vectors)))
|
|
175 (list (cond ((eq type :letter) 'mh-tool-bar-letter-buttons)
|
|
176 (t 'mh-tool-bar-folder-buttons)))
|
|
177 (key (intern (concat "mh-" type1 "tool-bar-" name-str)))
|
|
178 (setter (intern (concat type1 "-button-setter")))
|
|
179 (mbuttons (cond ((eq type :letter) 'letter-buttons)
|
|
180 ((eq type :show) 'show-buttons)
|
|
181 ((eq type :show-seq) 'show-buttons)
|
|
182 (t 'folder-buttons)))
|
|
183 (docs (cond ((eq mbuttons 'letter-buttons) 'letter-docs)
|
|
184 ((eq mbuttons 'folder-buttons) 'folder-docs))))
|
|
185 (add-to-list vector-list `[,xemacs-icon ,function t ,full-doc])
|
|
186 (add-to-list
|
|
187 setter `(when (member ',name ,list)
|
|
188 (mh-funcall-if-exists
|
|
189 tool-bar-add-item ,icon ',function ',key
|
|
190 :help ,doc :enable ',enable-expr)))
|
|
191 (add-to-list mbuttons name)
|
|
192 (if docs (add-to-list docs doc))))))
|
|
193 (setq folder-buttons (nreverse folder-buttons)
|
|
194 letter-buttons (nreverse letter-buttons)
|
|
195 show-buttons (nreverse show-buttons)
|
|
196 letter-docs (nreverse letter-docs)
|
|
197 folder-docs (nreverse folder-docs)
|
|
198 folder-vectors (nreverse folder-vectors)
|
|
199 show-vectors (nreverse show-vectors)
|
|
200 letter-vectors (nreverse letter-vectors))
|
|
201 (dolist (x folder-defaults)
|
|
202 (unless (memq x folder-buttons)
|
|
203 (error "Folder defaults contains unknown button '%s'" x)))
|
|
204 (dolist (x letter-defaults)
|
|
205 (unless (memq x letter-buttons)
|
|
206 (error "Letter defaults contains unknown button '%s'" x)))
|
|
207 `(eval-when (compile load eval)
|
|
208 (defun mh-buffer-exists-p (mode)
|
|
209 "Test whether a buffer with major mode MODE is present."
|
|
210 (loop for buf in (buffer-list)
|
|
211 when (save-excursion
|
|
212 (set-buffer buf)
|
|
213 (eq major-mode mode))
|
|
214 return t))
|
|
215
|
|
216 ;; GNU Emacs tool bar specific code
|
|
217 (mh-do-in-gnu-emacs
|
|
218 ;; Tool bar initialization functions
|
|
219 (defun mh-tool-bar-folder-buttons-init ()
|
|
220 (when (mh-buffer-exists-p 'mh-folder-mode)
|
|
221 (mh-image-load-path)
|
|
222 (setq mh-folder-tool-bar-map
|
|
223 (let ((tool-bar-map (make-sparse-keymap)))
|
|
224 ,@(nreverse folder-button-setter)
|
|
225 tool-bar-map))
|
|
226 (setq mh-show-tool-bar-map
|
|
227 (let ((tool-bar-map (make-sparse-keymap)))
|
|
228 ,@(nreverse show-button-setter)
|
|
229 tool-bar-map))
|
|
230 (setq mh-show-seq-tool-bar-map
|
|
231 (let ((tool-bar-map (copy-keymap mh-show-tool-bar-map)))
|
|
232 ,@(nreverse show-seq-button-setter)
|
|
233 tool-bar-map))
|
|
234 (setq mh-folder-seq-tool-bar-map
|
|
235 (let ((tool-bar-map (copy-keymap mh-folder-tool-bar-map)))
|
|
236 ,@(nreverse sequence-button-setter)
|
|
237 tool-bar-map))))
|
|
238 (defun mh-tool-bar-letter-buttons-init ()
|
|
239 (when (mh-buffer-exists-p 'mh-letter-mode)
|
|
240 (mh-image-load-path)
|
|
241 (setq mh-letter-tool-bar-map
|
|
242 (let ((tool-bar-map (make-sparse-keymap)))
|
|
243 ,@(nreverse letter-button-setter)
|
|
244 tool-bar-map))))
|
|
245 ;; Custom setter functions
|
|
246 (defun mh-tool-bar-folder-buttons-set (symbol value)
|
|
247 "Construct tool bar for `mh-folder-mode' and `mh-show-mode'."
|
|
248 (set-default symbol value)
|
|
249 (mh-tool-bar-folder-buttons-init))
|
|
250 (defun mh-tool-bar-letter-buttons-set (symbol value)
|
|
251 "Construct tool bar for `mh-letter-mode'."
|
|
252 (set-default symbol value)
|
|
253 (mh-tool-bar-letter-buttons-init)))
|
|
254 ;; XEmacs specific code
|
|
255 (mh-do-in-xemacs
|
|
256 (defvar mh-tool-bar-folder-vector-map
|
|
257 ',(loop for button in folder-buttons
|
|
258 for vector in folder-vectors
|
|
259 collect (cons button vector)))
|
|
260 (defvar mh-tool-bar-show-vector-map
|
|
261 ',(loop for button in show-buttons
|
|
262 for vector in show-vectors
|
|
263 collect (cons button vector)))
|
|
264 (defvar mh-tool-bar-letter-vector-map
|
|
265 ',(loop for button in letter-buttons
|
|
266 for vector in letter-vectors
|
|
267 collect (cons button vector)))
|
|
268 (defvar mh-tool-bar-folder-buttons nil)
|
|
269 (defvar mh-tool-bar-show-buttons nil)
|
|
270 (defvar mh-tool-bar-letter-buttons nil)
|
|
271 ;; Custom setter functions
|
|
272 (defun mh-tool-bar-letter-buttons-set (symbol value)
|
|
273 (set-default symbol value)
|
|
274 (when mh-xemacs-has-tool-bar-flag
|
|
275 (setq mh-tool-bar-letter-buttons
|
|
276 (loop for b in value
|
|
277 collect (cdr (assoc b mh-tool-bar-letter-vector-map))))))
|
|
278 (defun mh-tool-bar-folder-buttons-set (symbol value)
|
|
279 (set-default symbol value)
|
|
280 (when mh-xemacs-has-tool-bar-flag
|
|
281 (setq mh-tool-bar-folder-buttons
|
|
282 (loop for b in value
|
|
283 collect (cdr (assoc b mh-tool-bar-folder-vector-map))))
|
|
284 (setq mh-tool-bar-show-buttons
|
|
285 (loop for b in value
|
|
286 collect (cdr (assoc b mh-tool-bar-show-vector-map))))))
|
|
287 (defun mh-tool-bar-init (mode)
|
|
288 "Install tool bar in MODE."
|
|
289 (let ((tool-bar (cond ((eq mode :folder) mh-tool-bar-folder-buttons)
|
|
290 ((eq mode :letter) mh-tool-bar-letter-buttons)
|
|
291 ((eq mode :show) mh-tool-bar-show-buttons)))
|
|
292 (height 37)
|
|
293 (width 40)
|
|
294 (buffer (current-buffer)))
|
|
295 (when mh-xemacs-use-tool-bar-flag
|
|
296 (cond
|
|
297 ((eq mh-xemacs-tool-bar-position 'top)
|
|
298 (set-specifier top-toolbar tool-bar buffer)
|
|
299 (set-specifier top-toolbar-visible-p t)
|
|
300 (set-specifier top-toolbar-height height))
|
|
301 ((eq mh-xemacs-tool-bar-position 'bottom)
|
|
302 (set-specifier bottom-toolbar tool-bar buffer)
|
|
303 (set-specifier bottom-toolbar-visible-p t)
|
|
304 (set-specifier bottom-toolbar-height height))
|
|
305 ((eq mh-xemacs-tool-bar-position 'left)
|
|
306 (set-specifier left-toolbar tool-bar buffer)
|
|
307 (set-specifier left-toolbar-visible-p t)
|
|
308 (set-specifier left-toolbar-width width))
|
|
309 ((eq mh-xemacs-tool-bar-position 'right)
|
|
310 (set-specifier right-toolbar tool-bar buffer)
|
|
311 (set-specifier right-toolbar-visible-p t)
|
|
312 (set-specifier right-toolbar-width width))
|
|
313 (t (set-specifier default-toolbar tool-bar buffer)))))))
|
|
314 ;; Declare customizable tool bars
|
|
315 (custom-declare-variable
|
|
316 'mh-tool-bar-folder-buttons
|
|
317 '(list ,@(mapcar (lambda (x) `(quote ,x)) folder-defaults))
|
|
318 "List of buttons to include in MH-Folder tool bar."
|
|
319 :group 'mh-tool-bar :set 'mh-tool-bar-folder-buttons-set
|
|
320 :type '(set ,@(loop for x in folder-buttons
|
|
321 for y in folder-docs
|
|
322 collect `(const :tag ,y ,x))))
|
|
323 (custom-declare-variable
|
|
324 'mh-tool-bar-letter-buttons
|
|
325 '(list ,@(mapcar (lambda (x) `(quote ,x)) letter-defaults))
|
|
326 "List of buttons to include in MH-Letter tool bar."
|
|
327 :group 'mh-tool-bar :set 'mh-tool-bar-letter-buttons-set
|
|
328 :type '(set ,@(loop for x in letter-buttons
|
|
329 for y in letter-docs
|
|
330 collect `(const :tag ,y ,x)))))))
|
|
331
|
|
332 (mh-tool-bar-define
|
|
333 ((:folder mh-inc-folder mh-mime-save-parts mh-previous-undeleted-msg
|
|
334 mh-page-msg mh-next-undeleted-msg mh-delete-msg mh-refile-msg
|
|
335 mh-undo mh-execute-commands mh-toggle-tick mh-reply
|
|
336 mh-alias-grab-from-field mh-send mh-rescan-folder
|
|
337 mh-tool-bar-search mh-visit-folder
|
|
338 mh-tool-bar-customize mh-tool-bar-folder-help mh-widen)
|
|
339 (:letter mh-send-letter mh-compose-insertion ispell-message save-buffer
|
|
340 undo kill-region menu-bar-kill-ring-save yank mh-fully-kill-draft
|
|
341 mh-tool-bar-customize mh-tool-bar-letter-help))
|
|
342 ;; Folder/Show buffer buttons
|
|
343 (mh-inc-folder (folder) "mail"
|
|
344 "Incorporate new mail in Inbox
|
|
345 This button runs `mh-inc-folder' which drags any
|
|
346 new mail into your Inbox folder.")
|
|
347 (mh-mime-save-parts (folder) "attach"
|
|
348 "Save MIME parts from this message
|
|
349 This button runs `mh-mime-save-parts' which saves a message's
|
|
350 different parts into separate files.")
|
|
351 (mh-previous-undeleted-msg (folder) "left-arrow"
|
|
352 "Go to the previous undeleted message
|
|
353 This button runs `mh-previous-undeleted-msg'")
|
|
354 (mh-page-msg (folder) "page-down"
|
|
355 "Page the current message forwards\nThis button runs `mh-page-msg'")
|
|
356 (mh-next-undeleted-msg (folder) "right-arrow"
|
|
357 "Go to the next undeleted message\nThe button runs `mh-next-undeleted-msg'")
|
|
358 (mh-delete-msg (folder) "close"
|
|
359 "Mark this message for deletion\nThis button runs `mh-delete-msg'")
|
|
360 (mh-refile-msg (folder) "mail/refile"
|
|
361 "Refile this message\nThis button runs `mh-refile-msg'")
|
|
362 (mh-undo (folder) "undo" "Undo last operation\nThis button runs `undo'"
|
|
363 (mh-outstanding-commands-p))
|
|
364 (mh-execute-commands (folder) "execute"
|
|
365 "Perform moves and deletes\nThis button runs `mh-execute-commands'"
|
|
366 (mh-outstanding-commands-p))
|
|
367 (mh-toggle-tick (folder) "highlight"
|
|
368 "Toggle tick mark\nThis button runs `mh-toggle-tick'")
|
|
369 (mh-toggle-showing (folder) "show"
|
|
370 "Toggle showing message\nThis button runs `mh-toggle-showing'")
|
|
371 (mh-tool-bar-reply-from (folder) "mail/reply-from" "Reply to \"from\"")
|
|
372 (mh-tool-bar-reply-to (folder) "mail/reply-to" "Reply to \"to\"")
|
|
373 (mh-tool-bar-reply-all (folder) "mail/reply-all" "Reply to \"all\"")
|
|
374 (mh-reply (folder) "mail/reply"
|
|
375 "Reply to this message\nThis button runs `mh-reply'")
|
|
376 (mh-alias-grab-from-field (folder) "mail/alias"
|
|
377 "Grab From alias\nThis button runs `mh-alias-grab-from-field'"
|
|
378 (and (mh-extract-from-header-value) (not (mh-alias-for-from-p))))
|
|
379 (mh-send (folder) "mail/compose"
|
|
380 "Compose new message\nThis button runs `mh-send'")
|
|
381 (mh-rescan-folder (folder) "refresh"
|
|
382 "Rescan this folder\nThis button runs `mh-rescan-folder'")
|
|
383 (mh-pack-folder (folder) "mail/repack"
|
|
384 "Repack this folder\nThis button runs `mh-pack-folder'")
|
|
385 (mh-tool-bar-search (folder) "search"
|
|
386 "Search\nThis button runs `mh-tool-bar-search-function'")
|
|
387 (mh-visit-folder (folder) "fld-open"
|
|
388 "Visit other folder\nThis button runs `mh-visit-folder'")
|
|
389 ;; Letter buffer buttons
|
|
390 (mh-send-letter (letter) "mail/send" "Send this letter")
|
|
391 (mh-compose-insertion (letter) "attach" "Insert attachment")
|
|
392 (ispell-message (letter) "spell" "Check spelling")
|
|
393 (save-buffer (letter) "save" "Save current buffer to its file"
|
|
394 (buffer-modified-p))
|
|
395 (undo (letter) "undo" "Undo last operation")
|
|
396 (kill-region (letter) "cut"
|
|
397 "Cut (kill) text in region between mark and current position")
|
|
398 (menu-bar-kill-ring-save (letter) "copy"
|
|
399 "Copy text in region between mark and current position")
|
|
400 (yank (letter) "paste" "Paste (yank) text cut or copied earlier")
|
|
401 (mh-fully-kill-draft (letter) "close" "Kill this draft")
|
|
402 ;; Common buttons
|
|
403 (mh-tool-bar-customize (folder letter) "preferences" "MH-E Preferences")
|
|
404 (mh-tool-bar-folder-help (folder) "help"
|
|
405 "Help! (general help)\nThis button runs `info'")
|
|
406 (mh-tool-bar-letter-help (letter) "help"
|
|
407 "Help! (general help)\nThis button runs `info'")
|
|
408 ;; Folder narrowed to sequence buttons
|
|
409 (mh-widen (sequence) "widen"
|
|
410 "Widen from the sequence\nThis button runs `mh-widen'"))
|
|
411
|
|
412 (provide 'mh-tool-bar)
|
|
413
|
|
414 ;; Local Variables:
|
|
415 ;; indent-tabs-mode: nil
|
|
416 ;; sentence-end-double-space: nil
|
|
417 ;; End:
|
|
418
|
68470
|
419 ;; arch-tag: 28c2436d-bb8d-486a-a8d7-5a4d9cae3513
|
68465
|
420 ;;; mh-tool-bar.el ends here
|