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