Update.
[elisp.git] / vm
1 ;; -*- mode: Emacs-Lisp; mode: rainbow; -*-
2
3 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
4 ;; This program is free software: you can redistribute it and/or modify  ;;
5 ;; it under the terms of the version 3 of the GNU General Public License ;;
6 ;; as published by the Free Software Foundation.                         ;;
7 ;;                                                                       ;;
8 ;; This program is distributed in the hope that it will be useful, but   ;;
9 ;; WITHOUT ANY WARRANTY; without even the implied warranty of            ;;
10 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU      ;;
11 ;; General Public License for more details.                              ;;
12 ;;                                                                       ;;
13 ;; You should have received a copy of the GNU General Public License     ;;
14 ;; along with this program. If not, see <http://www.gnu.org/licenses/>.  ;;
15 ;;                                                                       ;;
16 ;; Written by and Copyright (C) Francois Fleuret                         ;;
17 ;; Contact <francois@fleuret.org> for comments & bug reports             ;;
18 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
19
20 (setq-default vm-summary-show-threads t)
21
22 ;; (setq vm-preview-lines nil)
23
24 ;; (setq vm-auto-displayed-mime-content-types '("text"));; "multipart"));; "image/xpm"
25
26 (setq vm-mime-thumbnail-max-geometry nil)
27
28 (setq vm-auto-displayed-mime-content-types '(
29                                              "text"
30                                              ;; "image/jpeg"
31                                              ;; "image/png"
32                                              "multipart"
33                                              "message/rfc822"
34                                              ))
35
36
37 (setq vm-startup-message-displayed t ;; Yes, we already saw it, no need to insist
38       vm-use-menus nil
39       vm-skip-deleted-messages nil
40       vm-skip-read-messages nil
41       vm-use-toolbar nil
42       ;; vm-jump-to-new-messages nil
43       vm-startup-with-summary t
44       ;; vm-preview-read-messages t
45       vm-preview-lines nil
46       vm-auto-get-new-mail t
47       vm-circular-folders nil
48       vm-confirm-new-folders t
49       vm-mutable-windows t
50       vm-mutable-frames nil
51       vm-summary-thread-indent-level 1
52       ;; vm-summary-uninteresting-senders-arrow "->"
53       ;; vm-summary-uninteresting-senders-arrow "►"
54       vm-summary-uninteresting-senders-arrow ">"
55       ;; vm-summary-uninteresting-senders-arrow "➔"
56       ;; vm-summary-uninteresting-senders-arrow "➤"
57       vm-summary-arrow "> "
58       vm-included-text-prefix " > "
59       vm-forwarding-digest-type "mime"
60       vm-mime-attachment-save-directory "~/misc/attachments"
61       vm-use-toolbar nil
62       vm-frame-per-folder nil
63       vm-frame-per-summary nil
64       vm-mime-yank-attachments nil
65
66       ;; vm-mime-7bit-composition-charset "latin-1"
67       vm-mime-8bit-composition-charset "iso-8859-1"
68       ;; vm-mime-8bit-composition-charset "utf-8"
69       ;; browse-url-mozilla-program "iceweasel"
70       vm-netscape-program browse-url-mozilla-program
71       ;; vm-coding-system-priorities '(utf-8)
72       ;; mail-from-style nil
73       ;; mail-complete-style nil
74
75       ;; vm-summary-format " %*%A %-3.3m %2d %5US %I%UA  %s\n"
76       vm-summary-format " %*%a %-3.3m %2d %5US %I%UA  %s\n"
77       ;; vm-highlighted-header-regexp "From:\\|Subject:\\|Cc:\\|To:\\|Bcc:\\|Reply-To:"
78       vm-highlighted-header-regexp "From:\\|Subject:\\|Reply-To:"
79
80       vm-auto-folder-case-fold-search t
81
82       vm-keep-sent-messages nil
83       vm-delete-after-saving t
84       vm-delete-after-archiving t
85
86       vm-forwarding-subject-format "(forwarded from %F) %s"
87       vm-in-reply-to-format nil
88       vm-included-text-attribution-format "\nOn %w, %m %d, %y (%h), %F wrote:\n\n"
89       ;; vm-included-text-attribution-format "\nOn %w, %m %d, at %H, you wrote:\n\n"
90       vm-reply-subject-prefix "Re: "
91
92       mail-signature t
93       mail-specify-envelope-from t
94
95       bbdb/mail-auto-create-p nil
96       bbdb-send-mail-style 'vm
97
98       )
99
100 ;; (add-to-list 'vm-visible-headers "From " t)
101 (add-to-list 'vm-visible-headers "Reply-To:" t)
102 ;; (add-to-list 'vm-visible-headers "X-Mailer:" t)
103 ;; (add-to-list 'vm-visible-headers "X-from-in-bbdb:" t)
104 ;; (add-to-list 'vm-visible-headers "Return-Path:")
105
106 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
107 ;; Mime-related stuff
108
109 (setq
110
111  ;; vm-auto-displayed-mime-content-types '("text/plain" "text" "image" "multipart")
112  ;; vm-display-using-mime t
113  ;; vm-coding-system-priorities '(iso-8859-1 iso-8859-15 utf-8)
114
115  vm-infer-mime-types t
116  vm-mime-use-image-strips nil
117  vm-mime-base64-decoder-program "base64"
118  vm-mime-base64-decoder-switches '("-d")
119  vm-mime-base64-encoder-program "base64"
120  vm-mime-base64-encoder-switches '()
121
122  ;; vm-auto-displayed-mime-content-types '(
123                                         ;; ;; "plain text"
124                                         ;; "text"
125                                         ;; "multipart"
126                                         ;; "image/xpm"
127                                         ;; )
128
129  ;; vm-auto-displayed-mime-content-type-exceptions '("text/html")
130
131  vm-mime-internal-content-types '(
132                                   "multipart"
133                                   "text"
134                                   ;; "plain text"
135                                   ;; "plain text/utf8"
136                                   "image/xpm"
137                                   )
138
139  ;; To force it to be converted to plain text
140  ;; vm-mime-internal-content-type-exceptions '("text/html")
141
142  vm-mime-external-content-types-alist  '(
143                                          ("application/x-dvi"      "xdvi")
144                                          ("image/postscript"       "gv")
145                                          ("application/pdf"        "xpdf")
146                                          ;; ("application/pdf"        "epdfview")
147                                          ("application/postscript" "gv")
148                                          ;;("image"                  "feh")
149                                          ("video"                  "mplayer")
150                                          ;; ("text/html"             "iceweasel")
151                                          )
152
153  )
154
155 (require 'vm-rfaddons)
156
157 ;; (add-to-list 'vm-mime-default-face-charsets  "utf-8")
158
159 (add-to-list 'vm-mime-default-face-charsets  "iso-8859-1")
160 ;; (add-hook 'vm-mail-send-hook 'ff/vm-remove-non-7bits-in-headers)
161 (add-hook 'vm-mail-send-hook 'vm-mime-encode-headers)
162 (add-hook 'vm-mail-send-hook 'vm-mail-check-recipients)
163 (add-hook 'vm-reply-hook (lambda () (set-buffer-modified-p nil)))
164
165 (add-to-list 'vm-mime-attachment-auto-type-alist '(".*" . "application/octet-stream") t)
166
167 ;; (add-to-list 'vm-mime-type-converter-alist '("text/html" "text/plain" "cat"))
168 ;; (add-to-list 'vm-mime-type-converter-alist '("text/html" "text/plain" "lynx -nolist -force_html -dump -stdin"))
169
170 ;; (add-to-list 'vm-mime-type-converter-alist
171 ;; '("text/html" "text/plain"
172 ;; "w3m -cols 75 -graph -dump -T text/html"
173 ;; ))
174
175 ;; (add-to-list 'vm-mime-type-converter-alist
176              ;; '("text/html" "text/plain"
177                ;; "html2text -style pretty -nobs"
178                ;; ))
179
180 ;; (add-to-list 'vm-mime-type-converter-alist
181              ;; '("text/html" "text/plain"
182                ;; "html2text.sh"
183                ;; ))
184
185 (add-to-list 'vm-mime-type-converter-alist
186              '("image" "image/xpm"
187                "/usr/bin/convert -geometry 640x480 - xpm:-"))
188
189 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
190
191 ;; (defun ff/vm-remove-properties () (interactive)
192 ;; (save-excursion
193 ;; (goto-char (point-min))
194 ;; (re-search-forward (concat "^" mail-header-separator "$"))
195 ;; (set-text-properties (point) (point-max) nil)
196 ;; )
197 ;; )
198
199 ;; (add-hook 'vm-mail-send-hook 'ff/vm-remove-properties)
200
201 ;; (defun ff/vm-mime-save-all-files (&optional delete)
202   ;; "Save all the mail attachments. With delete argument, remove
203 ;; the attachement from mail."
204   ;; (interactive "P")
205   ;; (let ((vm-mime-delete-after-saving delete))
206     ;; (while (and (vm-mime-reader-map-save-file)
207                 ;; (condition-case nil (vm-move-to-next-button 1)
208                   ;; (error nil)))))
209   ;; )
210
211 (defun ff/vm-mime-save-file (&optional delete)
212   "Save the current attachement. With delete argument, remove the
213 attachement from mail."
214   (interactive "P")
215   (let ((vm-mime-delete-after-saving delete))
216     (vm-mime-reader-map-save-file))
217   (condition-case nil (vm-move-to-next-button 1) (error (message "No more attachment"))))
218
219 ;; (define-key vm-summary-mode-map [(r)] 'vm-reply-include-text)
220 ;; (define-key vm-summary-mode-map [(R)] 'vm-followup-include-text)
221
222 (define-key vm-summary-mode-map [(control o)] 'ff/vm-mime-save-file)
223
224 (define-key vm-summary-mode-map [(control t)]
225   (lambda () (interactive)
226     (vm-toggle-threads-display)
227     (unless vm-summary-show-threads
228       (vm-sort-messages "date"))))
229
230 (defun ff/vm-select-thread-for-next-command () (interactive)
231   (vm-mark-thread-subtree)
232   (vm-next-command-uses-marks))
233
234 (define-key vm-summary-mode-map "T" 'ff/vm-select-thread-for-next-command)
235
236 (defun ff/vm-attach-file-or-dir
237   (&optional dir)
238   "Attaches the file or recursively the content of the directory with
239 `vm-mime-attach-file'."
240   (interactive "fFile or directory: ")
241
242   (save-excursion
243     (goto-char (point-max))
244     (insert "\n")
245     (if (file-regular-p dir)
246         (vm-mime-attach-file dir (vm-mime-default-type-from-filename dir))
247       (if (file-directory-p dir)
248           (mapcar
249            (lambda (x)
250              (when (not (string-match "^\\." (car x)))
251                (ff/vm-attach-file-or-dir
252                 (concat dir
253                         (unless (string-match "/$" dir) "/")
254                         (car x)))))
255            (directory-files-and-attributes dir)
256            )
257
258         (error "Can attach only files and directories")
259         ))))
260
261 (define-key vm-mail-mode-map [(control c) (control a)] 'ff/vm-attach-file-or-dir)
262
263 ;; Found no other way to avoid displaying the icones
264 (load "vm-mime")
265 (defun vm-mime-set-image-stamp-for-type (e type))
266
267 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
268 ;; Summary stuff
269
270 (defun vm-summary-function-A (message)
271   (let* ((from (vm-su-from message)))
272     (if (string-match vm-summary-uninteresting-senders from)
273         (concat vm-summary-uninteresting-senders-arrow " " (ff/explicit-name (vm-su-to message)))
274       (ff/explicit-name from))))
275
276 (defun vm-summary-function-S (&optional message)
277   (let ((s (string-to-int (vm-su-byte-count message))))
278     (if (> s 32768)
279         (propertize (concat (int-to-string (/ s 1024)) "k")
280                     'face 'italic
281                     )
282       "")))
283
284 (defun ff/vm-delete-and-go-down () (interactive)
285   ;; (vm-goto-message)
286   (vm-delete-message 1)
287   (condition-case nil (vm-next-message-no-skip 1) (error nil)))
288
289 (add-hook 'vm-quit-hook 'vm-expunge-folder)
290 (add-hook 'vm-quit-hook 'bbdb-save-db)
291 (add-hook 'vm-retrieved-spooled-mail-hook 'display-time-update)
292
293 (ff/configure-faces '((ff/summary-highlight-face :background "yellow"
294                                                  ;; :weight 'bold
295                                                  )))
296
297 (setq vm-summary-highlight-face 'ff/summary-highlight-face)
298
299 (define-key vm-summary-mode-map [(K)] 'ff/vm-delete-and-go-down)
300
301 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
302 ;; Activate the required modes and authorize the commenting
303
304 (defun ff/prepare-mail-mode ()
305   (bbdb-define-all-aliases)
306   (flyspell-mode)
307   (auto-fill-mode)
308   (mail-abbrevs-setup)
309
310   ;; (setq fill-paragraph-function 'mail-mode-fill-paragraph)
311
312   ;; Since I set the comment prefix, I have to tell the filling
313   ;; functions not to use it
314
315   ;; ******************* removed Aug 23
316   ;; (setq fill-paragraph-handle-comment nil)
317   ;; ;; (when message-yank-prefix
318   (set (make-local-variable 'comment-start) vm-included-text-prefix)
319   ;; (set (make-local-variable 'comment-start-skip)
320   ;; (concat "^\\(" (regexp-quote vm-included-text-prefix) "\\)"))
321   ;; ;; )
322   )
323
324 (add-hook 'mail-mode-hook 'ff/prepare-mail-mode)
325 ;; (add-hook 'mail-mode-hook 'orgtbl-mode)
326
327 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
328 ;; To have a slightly darker background for headers
329
330 (ff/configure-faces
331  ;; '((ff/mail-header-face :background "#c8c8ff"))
332  '((ff/mail-header-face :foreground "blue4"))
333  )
334
335 (defun ff/colorize-headers () (interactive)
336   (let ((inhibit-read-only t))
337     (save-excursion
338       (goto-char (point-min))
339       (while (vm-match-header)
340         (goto-char (vm-matched-header-end)))
341       (add-text-properties
342        ;; (vm-matched-header-contents-start)
343        ;; (vm-matched-header-contents-end)
344        (point-min)
345        (point-at-bol)
346        '(face ff/mail-header-face)
347        )
348       )))
349
350 (defadvice vm-highlight-headers (after ff/colorize-headers nil activate)
351   (ff/colorize-headers))
352
353 (defun ff/highlight-important-words ()
354   (let ((inhibit-read-only t))
355     (save-excursion
356       (goto-char (point-min))
357       (while (re-search-forward "Fleuret" nil t)
358         (message "%d-%d"  (match-beginning 0) (match-end 0))
359         ;; (add-text-properties (match-beginning 0) (match-end 0)
360                              ;; '(face (:background "red"))
361                              ;; )
362         ))
363     ))
364
365 ;; (add-hook 'vm-select-message-hook 'ff/highlight-important-words)
366
367 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
368 ;; I want to have a file associated to every mail I am writing
369
370 (defcustom ff/vm-mail-draft-directory "~/"
371   "Where to save mail drafts with VM")
372
373 (defun ff/associate-file-to-vm-mail-buffer ()
374   "Associate the current buffer to a file whose name is built from the current time."
375   (unless (buffer-file-name)
376     (set-visited-file-name (format
377                             "%s/mail-%s"
378                             ff/vm-mail-draft-directory
379                             (format-time-string
380                              "%04Y%02m%02d-%02H%02M%02S"
381                              (current-time))))
382     (set-buffer-modified-p nil)))
383
384 (add-hook 'mail-setup-hook 'ff/associate-file-to-vm-mail-buffer)
385
386 (defun ff/mail-header-field (field) (interactive)
387   "Grab the value of a certain field from the mail header."
388   (let ((s "no-subject"))
389     (save-excursion
390       (goto-char (point-min))
391       (let ((l (re-search-forward (concat "^" mail-header-separator "$") nil t)))
392         (when l
393           (goto-char (point-min))
394           (when (re-search-forward (concat "^" field ": ") l t nil)
395             (setq s (buffer-substring-no-properties (point) (point-at-eol))))
396           )
397         )
398       )
399     s))
400
401 (defun ff/dissociate-file-from-vm-mail-buffer ()
402   "Save the file under a new name and set the associated file to nil."
403   (let ((bn (buffer-file-name)))
404     (when bn
405       (set-visited-file-name
406        (concat (file-name-directory bn)
407                "sent-"
408                (file-name-nondirectory bn)
409                "-"
410                (replace-regexp-in-string "[^a-zA-Z0-9]+" "_"
411                                          (ff/mail-header-field "Subject"))
412                ))
413       (save-buffer)
414       (set-visited-file-name nil))
415     )
416   )
417
418 (defun ff/find-file-in-vm-mail-mode (filename) (interactive)
419   ;; No easy way to activate vm-mail-mode, so we create such a
420   ;; buffer, erase its content and insert the file
421   (vm-compose-mail)
422   (when (file-exists-p filename)
423     (erase-buffer)
424     (insert-file filename))
425   (set-visited-file-name filename)
426   (set-buffer-modified-p nil)
427   ;; (run-hooks find-file-hooks)
428   (when (functionp 'alarm-vc-check) (alarm-vc-check))
429   ;; Move the cursor at a convenient location
430   (when (re-search-forward (concat "^" mail-header-separator "$") nil t)
431     (if (re-search-forward "^-- $" nil t)
432         (previous-line 1)
433       (next-line 1))
434     (end-of-line))
435   )
436
437 ;; All this mess to activate the vm-mail-mode when loading a file
438 ;; looking like a mail draft. Did I miss something ?
439
440 (defadvice find-file (around ff/find-file-or-mail
441                              (filename &optional wildcards)
442                              activate)
443
444   (interactive "FFind file: \np")
445
446   (if (string-match "^\\(mail\\|sent\\)-[^/]+$"
447                     (file-name-nondirectory filename))
448
449       (if (find-buffer-visiting filename)
450           (switch-to-buffer (find-buffer-visiting filename))
451         (ff/find-file-in-vm-mail-mode filename))
452     ad-do-it
453     ))
454
455 (setq ff/vm-mail-draft-directory "~/private/drafts")
456
457 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
458 ;; Check there are no missing attachment (the idea comes from
459 ;; http://home.cc.gatech.edu/eaganj/MailApp) and no leading "From"
460 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
461
462 (defcustom ff/check-vm-attachement-regexp "attach"
463   "*A mail whose body matches this regular expression should contain
464 an attachment")
465
466 (defun ff/check-vm-attachment ()
467   (when (save-excursion
468           (goto-char (point-min))
469           (and (re-search-forward "\\[ATTACHMENT" nil t)
470                (not (get-text-property (point) 'vm-mime-object))))
471     (error "Buggy attachment"))
472
473   (if (and
474        (save-excursion (goto-char (point-min))
475                        (re-search-forward ff/check-vm-attachement-regexp nil t))
476        (not (save-excursion (goto-char (point-min))
477                             (re-search-forward "\\[ATTACHMENT" nil t)))
478        (not (y-or-n-p "An attachment seems to be missing, send message ? ")))
479       (error "You refer to an unexisting attachment."))
480
481   )
482
483 ;; You can not have a line starting with "From:" in a pure text
484 ;; mail. The smtp server would add a leading character to prevent it.
485
486 (defun ff/check-no-leading-from ()
487   (and (let ((case-fold-search nil))
488          (save-excursion
489            (goto-char (point-min))
490            (re-search-forward (concat "^" mail-header-separator "$"))
491            (re-search-forward "^From " nil t)))
492        (not (y-or-n-p "There is a leading ``From '', send message ? "))
493        (error "There is a leading ``From ''.")))
494
495 ;; An attempt at limiting excess wording in sent mails
496
497 (defface ff/strong-words
498   '((t (:background "red")))
499   "The face to highlight upper caps, exclamation marks and such.")
500
501 (defun ff/max-in-a-row (overlay regexp max)
502   (let ((case-fold-search nil))
503     (save-excursion
504       (goto-char (point-min))
505       (re-search-forward (concat "^" mail-header-separator "$"))
506       (when (and (re-search-forward regexp nil t nil)
507                  (>= (- (match-end 0) (match-beginning 0)) max))
508         (move-overlay overlay (match-beginning 0) (match-end 0))
509         t))))
510
511 (defun ff/check-no-excess-wording () (interactive)
512   (let ((overlay (make-overlay 0 0)))
513     (overlay-put overlay 'face 'media/current-tune-face)
514     (let ((err (and
515                 (or (ff/max-in-a-row overlay "[A-Z\?\!][A-Z\?\! ]+[A-Z\?\!]" 6)
516                     (ff/max-in-a-row overlay "[\?\!]+" 2)
517                     )
518                 (not (y-or-n-p "That does not look good. Send message ? ")))))
519       (delete-overlay overlay)
520       (when err (error "Good idea. Chill out a bit.")))
521     ))
522
523 (defun ff/check-badly-encoded-address () (interactive)
524   (let (bodysep bad-adr)
525     (save-excursion
526       (goto-char (point-min))
527       (search-forward mail-header-separator)
528       (setq bodysep (vm-marker (match-beginning 0)))
529       (goto-char (point-min))
530       (setq bad-adr (re-search-forward "[^<a-zA-Z_0-9\-\. \n\t]+[^ \n]*@" nil t))
531       (when (and bad-adr (< bad-adr bodysep))
532         (error "There is an invalid address in the header (%s)"
533                (match-string 0)))))
534   )
535
536 (add-hook 'vm-mail-send-hook 'ff/check-vm-attachment)
537 (add-hook 'vm-mail-send-hook 'ff/check-no-leading-from)
538 (add-hook 'vm-mail-send-hook 'ff/check-no-excess-wording)
539 (add-hook 'vm-mail-send-hook 'flyspell-mode-off)
540 ;; Append so that it happens after the mime encoding
541 ;; (add-hook 'vm-mail-send-hook 'ff/check-badly-encoded-address t)
542 ;; Append this hook so that it runs after all other checks
543 (add-hook 'vm-mail-send-hook 'ff/dissociate-file-from-vm-mail-buffer t)
544
545 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
546 ;; If we can, encrypt!
547
548 (add-hook 'vm-mode-hook 'mc-install-read-mode)
549 (add-hook 'vm-summary-mode-hook 'mc-install-read-mode)
550 (add-hook 'vm-virtual-mode-hook 'mc-install-read-mode)
551 (add-hook 'vm-mail-mode-hook 'mc-install-write-mode)
552
553 ;; (defun ff/encrypt-mail-if-possible () (interactive)
554 ;; (condition-case nil (mc-encrypt)
555 ;; (error nil)))
556
557 ;; (add-hook 'vm-mail-send-hook 'ff/encrypt-mail-if-possible t)
558
559 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
560 ;; Composing a mail
561
562 ;; Move through important points in the mail ("To:" field, "Subject:"
563 ;; field and the end of the body)
564
565 (defun ff/goto-next-mail-field () (interactive)
566   (let ((field (save-excursion
567                  (end-of-line)
568                  (re-search-backward (concat "\\(^[a-zA-Z\-]*: \\|^" mail-header-separator "$\\)") nil t)
569                  (match-string 1))))
570
571     (cond ((string= field "To: ")
572            (expand-abbrev)
573            (re-search-forward "Subject: ")
574            (end-of-line))
575
576           ((string= field "Subject: ")
577            (re-search-forward (concat "^" mail-header-separator "$"))
578            (if (re-search-forward "^-- $" nil t)
579                (previous-line 1)
580              (next-line 1))
581            (end-of-line))
582
583           (t (beginning-of-buffer)
584              (re-search-forward "^To: ")
585              (end-of-line)
586              (re-search-forward "^[a-zA-Z\-]*: ")
587              (beginning-of-line)
588              (backward-char)))))
589
590 ;; (define-key vm-mail-mode-map [(control tab)] 'ff/goto-next-mail-field)
591 (define-key vm-mail-mode-map [(iso-lefttab)] 'ff/goto-next-mail-field)
592 ;; (define-key vm-mail-mode-map [(shift iso-lefttab)] 'mail-mode-smart-tab)
593 (define-key vm-mail-mode-map [(shift iso-lefttab)] 'bbdb-complete-name)
594
595 ;; The definition of "\t" is forced through a hook defined in
596 ;; vm-init.el, so I add mine. This is ugly.
597
598 (add-hook 'mail-setup-hook
599           '(lambda () (local-set-key "\t" 'ff/goto-next-mail-field))
600           t)
601
602 (substitute-key-definition 'next-line 'mail-abbrev-next-line vm-mail-mode-map global-map)
603 (substitute-key-definition 'end-of-buffer 'mail-abbrev-end-of-buffer vm-mail-mode-map global-map)
604
605 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
606 ;; I rarely edit two mails at the same time, and it makes sense to
607 ;; come back to the one currently being edited with the same function
608
609 (defun ff/first-buffer-in-mode (l m)
610   (if l
611       (if (eq (save-excursion
612                 (set-buffer (car l)) major-mode) m)
613           (car l)
614         (ff/first-buffer-in-mode (cdr l) m))))
615
616 (defun ff/compose-mail (&optional force-new)
617   "Cycles through an existing buffers with major mode `mail-mode',
618 or invoke `vm-compose-mail' if none can be found or if FORCE-NEW
619 is t."
620   (interactive "P")
621   (when (eq major-mode 'mail-mode) (bury-buffer))
622   (let ((buf (and (not force-new)
623                   (ff/first-buffer-in-mode (buffer-list) 'mail-mode))))
624     (if buf (switch-to-buffer buf)
625       (vm-compose-mail))))
626
627 (define-key global-map [(control x) (m)] 'ff/compose-mail)
628
629 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
630 ;; bbdb
631
632 (load "bbdb")
633 (load "bbdb-hooks")
634
635 (when (load "bbdb-vm" t)
636
637   ;; (defadvice define-mail-abbrev (before ff/remove-explicit-name (name definition &optional from-mailrc-file) activate)
638   ;; (message "%s -> %s" name definition))
639
640   (defun ff/mail-aliases-from-bbdb ()
641     "Creates automatically mail aliases from the bbdb records. For
642 instance, someone in bbdb named \"Paul Smith\" would generate an alias
643 'pm'. Does not replace existing aliases."
644     (interactive)
645     (let* ((records (bbdb-records)))
646       (while records
647         (let* ((record (car records))
648                (name (concat (elt record 0) " " (elt record 1)))
649                (email (car (elt record 6)))
650                (alias (downcase (replace-regexp-in-string "\\([a-zA-Z]?\\)[^- ]*[- ]*" "\\1" name))))
651           (if (and (> (length alias) 1)
652                    ;; Do not overwrite an existing alias
653                    (not (and mail-abbrevs (intern-soft alias mail-abbrevs))))
654               (define-mail-abbrev alias email))
655           (setq records (cdr records))))))
656
657   (when (>= emacs-major-version 22)
658     (bbdb-insinuate-vm)
659     (ff/mail-aliases-from-bbdb))
660   )