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