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