vm

   1 ;; -*-Emacs-Lisp-*-
   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 (setq-default vm-summary-show-threads t)
  21
  22 (setq vm-startup-message-displayed t ;; Yes, we already saw it, no need to insist
  23       vm-use-menus nil
  24       vm-skip-deleted-messages nil
  25       vm-skip-read-messages nil
  26       vm-use-toolbar nil
  27       ;; vm-jump-to-new-messages nil
  28       vm-startup-with-summary t
  29       ;; vm-preview-read-messages t
  30       vm-preview-lines nil
  31       vm-auto-get-new-mail t
  32       vm-circular-folders nil
  33       vm-confirm-new-folders t
  34       vm-mutable-windows t
  35       vm-mutable-frames nil
  36       vm-summary-uninteresting-senders-arrow "->"
  37       vm-summary-arrow "> "
  38       vm-included-text-prefix " > "
  39       vm-forwarding-digest-type "mime"
  40       vm-mime-attachment-save-directory "~/"
  41       vm-use-toolbar nil
  42       vm-frame-per-folder nil
  43       vm-frame-per-summary nil
  44       vm-mime-yank-attachments nil
  45
  46       ;; vm-mime-7bit-composition-charset "latin-1"
  47       vm-mime-8bit-composition-charset "iso-8859-1"
  48       ;; vm-mime-8bit-composition-charset "utf-8"
  49       ;; browse-url-mozilla-program "iceweasel"
  50       vm-netscape-program browse-url-mozilla-program
  51       ;; vm-coding-system-priorities '(utf-8)
  52       ;; mail-from-style nil
  53       ;; mail-complete-style nil
  54
  55       ;; vm-summary-format " %*%A %-3.3m %2d %5US %I%UA  %s\n"
  56       vm-summary-format " %*%a %-3.3m %2d %5US %I%UA  %s\n"
  57       ;; vm-highlighted-header-regexp "From:\\|Subject:\\|Cc:\\|To:\\|Bcc:\\|Reply-To:"
  58       vm-highlighted-header-regexp "From:\\|Subject:"
  59
  60       vm-auto-folder-case-fold-search t
  61
  62       vm-keep-sent-messages nil
  63       vm-delete-after-saving t
  64       vm-delete-after-archiving t
  65
  66       vm-forwarding-subject-format "(forwarded from %F) %s"
  67       vm-in-reply-to-format nil
  68       vm-included-text-attribution-format "\nOn %w, %m %d, %y (%h), %F wrote:\n\n"
  69       ;; vm-included-text-attribution-format "\nOn %w, %m %d, at %H, you wrote:\n\n"
  70       vm-reply-subject-prefix "Re: "
  71
  72       mail-signature t
  73       mail-specify-envelope-from t
  74
  75       bbdb/mail-auto-create-p nil
  76       bbdb-send-mail-style 'vm
  77
  78       )
  79
  80 ;; (add-to-list 'vm-visible-headers "Reply-To:" t)
  81 ;; (add-to-list 'vm-visible-headers "X-Mailer:" t)
  82 ;; (add-to-list 'vm-visible-headers "X-from-in-bbdb:" t)
  83 ;; (add-to-list 'vm-visible-headers "Return-Path:")
  84
  85 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  86 ;; Mime-related stuff
  87
  88 (setq
  89
  90  ;; vm-auto-displayed-mime-content-types '("text/plain" "text" "image" "multipart")
  91  ;; vm-display-using-mime t
  92  ;; vm-coding-system-priorities '(iso-8859-1 iso-8859-15 utf-8)
  93
  94  vm-infer-mime-types t
  95  vm-mime-use-image-strips nil
  96  vm-mime-base64-decoder-program "mimencode"
  97  vm-mime-base64-decoder-switches '("-u")
  98  vm-mime-base64-encoder-program "mimencode"
  99  vm-mime-base64-encoder-switches '()
 100
 101  vm-auto-displayed-mime-content-types '(
 102                                         ;; "plain text"
 103                                         "text"
 104                                         "multipart"
 105                                         "image/xpm"
 106                                         )
 107
 108  ;; vm-auto-displayed-mime-content-type-exceptions '("text/html")
 109
 110  vm-mime-internal-content-types '(
 111                                   "multipart"
 112                                   "text"
 113                                   ;; "plain text"
 114                                   ;; "plain text/utf8"
 115                                   "image/xpm"
 116                                   )
 117
 118  ;; To force it to be converted to plain text
 119  vm-mime-internal-content-type-exceptions '("text/html")
 120
 121  vm-mime-external-content-types-alist  '(
 122                                          ("application/x-dvi"      "xdvi")
 123                                          ("image/postscript"       "gv")
 124                                          ("application/pdf"        "xpdf")
 125                                          ;; ("application/pdf"        "epdfview")
 126                                          ("application/postscript" "gv")
 127                                          ;;("image"                  "feh")
 128                                          ("video"                  "mplayer")
 129                                          ;; ("text/html"             "iceweasel")
 130                                          )
 131
 132  )
 133
 134 (require 'vm-rfaddons)
 135
 136 ;; (add-to-list 'vm-mime-default-face-charsets  "utf-8")
 137
 138 (add-to-list 'vm-mime-default-face-charsets  "iso-8859-1")
 139 (add-hook 'vm-mail-send-hook 'vm-mime-encode-headers)
 140 (add-hook 'vm-mail-send-hook 'vm-mail-check-recipients)
 141 (add-hook 'vm-reply-hook (lambda () (set-buffer-modified-p nil)))
 142
 143 (add-to-list 'vm-mime-attachment-auto-type-alist '(".*" . "application/octet-stream") t)
 144
 145 ;; (add-to-list 'vm-mime-type-converter-alist '("text/html" "text/plain" "cat"))
 146 ;; (add-to-list 'vm-mime-type-converter-alist '("text/html" "text/plain" "lynx -nolist -force_html -dump -stdin"))
 147
 148 ;; (add-to-list 'vm-mime-type-converter-alist
 149 ;; '("text/html" "text/plain"
 150 ;; "w3m -cols 75 -graph -dump -T text/html"
 151 ;; ))
 152
 153 (add-to-list 'vm-mime-type-converter-alist
 154              '("text/html" "text/plain"
 155                "html2text -nobs"
 156                ))
 157
 158 (add-to-list 'vm-mime-type-converter-alist
 159              '("image" "image/xpm"
 160                "/usr/bin/convert -geometry 640x480 - xpm:-"))
 161
 162 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 163
 164 ;; (defun ff/vm-remove-properties () (interactive)
 165 ;; (save-excursion
 166 ;; (goto-char (point-min))
 167 ;; (re-search-forward (concat "^" mail-header-separator "$"))
 168 ;; (set-text-properties (point) (point-max) nil)
 169 ;; )
 170 ;; )
 171
 172 ;; (add-hook 'vm-mail-send-hook 'ff/vm-remove-properties)
 173
 174 (defun ff/vm-mime-save-all-files (&optional delete)
 175   "Save all the mail attachments. With delete argument, remove
 176 the attachement from mail."
 177   (interactive "P")
 178   (let ((vm-mime-delete-after-saving delete))
 179     (while (and (vm-mime-reader-map-save-file)
 180                 (condition-case nil (vm-move-to-next-button 1)
 181                   (error nil)))))
 182   )
 183
 184 (defun ff/vm-mime-save-file (&optional delete)
 185   "Save the current attachement. With delete argument, remove the
 186 attachement from mail."
 187   (interactive "P")
 188   (let ((vm-mime-delete-after-saving delete))
 189     (vm-mime-reader-map-save-file))
 190   (condition-case nil (vm-move-to-next-button 1) (error (message "No more attachment"))))
 191
 192 ;; (define-key vm-summary-mode-map [(r)] 'vm-reply-include-text)
 193 ;; (define-key vm-summary-mode-map [(R)] 'vm-followup-include-text)
 194
 195 (define-key vm-summary-mode-map [(control o)] 'ff/vm-mime-save-file)
 196
 197 (define-key vm-summary-mode-map [(control t)]
 198   (lambda () (interactive)
 199     (vm-toggle-threads-display)
 200     (unless vm-summary-show-threads
 201       (vm-sort-messages "date"))))
 202
 203 (defun ff/vm-select-thread-for-next-command () (interactive)
 204   (vm-mark-thread-subtree)
 205   (vm-next-command-uses-marks))
 206
 207 (define-key vm-summary-mode-map "T" 'ff/vm-select-thread-for-next-command)
 208
 209 (defun ff/vm-attach-file-or-dir
 210   (&optional dir)
 211   "Attaches the file or recursively the content of the directory with
 212 `vm-mime-attach-file'."
 213   (interactive "fFile or directory: ")
 214
 215   (save-excursion
 216     (goto-char (point-max))
 217     (insert "\n")
 218     (if (file-regular-p dir)
 219         (vm-mime-attach-file dir (vm-mime-default-type-from-filename dir))
 220       (if (file-directory-p dir)
 221           (mapcar
 222            (lambda (x)
 223              (when (not (string-match "^\\." (car x)))
 224                (ff/vm-attach-file-or-dir
 225                 (concat dir
 226                         (unless (string-match "/$" dir) "/")
 227                         (car x)))))
 228            (directory-files-and-attributes dir)
 229            )
 230
 231         (error "Can attach only files and directories")
 232         ))))
 233
 234 (define-key vm-mail-mode-map [(control c) (control a)] 'ff/vm-attach-file-or-dir)
 235
 236 ;; Found no other way to avoid displaying the icones
 237 (load "vm-mime")
 238 (defun vm-mime-set-image-stamp-for-type (e type))
 239
 240 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 241 ;; Summary stuff
 242
 243 (defun vm-summary-function-A (message)
 244   (let* ((from (vm-su-from message)))
 245     (if (string-match vm-summary-uninteresting-senders from)
 246         (concat vm-summary-uninteresting-senders-arrow " " (ff/explicit-name (vm-su-to message)))
 247       (ff/explicit-name from))))
 248
 249 (defun vm-summary-function-S (&optional message)
 250   (let ((s (string-to-int (vm-su-byte-count message))))
 251     (if (> s 32768)
 252         (propertize (concat (int-to-string (/ s 1024)) "k") 'face 'bold)
 253       "")))
 254
 255 (defun ff/vm-delete-and-go-down () (interactive)
 256   ;; (vm-goto-message)
 257   (vm-delete-message 1)
 258   (condition-case nil (vm-next-message-no-skip 1) (error nil)))
 259
 260 (add-hook 'vm-quit-hook 'vm-expunge-folder)
 261 (add-hook 'vm-quit-hook 'bbdb-save-db)
 262 (add-hook 'vm-retrieved-spooled-mail-hook 'display-time-update)
 263
 264 (ff/configure-faces '((ff/summary-highlight-face :background "yellow"
 265                                                  ;; :weight 'bold
 266                                                  )))
 267
 268 (setq vm-summary-highlight-face 'ff/summary-highlight-face)
 269
 270 (define-key vm-summary-mode-map [(K)] 'ff/vm-delete-and-go-down)
 271
 272 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 273 ;; Activate the required modes and authorize the commenting
 274
 275 (defun ff/prepare-mail-mode ()
 276   (bbdb-define-all-aliases)
 277   (flyspell-mode)
 278   (auto-fill-mode)
 279   (mail-abbrevs-setup)
 280
 281   ;; (setq fill-paragraph-function 'mail-mode-fill-paragraph)
 282
 283   ;; Since I set the comment prefix, I have to tell the filling
 284   ;; functions not to use it
 285
 286   ;; ******************* removed Aug 23
 287   ;; (setq fill-paragraph-handle-comment nil)
 288   ;; ;; (when message-yank-prefix
 289   (set (make-local-variable 'comment-start) vm-included-text-prefix)
 290   ;; (set (make-local-variable 'comment-start-skip)
 291   ;; (concat "^\\(" (regexp-quote vm-included-text-prefix) "\\)"))
 292   ;; ;; )
 293   )
 294
 295 (add-hook 'mail-mode-hook 'ff/prepare-mail-mode)
 296 ;; (add-hook 'mail-mode-hook 'orgtbl-mode)
 297
 298 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 299 ;; To have a slightly darker background for headers
 300
 301 (ff/configure-faces
 302  '((ff/mail-header-face :background "#d0d0e8"))
 303  )
 304
 305 (defun ff/colorize-headers () (interactive)
 306   (let ((inhibit-read-only t))
 307     (save-excursion
 308       (goto-char (point-min))
 309       (while (vm-match-header)
 310         (goto-char (vm-matched-header-end)))
 311       (add-text-properties
 312        ;; (vm-matched-header-contents-start)
 313        ;; (vm-matched-header-contents-end)
 314        (point-min)
 315        (point-at-bol)
 316        ;; '(face (:background "gray85"))
 317        ;; '(face (:background "gray50" :foreground "gray95"))
 318        '(face ff/mail-header-face)
 319        )
 320       )))
 321
 322 (defadvice vm-highlight-headers (after ff/colorize-headers nil activate)
 323   (ff/colorize-headers))
 324
 325 (defun ff/highlight-important-words ()
 326   (let ((inhibit-read-only t))
 327     (save-excursion
 328       (goto-char (point-min))
 329       (while (re-search-forward "Fleuret" nil t)
 330         (message "%d-%d"  (match-beginning 0) (match-end 0))
 331         ;; (add-text-properties (match-beginning 0) (match-end 0)
 332                              ;; '(face (:background "red"))
 333                              ;; )
 334         ))
 335     ))
 336
 337 ;; (add-hook 'vm-select-message-hook 'ff/highlight-important-words)
 338
 339 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 340 ;; I want to have a file associated to every mail I am writing
 341
 342 (defcustom ff/vm-mail-draft-directory "~/"
 343   "Where to save mail drafts with VM")
 344
 345 (defun ff/associate-file-to-vm-mail-buffer ()
 346   "Associate the current buffer to a file whose name is built from the current time."
 347   (unless (buffer-file-name)
 348     (set-visited-file-name (format
 349                             "%s/mail-%s"
 350                             ff/vm-mail-draft-directory
 351                             (format-time-string "%04Y%02m%02d-%02H%02M%02S" (current-time))))
 352     (set-buffer-modified-p nil)))
 353
 354 (add-hook 'mail-setup-hook 'ff/associate-file-to-vm-mail-buffer)
 355
 356 (defun ff/mail-header-field (field) (interactive)
 357   "Grab the value of a certain field from the mail header."
 358   (let ((s "no-subject"))
 359     (save-excursion
 360       (goto-char (point-min))
 361       (let ((l (re-search-forward (concat "^" mail-header-separator "$") nil t)))
 362         (when l
 363           (goto-char (point-min))
 364           (when (re-search-forward (concat "^" field ": ") l t nil)
 365             (setq s (buffer-substring-no-properties (point) (point-at-eol))))
 366           )
 367         )
 368       )
 369     s))
 370
 371 (defun ff/dissociate-file-from-vm-mail-buffer ()
 372   "Save the file under a new name and set the associated file to nil."
 373   (let ((bn (buffer-file-name)))
 374     (when bn
 375       (set-visited-file-name (concat (file-name-directory bn)
 376                                      "sent-"
 377                                      (file-name-nondirectory bn)
 378                                      "-"
 379                                      (replace-regexp-in-string "[^a-zA-Z0-9]+" "_"
 380                                                                (ff/mail-header-field "Subject"))
 381                                      ))
 382       (save-buffer)
 383       (set-visited-file-name nil))
 384     )
 385   )
 386
 387 (defun ff/find-file-in-vm-mail-mode (filename) (interactive)
 388   ;; No easy way to activate vm-mail-mode, so we create such a
 389   ;; buffer, erase its content and insert the file
 390   (vm-compose-mail)
 391   (when (file-exists-p filename)
 392     (erase-buffer)
 393     (insert-file filename))
 394   (set-visited-file-name filename)
 395   (set-buffer-modified-p nil)
 396   ;; (run-hooks find-file-hooks)
 397   (when (functionp 'alarm-vc-check) (alarm-vc-check))
 398   ;; Move the cursor at a convenient location
 399   (when (re-search-forward (concat "^" mail-header-separator "$") nil t)
 400     (if (re-search-forward "^-- $" nil t)
 401         (previous-line 1)
 402       (next-line 1))
 403     (end-of-line))
 404   )
 405
 406 ;; All this mess to activate the vm-mail-mode when loading a file
 407 ;; looking like a mail draft. Did I miss something ?
 408
 409 (defadvice find-file (around ff/find-file-or-mail
 410                              (filename &optional wildcards)
 411                              activate)
 412
 413   (interactive "FFind file: \np")
 414
 415   (if (string-match "^\\(mail\\|sent\\)-[^/]+$"
 416                     (file-name-nondirectory filename))
 417
 418       (if (find-buffer-visiting filename)
 419           (switch-to-buffer (find-buffer-visiting filename))
 420         (ff/find-file-in-vm-mail-mode filename))
 421     ad-do-it
 422     ))
 423
 424 (setq ff/vm-mail-draft-directory "~/private/drafts")
 425
 426 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 427 ;; Check there are no missing attachment (the idea comes from
 428 ;; http://home.cc.gatech.edu/eaganj/MailApp) and no leading "From"
 429 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 430
 431 (defcustom ff/check-vm-attachement-regexp "attach"
 432   "*A mail whose body matches this regular expression should contain
 433 an attachment")
 434
 435 (defun ff/check-vm-attachment ()
 436   (when (save-excursion
 437           (goto-char (point-min))
 438           (and (re-search-forward "\\[ATTACHMENT" nil t)
 439                (not (get-text-property (point) 'vm-mime-object))))
 440     (error "Buggy attachment"))
 441
 442   (if (and
 443        (save-excursion (goto-char (point-min))
 444                        (re-search-forward ff/check-vm-attachement-regexp nil t))
 445        (not (save-excursion (goto-char (point-min))
 446                             (re-search-forward "\\[ATTACHMENT" nil t)))
 447        (not (y-or-n-p "An attachment seems to be missing, send message ? ")))
 448       (error "You refer to an unexisting attachment."))
 449
 450   )
 451
 452 ;; You can not have a line starting with "From:" in a pure text
 453 ;; mail. The smtp server would add a leading character to prevent it.
 454
 455 (defun ff/check-no-leading-from ()
 456   (and (let ((case-fold-search nil))
 457          (save-excursion
 458            (goto-char (point-min))
 459            (re-search-forward (concat "^" mail-header-separator "$"))
 460            (re-search-forward "^From " nil t)))
 461        (not (y-or-n-p "There is a leading ``From '', send message ? "))
 462        (error "There is a leading ``From ''.")))
 463
 464 ;; An attempt at limiting excess wording in sent mails
 465
 466 (defface ff/strong-words
 467   '((t (:background "red")))
 468   "The face to highlight upper caps, exclamation marks and such.")
 469
 470 (defun ff/max-in-a-row (overlay regexp max)
 471   (let ((case-fold-search nil))
 472     (save-excursion
 473       (goto-char (point-min))
 474       (re-search-forward (concat "^" mail-header-separator "$"))
 475       (when (and (re-search-forward regexp nil t nil)
 476                  (>= (- (match-end 0) (match-beginning 0)) max))
 477         (move-overlay overlay (match-beginning 0) (match-end 0))
 478         t))))
 479
 480 (defun ff/check-no-excess-wording () (interactive)
 481   (let ((overlay (make-overlay 0 0)))
 482     (overlay-put overlay 'face 'media/current-tune-face)
 483     (let ((err (and
 484                 (or (ff/max-in-a-row overlay "[A-Z\?\!][A-Z\?\! ]+[A-Z\?\!]" 6)
 485                     (ff/max-in-a-row overlay "[\?\!]+" 2)
 486                     )
 487                 (not (y-or-n-p "That does not look good. Send message ? ")))))
 488       (delete-overlay overlay)
 489       (when err (error "Good idea. Chill out a bit.")))
 490     ))
 491
 492 (defun ff/check-badly-encoded-address () (interactive)
 493   (let (bodysep bad-adr)
 494     (save-excursion
 495       (goto-char (point-min))
 496       (search-forward mail-header-separator)
 497       (setq bodysep (vm-marker (match-beginning 0)))
 498       (goto-char (point-min))
 499       (setq bad-adr (re-search-forward "[^<a-zA-Z_0-9\-\. \n\t]+[^ \n]*@" nil t))
 500       (when (and bad-adr (< bad-adr bodysep))
 501         (error "There is an invalid address in the header (%s)"
 502                (match-string 0)))))
 503   )
 504
 505 (add-hook 'vm-mail-send-hook 'ff/check-vm-attachment)
 506 (add-hook 'vm-mail-send-hook 'ff/check-no-leading-from)
 507 (add-hook 'vm-mail-send-hook 'ff/check-no-excess-wording)
 508 (add-hook 'vm-mail-send-hook 'flyspell-mode-off)
 509 ;; Append so that it happens after the mime encoding
 510 ;; (add-hook 'vm-mail-send-hook 'ff/check-badly-encoded-address t)
 511 ;; Append this hook so that it runs after all other checks
 512 (add-hook 'vm-mail-send-hook 'ff/dissociate-file-from-vm-mail-buffer t)
 513
 514 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 515 ;; If we can, encrypt!
 516
 517 ;; (defun ff/encrypt-mail-if-possible () (interactive)
 518 ;; (condition-case nil (mc-encrypt)
 519 ;; (error nil)))
 520
 521 ;; (add-hook 'vm-mail-send-hook 'ff/encrypt-mail-if-possible t)
 522
 523 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 524 ;; Composing a mail
 525
 526 ;; Move through important points in the mail ("To:" field, "Subject:"
 527 ;; field and the end of the body)
 528
 529 (defun ff/goto-next-mail-field () (interactive)
 530   (let ((field (save-excursion
 531                  (end-of-line)
 532                  (re-search-backward (concat "\\(^[a-zA-Z\-]*: \\|^" mail-header-separator "$\\)") nil t)
 533                  (match-string 1))))
 534
 535     (cond ((string= field "To: ")
 536            (expand-abbrev)
 537            (re-search-forward "Subject: ")
 538            (end-of-line))
 539
 540           ((string= field "Subject: ")
 541            (re-search-forward (concat "^" mail-header-separator "$"))
 542            (if (re-search-forward "^-- $" nil t)
 543                (previous-line 1)
 544              (next-line 1))
 545            (end-of-line))
 546
 547           (t (beginning-of-buffer)
 548              (re-search-forward "^To: ")
 549              (end-of-line)
 550              (re-search-forward "^[a-zA-Z\-]*: ")
 551              (beginning-of-line)
 552              (backward-char)))))
 553
 554 ;; (define-key vm-mail-mode-map [(control tab)] 'ff/goto-next-mail-field)
 555 (define-key vm-mail-mode-map [(iso-lefttab)] 'ff/goto-next-mail-field)
 556 ;; (define-key vm-mail-mode-map [(shift iso-lefttab)] 'mail-mode-smart-tab)
 557 (define-key vm-mail-mode-map [(shift iso-lefttab)] 'bbdb-complete-name)
 558
 559 ;; The definition of "\t" is forced through a hook defined in
 560 ;; vm-init.el, so I add mine. This is ugly.
 561
 562 (add-hook 'mail-setup-hook
 563           '(lambda () (local-set-key "\t" 'ff/goto-next-mail-field))
 564           t)
 565
 566 (substitute-key-definition 'next-line 'mail-abbrev-next-line vm-mail-mode-map global-map)
 567 (substitute-key-definition 'end-of-buffer 'mail-abbrev-end-of-buffer vm-mail-mode-map global-map)
 568
 569 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 570 ;; I rarely edit two mails at the same time, and it makes sense to
 571 ;; come back to the one currently being edited with the same function
 572
 573 (defun ff/first-buffer-in-mode (l m)
 574   (if l
 575       (if (eq (save-excursion
 576                 (set-buffer (car l)) major-mode) m)
 577           (car l)
 578         (ff/first-buffer-in-mode (cdr l) m))))
 579
 580 (defun ff/compose-mail (&optional force-new)
 581   "Switch to an existing buffer with major mode `mail-mode',
 582 or invoke `vm-compose-mail' if none can be found or if FORCE-NEW
 583 is t. If already in a mail buffer, burry it and go to the next."
 584   (interactive "P")
 585   (when (eq major-mode 'mail-mode) (bury-buffer))
 586   (let ((buf (and (not force-new)
 587                   (ff/first-buffer-in-mode (buffer-list) 'mail-mode))))
 588     (if buf (switch-to-buffer buf)
 589       (vm-compose-mail))))
 590
 591 (define-key global-map [(control x) (m)] 'ff/compose-mail)
 592
 593 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 594 ;; bbdb
 595
 596 (load "bbdb")
 597 (load "bbdb-hooks")
 598
 599 (when (load "bbdb-vm" t)
 600
 601   ;; (defadvice define-mail-abbrev (before ff/remove-explicit-name (name definition &optional from-mailrc-file) activate)
 602   ;; (message "%s -> %s" name definition))
 603
 604   (defun ff/mail-aliases-from-bbdb ()
 605     "Creates automatically mail aliases from the bbdb records. For
 606 instance, someone in bbdb named \"Paul Smith\" would generate an alias
 607 'pm'. Does not replace existing aliases."
 608     (interactive)
 609     (let* ((records (bbdb-records)))
 610       (while records
 611         (let* ((record (car records))
 612                (name (concat (elt record 0) " " (elt record 1)))
 613                (email (car (elt record 6)))
 614                (alias (downcase (replace-regexp-in-string "\\([a-zA-Z]?\\)[^- ]*[- ]*" "\\1" name))))
 615           (if (and (> (length alias) 1)
 616                    ;; Do not overwrite an existing alias
 617                    (not (and mail-abbrevs (intern-soft alias mail-abbrevs))))
 618               (define-mail-abbrev alias email))
 619           (setq records (cdr records))))))
 620
 621   (when (>= emacs-major-version 22)
 622     (bbdb-insinuate-vm)
 623     (ff/mail-aliases-from-bbdb))
 624   )