vm

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