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