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