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 ;; Append so that it happens after the mime encoding
 549 ;; (add-hook 'vm-mail-send-hook 'ff/check-badly-encoded-address t)
 550
 551 ;; Append this hook so that it runs after all other checks
 552 (add-hook 'vm-mail-send-hook 'ff/dissociate-file-from-vm-mail-buffer t)
 553
 554 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 555 ;; If we can, encrypt!
 556
 557 (add-hook 'vm-mode-hook 'mc-install-read-mode)
 558 (add-hook 'vm-summary-mode-hook 'mc-install-read-mode)
 559 (add-hook 'vm-virtual-mode-hook 'mc-install-read-mode)
 560 (add-hook 'vm-mail-mode-hook 'mc-install-write-mode)
 561 (add-hook 'vm-presentation-mode-hook 'mc-install-read-mode)
 562
 563 ;; (defun ff/encrypt-mail-if-possible () (interactive)
 564   ;; (condition-case nil (mc-encrypt-message)
 565     ;; (error nil)))
 566
 567 ;; (add-hook 'vm-mail-send-hook 'ff/encrypt-mail-if-possible t)
 568
 569 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 570 ;; Composing a mail
 571
 572 ;; Move through important points in the mail ("To:" field, "Subject:"
 573 ;; field and the end of the body)
 574
 575 (defun ff/goto-next-mail-field () (interactive)
 576   (let ((field (save-excursion
 577                  (end-of-line)
 578                  (re-search-backward
 579                   (concat "\\(^[a-zA-Z\-]*: \\|^" mail-header-separator "$\\)") nil t)
 580                  (match-string 1))))
 581
 582     (cond ((string= field "To: ")
 583            (expand-abbrev)
 584            (re-search-forward "Subject: ")
 585            (end-of-line))
 586
 587           ((string= field "Subject: ")
 588            (re-search-forward (concat "^" mail-header-separator "$"))
 589            (if (re-search-forward "^-- $" nil t)
 590                (previous-line 1)
 591              (next-line 1))
 592            (end-of-line))
 593
 594           (t (beginning-of-buffer)
 595              (re-search-forward "^To: ")
 596              (end-of-line)
 597              (re-search-forward "^[a-zA-Z\-]*: ")
 598              (beginning-of-line)
 599              (backward-char)))))
 600
 601 ;; (define-key vm-mail-mode-map [(control tab)] 'ff/goto-next-mail-field)
 602 (define-key vm-mail-mode-map [(iso-lefttab)] 'ff/goto-next-mail-field)
 603 ;; (define-key vm-mail-mode-map [(shift iso-lefttab)] 'mail-mode-smart-tab)
 604 (define-key vm-mail-mode-map [(shift iso-lefttab)] 'bbdb-complete-name)
 605
 606 ;; The definition of "\t" is forced through a hook defined in
 607 ;; vm-init.el, so I add mine. This is ugly.
 608
 609 (add-hook 'mail-setup-hook
 610           '(lambda () (local-set-key "\t" 'ff/goto-next-mail-field))
 611           t)
 612
 613 (substitute-key-definition 'next-line 'mail-abbrev-next-line vm-mail-mode-map global-map)
 614
 615 (substitute-key-definition 'end-of-buffer 'mail-abbrev-end-of-buffer vm-mail-mode-map global-map)
 616
 617 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 618 ;; I rarely edit two mails at the same time, and it makes sense to
 619 ;; come back to the one currently being edited with the same function
 620
 621 (defun ff/first-buffer-in-mode (l m)
 622   (if l
 623       (if (eq (save-excursion
 624                 (set-buffer (car l)) major-mode) m)
 625           (car l)
 626         (ff/first-buffer-in-mode (cdr l) m))))
 627
 628 (defun ff/compose-mail (&optional force-new)
 629   "Cycles through an existing buffers with major mode `mail-mode',
 630 or invoke `vm-compose-mail' if none can be found or if FORCE-NEW
 631 is t."
 632   (interactive "P")
 633   (when (eq major-mode 'mail-mode) (bury-buffer))
 634   (let ((buf (and (not force-new)
 635                   (ff/first-buffer-in-mode (buffer-list) 'mail-mode))))
 636     (if buf (switch-to-buffer buf)
 637       (vm-compose-mail))))
 638
 639 (define-key global-map [(control x) (m)] 'ff/compose-mail)
 640
 641 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 642 ;; bbdb
 643
 644 (load "bbdb")
 645 (load "bbdb-hooks")
 646
 647 (when (load "bbdb-vm" t)
 648
 649   (defun ff/mail-aliases-from-bbdb ()
 650     "Creates automatically mail aliases from the bbdb records. For
 651 instance, someone in bbdb named \"Paul Smith\" would generate an alias
 652 'pm'. Does not replace existing aliases."
 653     (interactive)
 654     (let* ((records (bbdb-records)))
 655       (while records
 656         (let* ((record (car records))
 657                (name (concat (elt record 0) " " (elt record 1)))
 658                (email (car (elt record 6)))
 659                (alias (downcase (replace-regexp-in-string
 660                                  "\\([a-zA-Z]?\\)[^- ]*[- ]*" "\\1" name))))
 661           (if (and (> (length alias) 1)
 662                    ;; Do not overwrite an existing alias
 663                    (not (and mail-abbrevs (intern-soft alias mail-abbrevs))))
 664               (define-mail-abbrev alias email))
 665           (setq records (cdr records))))))
 666
 667   (when (>= emacs-major-version 22)
 668     (bbdb-insinuate-vm)
 669     (ff/mail-aliases-from-bbdb))
 670   )
 671
 672 (defun ff/pipe-to-tmp () (interactive)
 673   (let ((link "/tmp/attach")
 674         (dir (format-time-string "/tmp/attach-%Y%m%d-%H%M%S" (current-time))))
 675     (mkdir dir)
 676     (when (file-symlink-p link) (delete-file link))
 677     (unless (file-exists-p link)
 678       (make-symbolic-link dir "/tmp/attach" 1))
 679     (vm-pipe-message-to-command (concat "munpack -C " dir))
 680     (message "Wrote files to %s" dir)
 681     )
 682   )