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