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