1 ;; -*- mode: Emacs-Lisp; mode: rainbow; -*-
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. ;;
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. ;;
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/>. ;;
16 ;; Written by and Copyright (C) Francois Fleuret ;;
17 ;; Contact <francois@fleuret.org> for comments & bug reports ;;
18 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
20 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
21 ;; A fast indexed / search in mbox
22 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
23 ;; This is one of my own things, check my web page to get it
25 (when (ff/load-or-alert "~/sources/gpl/mymail/mymail-vm.el")
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")
34 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
36 ;; Store and restore the window configuration
38 (setq ff/window-configuration-before-vm nil)
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)))
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)
52 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
54 (setq-default vm-summary-show-threads t)
56 ;; (setq vm-preview-lines nil)
58 ;; (setq vm-auto-displayed-mime-content-types '("text"));; "multipart"));; "image/xpm"
60 (setq vm-mime-thumbnail-max-geometry nil)
62 (setq vm-auto-displayed-mime-content-types '(
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
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
111 vm-netscape-program browse-url-mozilla-program
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 ">"
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:")
133 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
134 ;; Mime-related stuff
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 '()
145 vm-mime-internal-content-types '(
153 ;; To force it to be converted to plain text
154 ;; vm-mime-internal-content-type-exceptions '("text/html")
156 vm-mime-external-content-types-alist '(
157 ("application/x-dvi" "xdvi")
158 ("image/postscript" "gv")
159 ("application/pdf" "xpdf")
160 ("application/postscript" "gv")
163 ;; ("text/html" "firefox")
164 ;; ("application/pdf" "epdfview")
169 (require 'vm-rfaddons)
171 ;; The two following lines deal with windows-1252 buggy encoding
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))
178 ;; (setq vm-mime-default-face-charsets t)
180 ;; (add-to-list 'vm-mime-default-face-charsets "utf-8")
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)
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)))
190 (add-to-list 'vm-mime-attachment-auto-type-alist '(".*" . "application/octet-stream") t)
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"))
195 ;; (add-to-list 'vm-mime-type-converter-alist
196 ;; '("text/html" "text/plain"
197 ;; "w3m -cols 75 -graph -dump -T text/html"
200 ;; (add-to-list 'vm-mime-type-converter-alist
201 ;; '("text/html" "text/plain"
202 ;; "html2text -style pretty -nobs"
205 ;; (add-to-list 'vm-mime-type-converter-alist
206 ;; '("text/html" "text/plain"
210 (add-to-list 'vm-mime-type-converter-alist
211 '("image" "image/xpm"
212 "/usr/bin/convert -geometry 640x480 - xpm:-"))
214 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
216 ;; (defun ff/vm-remove-properties () (interactive)
218 ;; (goto-char (point-min))
219 ;; (re-search-forward (concat "^" mail-header-separator "$"))
220 ;; (set-text-properties (point) (point-max) nil)
224 ;; (add-hook 'vm-mail-send-hook 'ff/vm-remove-properties)
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."
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)
236 (defun ff/vm-mime-save-file (&optional delete)
237 "Save the current attachement. With delete argument, remove the
238 attachement from mail."
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"))))
244 ;; (define-key vm-summary-mode-map [(r)] 'vm-reply-include-text)
245 ;; (define-key vm-summary-mode-map [(R)] 'vm-followup-include-text)
247 (define-key vm-summary-mode-map [(control o)] 'ff/vm-mime-save-file)
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"))))
255 (defun ff/vm-select-thread-for-next-command () (interactive)
256 (vm-mark-thread-subtree)
257 (vm-next-command-uses-marks))
259 (define-key vm-summary-mode-map "T" 'ff/vm-select-thread-for-next-command)
261 (defun ff/vm-attach-file-or-dir
263 "Attaches the file or recursively the content of the directory with
264 `vm-mime-attach-file'."
265 (interactive "fFile or directory: ")
268 (goto-char (point-max))
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)
275 (when (not (string-match "^\\." (car x)))
276 (ff/vm-attach-file-or-dir
278 (unless (string-match "/$" dir) "/")
280 (directory-files-and-attributes dir)
283 (error "Can attach only files and directories")
286 (define-key vm-mail-mode-map [(control c) (control a)] 'ff/vm-attach-file-or-dir)
288 ;; Found no other way to avoid displaying the icones
290 (defun vm-mime-set-image-stamp-for-type (e type))
292 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
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))))
301 (defun vm-summary-function-S (&optional message)
302 (let ((s (string-to-int (vm-su-byte-count message))))
304 (propertize (concat (int-to-string (/ s 1024)) "k")
309 (defun ff/vm-delete-and-go-down () (interactive)
311 (vm-delete-message 1)
312 (condition-case nil (vm-next-message-no-skip 1) (error nil)))
314 (defun ff/vm-expunge-folder ()
315 (unless vm-folder-read-only (vm-expunge-folder)))
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)
321 (ff/configure-faces '((ff/summary-highlight-face :background "yellow"
325 (setq vm-summary-highlight-face 'ff/summary-highlight-face)
327 (define-key vm-summary-mode-map [(K)] 'ff/vm-delete-and-go-down)
329 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
330 ;; Activate the required modes and authorize the commenting
332 (defun ff/does-not-fill (&optional a b) (interactive) (message "Nope"))
334 (defun ff/prepare-mail-mode ()
335 (bbdb-define-all-aliases)
340 ;; Let's try the visual-line mode for mails
343 ;; (setq fill-paragraph-function 'ff/does-not-fill)
344 ;; (visual-line-mode)
346 (set (make-local-variable 'comment-start) vm-included-text-prefix)
349 (add-hook 'mail-mode-hook 'ff/prepare-mail-mode)
351 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
352 ;; To have a slightly darker background for headers
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"))
361 (defun ff/colorize-headers () (interactive)
362 (let ((inhibit-read-only t))
364 (goto-char (point-min))
365 (while (vm-match-header)
366 (goto-char (vm-matched-header-end)))
368 ;; (vm-matched-header-contents-start)
369 ;; (vm-matched-header-contents-end)
372 '(face ff/mail-header-face)
376 (defadvice vm-highlight-headers (after ff/colorize-headers nil activate)
377 (ff/colorize-headers))
379 (defun ff/highlight-important-words ()
380 (let ((inhibit-read-only t))
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"))
391 ;; (add-hook 'vm-select-message-hook 'ff/highlight-important-words)
393 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
394 ;; I want to have a file associated to every mail I am writing
396 (defcustom ff/vm-mail-draft-directory "~/"
397 "Where to save mail drafts with VM")
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
404 ff/vm-mail-draft-directory
406 "%04Y%02m%02d-%02H%02M%02S"
408 (set-buffer-modified-p nil)))
410 (add-hook 'mail-setup-hook 'ff/associate-file-to-vm-mail-buffer)
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"))
416 (goto-char (point-min))
417 (let ((l (re-search-forward (concat "^" mail-header-separator "$") nil t)))
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))))
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)))
431 (set-visited-file-name
432 (concat (file-name-directory bn)
434 (file-name-nondirectory bn)
436 (replace-regexp-in-string "[^a-zA-Z0-9]+" "_"
437 (ff/mail-header-field "Subject"))
440 (set-visited-file-name nil))
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
448 (when (file-exists-p filename)
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)
463 ;; All this mess to activate the vm-mail-mode when loading a file
464 ;; looking like a mail draft. Did I miss something ?
466 (defadvice find-file (around ff/find-file-or-mail
467 (filename &optional wildcards)
470 (interactive "FFind file: \np")
472 (if (string-match "^\\(mail\\|sent\\)-[^/]+$"
473 (file-name-nondirectory filename))
475 (if (find-buffer-visiting filename)
476 (switch-to-buffer (find-buffer-visiting filename))
477 (ff/find-file-in-vm-mail-mode filename))
481 (setq ff/vm-mail-draft-directory "~/private/drafts")
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 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
488 (defcustom ff/check-vm-attachement-regexp "attach"
489 "*A mail whose body matches this regular expression should contain
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"))
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."))
509 (defun ff/check-no-prolematic-dest ()
510 "Check that there are no \">,[^\ $]\" in the header"
511 (let ((s "no-subject"))
513 (goto-char (point-min))
514 (let ((end-header (re-search-forward (concat "^" mail-header-separator "$") nil t)))
516 (goto-char (point-min))
517 (re-search-forward ">,[^\ ]" end-header t nil)
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.
526 (defun ff/check-no-leading-from ()
527 (and (let ((case-fold-search nil))
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 ''.")))
535 ;; An attempt at limiting excess wording in sent mails
537 (defface ff/strong-words
538 '((t (:background "red")))
539 "The face to highlight upper caps, exclamation marks and such.")
541 (defun ff/max-in-a-row (overlay regexp max)
542 (let ((case-fold-search nil))
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))
551 (defun ff/check-no-excess-wording () (interactive)
552 (let ((overlay (make-overlay 0 0)))
553 (overlay-put overlay 'face 'media/current-tune-face)
555 (or (ff/max-in-a-row overlay "[A-Z\?\!][A-Z\?\! ]+[A-Z\?\!]" 6)
556 (ff/max-in-a-row overlay "[\?\!]+" 2)
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.")))
563 (defun ff/check-badly-encoded-address () (interactive)
564 (let (bodysep bad-adr)
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)"
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)
581 (defadvice vm-mail-send-and-exit (before ff/switch-flyspell-off nil activate)
584 ;; Append so that it happens after the mime encoding
585 ;; (add-hook 'vm-mail-send-hook 'ff/check-badly-encoded-address t)
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)
590 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
591 ;; If we can, encrypt!
593 ;; (autoload 'mc-install-write-mode "mailcrypt" nil t)
594 ;; (autoload 'mc-install-read-mode "mailcrypt" nil t)
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)
602 ;; (defun ff/encrypt-mail-if-possible () (interactive)
603 ;; (condition-case nil (mc-encrypt-message)
606 ;; (add-hook 'vm-mail-send-hook 'ff/encrypt-mail-if-possible t)
608 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
611 ;; Move through important points in the mail ("To:" field, "Subject:"
612 ;; field and the end of the body)
614 (defun ff/goto-next-mail-field () (interactive)
615 (let ((field (save-excursion
618 (concat "\\(^[a-zA-Z\-]*: \\|^" mail-header-separator "$\\)") nil t)
621 (cond ((string= field "To: ")
623 (re-search-forward "Subject: ")
626 ((string= field "Subject: ")
627 (re-search-forward (concat "^" mail-header-separator "$"))
628 (if (re-search-forward "^-- $" nil t)
633 (t (beginning-of-buffer)
634 (re-search-forward "^To: ")
636 (re-search-forward "^[a-zA-Z\-]*: ")
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)
645 ;; The definition of "\t" is forced through a hook defined in
646 ;; vm-init.el, so I add mine. This is ugly.
648 (add-hook 'mail-setup-hook
649 '(lambda () (local-set-key "\t" 'ff/goto-next-mail-field))
652 (substitute-key-definition 'next-line 'mail-abbrev-next-line vm-mail-mode-map global-map)
654 (substitute-key-definition 'end-of-buffer 'mail-abbrev-end-of-buffer vm-mail-mode-map global-map)
656 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
657 ;; I rarely edit two mails at the same time, and it makes sense to
658 ;; come back to the one currently being edited with the same function
660 (defun ff/first-buffer-in-mode (l m)
663 ;; (save-excursion (set-buffer (car l)) major-mode)
664 (with-current-buffer (car l) major-mode)
667 (ff/first-buffer-in-mode (cdr l) m))))
669 (defun ff/compose-mail (&optional force-new)
670 "Cycles through existing buffers with major mode `mail-mode',
671 or invoke `vm-compose-mail' if none can be found or if FORCE-NEW
674 (when (eq major-mode 'mail-mode) (bury-buffer))
675 (let ((buf (and (not force-new)
676 ;; (not (eq major-mode 'mail-mode))
677 (ff/first-buffer-in-mode (buffer-list) 'mail-mode))))
678 (if buf (switch-to-buffer buf)
681 (define-key global-map [(control x) (m)] 'ff/compose-mail)
683 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
689 (when (load "bbdb-vm" t)
691 (defun ff/mail-aliases-from-bbdb ()
692 "Creates automatically mail aliases from the bbdb records. For
693 instance, someone in bbdb named \"Paul Smith\" would generate an alias
694 'pm'. Does not replace existing aliases."
696 (let* ((records (bbdb-records)))
698 (let* ((record (car records))
699 (name (concat (elt record 0) " " (elt record 1)))
700 (email (car (elt record 6)))
701 (alias (downcase (replace-regexp-in-string
702 "\\([a-zA-Z]?\\)[^- ]*[- ]*" "\\1" name))))
705 ;; Do not overwrite an existing alias
706 (not (and mail-abbrevs (intern-soft alias mail-abbrevs))))
707 (define-mail-abbrev alias email))
708 (setq records (cdr records))))))
710 (when (>= emacs-major-version 22)
712 (ff/mail-aliases-from-bbdb)
716 (defun ff/pipe-to-tmp (universal)
719 (if universal (vm-pipe-message-to-command)
721 (let ((link "/tmp/at")
722 (dir (format-time-string "/tmp/at-%Y%m%d-%H%M%S" (current-time))))
725 (when (file-symlink-p (concat link "~~"))
726 (delete-file (concat link "~~")))
728 (when (and (file-symlink-p (concat link "~"))
729 (not (file-exists-p (concat link "~~"))))
730 (rename-file (concat link "~") (concat link "~~")))
732 (when (and (file-symlink-p link)
733 (not (file-exists-p (concat link "~"))))
734 (file-symlink-p link) (rename-file link (concat link "~")))
736 (unless (file-exists-p link)
737 (make-symbolic-link dir link 1))
739 ;; (vm-pipe-message-to-command (concat "munpack -C " dir))
741 (vm-pipe-message-to-command (concat "munpack -t -C " dir))
742 (message "Wrote files to %s" dir)
747 (define-key vm-mode-pipe-map "\\" 'ff/pipe-to-tmp)
749 (defun ff/make-nonexisting-filename (filename)
750 (let ((root filename)
753 (when (file-exists-p result)
754 (when (string-match "^\\(.*\\)\\(\\.[^\\.]*\\)$" filename)
755 (setq root (match-string 1 filename)
756 extension (match-string 2 filename)))
758 (while (file-exists-p (setq result (format "%s_%03d%s" root n extension)))
762 (defun ff/vm-mime-save-all-attachments (&optional count
764 no-delete-after-saving)
765 "Save all attachments in the next COUNT messages or marked
766 messages. For the purpose of this function, an \"attachment\" is
767 a mime part part which has \"attachment\" as its disposition or
768 simply has an associated filename. Any mime types that match
769 `vm-mime-savable-types' but not `vm-mime-savable-type-exceptions'
772 The attachments are saved to the specified DIRECTORY. The
773 variables `vm-all-attachments-directory' or
774 `vm-mime-attachment-save-directory' can be used to set the
775 default location. When directory does not exist it will be
778 (list current-prefix-arg
780 "Attachment directory: "
781 (or vm-mime-all-attachments-directory
782 vm-mime-attachment-save-directory
784 (or vm-mime-all-attachments-directory
785 vm-mime-attachment-save-directory
788 vm-mime-save-all-attachments-history)))
790 (vm-check-for-killed-summary)
791 (if (interactive-p) (vm-follow-summary-cursor))
794 (vm-mime-action-on-all-attachments
796 ;; the action to be performed BEGIN
797 (lambda (msg layout type file)
798 (let ((directory (if (functionp directory)
799 (funcall directory msg)
803 (expand-file-name (file-name-nondirectory file) directory)
805 (format "Save %s to file: " type)
807 vm-mime-all-attachments-directory
808 vm-mime-attachment-save-directory)
810 vm-mime-all-attachments-directory
811 vm-mime-attachment-save-directory)
813 vm-mime-save-all-attachments-history)
816 (setq file (ff/make-nonexisting-filename file))
819 (message "Saving `%s%s" type (if file (format " (%s)" file) ""))
820 (make-directory (file-name-directory file) t)
821 (vm-mime-send-body-to-file layout file file)
822 (if vm-mime-delete-after-saving
823 (let ((vm-mime-confirm-delete nil))
824 (vm-mime-discard-layout-contents
825 layout (expand-file-name file))))
827 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; the action to be performed END
828 ;; attachment filters
829 vm-mime-savable-types
830 vm-mime-savable-type-exceptions)
832 (when (interactive-p)
833 (vm-discard-cached-data)
834 (vm-preview-current-message))
837 (message "%d attachment%s saved" n (if (= n 1) "" "s"))
838 (message "No attachments to be saved!"))))
840 (define-key vm-summary-mode-map [(control c) (control s)] 'ff/vm-mime-save-all-attachments)
842 ;; I do not like relief
847 ;; (vm-highlight-url :weight 'bold :foreground "#0000f0" :box nil)
848 (vm-highlight-url :underline nil :foreground "#0000f0" :box nil)
849 ;; (vm-highlight-url :background "white" :foreground "#0000f0" :box nil)
850 (vm-highlighted-header :box nil) ;; :weight 'bold :background "white")
852 (vm-attachment-button :background "#f0d0d0" :box nil)
853 (vm-attachment-button-mouse :background "#f0d0d0" :box nil)
854 (vm-attachment-button-pressed-face :background "#f0d0d0" :box nil)
855 (vm-mime-button :background "#f0d0d0" :box nil)
856 (vm-mime-button-mouse :background "#f0d0d0" :box nil)
857 (vm-mime-button-pressed-face :background "#f0d0d0" :box nil)