;; -*- mode: Emacs-Lisp; mode: rainbow; -*-

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; This program is free software: you can redistribute it and/or modify  ;;
;; it under the terms of the version 3 of the GNU General Public License ;;
;; as published by the Free Software Foundation.                         ;;
;;                                                                       ;;
;; This program is distributed in the hope that it will be useful, but   ;;
;; WITHOUT ANY WARRANTY; without even the implied warranty of            ;;
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU      ;;
;; General Public License for more details.                              ;;
;;                                                                       ;;
;; You should have received a copy of the GNU General Public License     ;;
;; along with this program. If not, see <http://www.gnu.org/licenses/>.  ;;
;;                                                                       ;;
;; Written by and Copyright (C) Francois Fleuret                         ;;
;; Contact <francois@fleuret.org> for comments & bug reports             ;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(setq-default vm-summary-show-threads t)

;; (setq vm-preview-lines nil)

;; (setq vm-auto-displayed-mime-content-types '("text"));; "multipart"));; "image/xpm"

(setq vm-mime-thumbnail-max-geometry nil)

(setq vm-auto-displayed-mime-content-types '(
                                             "text"
                                             ;; "image/jpeg"
                                             ;; "image/png"
                                             "multipart"
                                             "message/rfc822"
                                             ))


(setq
      ;; browse-url-mozilla-program "iceweasel"
      ;; mail-complete-style nil
      ;; mail-from-style nil
      ;; vm-coding-system-priorities '(utf-8)
      ;; vm-highlighted-header-regexp "From:\\|Subject:\\|Cc:\\|To:\\|Bcc:\\|Reply-To:"
      ;; vm-included-text-attribution-format "\nOn %w, %m %d, at %H, you wrote:\n\n"
      ;; vm-jump-to-new-messages nil
      ;; vm-mime-7bit-composition-charset "latin-1"
      ;; vm-mime-8bit-composition-charset "utf-8"
      ;; vm-preview-read-messages t
      ;; vm-summary-format " %*%A %-3.3m %2d %5US %I%UA  %s\n"
      ;; vm-summary-uninteresting-senders-arrow "->"
      ;; vm-summary-uninteresting-senders-arrow "►"
      ;; vm-summary-uninteresting-senders-arrow "➔"
      ;; vm-summary-uninteresting-senders-arrow "➤"
      bbdb-send-mail-style 'vm
      bbdb/mail-auto-create-p nil
      mail-signature t
      mail-specify-envelope-from t
      vm-auto-folder-case-fold-search t
      vm-auto-get-new-mail t
      vm-circular-folders nil
      vm-confirm-new-folders t
      vm-delete-after-archiving t
      vm-delete-after-saving t
      vm-forwarding-digest-type "mime"
      vm-forwarding-subject-format "(forwarded from %F) %s"
      vm-frame-per-folder nil
      vm-frame-per-summary nil
      vm-highlighted-header-regexp "From:\\|Subject:\\|Reply-To:"
      vm-in-reply-to-format nil
      vm-included-text-attribution-format "\nOn %w, %m %d, %y (%h), %F wrote:\n\n"
      vm-included-text-prefix " > "
      vm-keep-sent-messages nil
      vm-mime-8bit-composition-charset "iso-8859-1"
      vm-mime-attachment-save-directory "~/misc/attachments"
      vm-mime-yank-attachments nil
      vm-mutable-frames nil
      vm-mutable-windows t
      vm-netscape-program browse-url-mozilla-program
      vm-preview-lines nil
      vm-reply-subject-prefix "Re: "
      vm-skip-deleted-messages nil
      vm-skip-read-messages nil
      vm-startup-message-displayed t
      vm-startup-with-summary t
      vm-summary-arrow "> "
      vm-summary-format " %*%a %-3.3m %2d %5US %I%UA  %s\n"
      vm-summary-thread-indent-level 1
      vm-summary-uninteresting-senders-arrow ">"
      vm-use-menus nil
      vm-use-toolbar nil
      vm-use-toolbar nil
      )

;; (add-to-list 'vm-visible-headers "From " t)
(add-to-list 'vm-visible-headers "Reply-To:" t)
;; (add-to-list 'vm-visible-headers "X-Mailer:" t)
;; (add-to-list 'vm-visible-headers "X-from-in-bbdb:" t)
;; (add-to-list 'vm-visible-headers "Return-Path:")

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Mime-related stuff

(setq

 vm-infer-mime-types t
 vm-mime-use-image-strips nil
 vm-mime-base64-decoder-program "base64"
 vm-mime-base64-decoder-switches '("-d")
 vm-mime-base64-encoder-program "base64"
 vm-mime-base64-encoder-switches '()

 vm-mime-internal-content-types '(
                                  "multipart"
                                  "text"
                                  ;; "plain text"
                                  ;; "plain text/utf8"
                                  "image/xpm"
                                  )

 ;; To force it to be converted to plain text
 ;; vm-mime-internal-content-type-exceptions '("text/html")

 vm-mime-external-content-types-alist  '(
                                         ("application/x-dvi"      "xdvi")
                                         ("image/postscript"       "gv")
                                         ("application/pdf"        "xpdf")
                                         ("application/postscript" "gv")
                                         ("image"                  "pho")
                                         ("video"                  "mplayer")
                                         ;; ("text/html"              "firefox")
                                         ;; ("application/pdf"        "epdfview")
                                         )

 )

(require 'vm-rfaddons)

;; The two following lines deal with windows-1252 buggy encoding

;;**;; ;; First, don't display iso-8859-1 as-is in default face
;;**;; (delete "iso-8859-1" vm-mime-default-face-charsets)
;;**;; ;; Then substitute windows-1252 for iso-8859-1
;;**;; (add-to-list 'vm-mime-mule-charset-to-coding-alist '("iso-8859-1" windows-1252))

;; (setq vm-mime-default-face-charsets t)

;; (add-to-list 'vm-mime-default-face-charsets  "utf-8")

;; (add-to-list 'vm-mime-default-face-charsets "iso-8859-1")
;; (add-to-list 'vm-mime-default-face-charsets "Windows-1251")
;; (add-hook 'vm-mail-send-hook 'ff/vm-remove-non-7bits-in-headers)
(add-hook 'vm-mail-send-hook 'vm-mime-encode-headers)
(add-hook 'vm-mail-send-hook 'vm-mail-check-recipients)
(add-hook 'vm-reply-hook (lambda () (set-buffer-modified-p nil)))

(add-to-list 'vm-mime-attachment-auto-type-alist '(".*" . "application/octet-stream") t)

;; (add-to-list 'vm-mime-type-converter-alist '("text/html" "text/plain" "cat"))
;; (add-to-list 'vm-mime-type-converter-alist '("text/html" "text/plain" "lynx -nolist -force_html -dump -stdin"))

;; (add-to-list 'vm-mime-type-converter-alist
;; '("text/html" "text/plain"
;; "w3m -cols 75 -graph -dump -T text/html"
;; ))

;; (add-to-list 'vm-mime-type-converter-alist
             ;; '("text/html" "text/plain"
               ;; "html2text -style pretty -nobs"
               ;; ))

;; (add-to-list 'vm-mime-type-converter-alist
             ;; '("text/html" "text/plain"
               ;; "html2text.sh"
               ;; ))

(add-to-list 'vm-mime-type-converter-alist
             '("image" "image/xpm"
               "/usr/bin/convert -geometry 640x480 - xpm:-"))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

;; (defun ff/vm-remove-properties () (interactive)
;; (save-excursion
;; (goto-char (point-min))
;; (re-search-forward (concat "^" mail-header-separator "$"))
;; (set-text-properties (point) (point-max) nil)
;; )
;; )

;; (add-hook 'vm-mail-send-hook 'ff/vm-remove-properties)

;; (defun ff/vm-mime-save-all-files (&optional delete)
  ;; "Save all the mail attachments. With delete argument, remove
;; the attachement from mail."
  ;; (interactive "P")
  ;; (let ((vm-mime-delete-after-saving delete))
    ;; (while (and (vm-mime-reader-map-save-file)
                ;; (condition-case nil (vm-move-to-next-button 1)
                  ;; (error nil)))))
  ;; )

(defun ff/vm-mime-save-file (&optional delete)
  "Save the current attachement. With delete argument, remove the
attachement from mail."
  (interactive "P")
  (let ((vm-mime-delete-after-saving delete))
    (vm-mime-reader-map-save-file))
  (condition-case nil (vm-move-to-next-button 1) (error (message "No more attachment"))))

;; (define-key vm-summary-mode-map [(r)] 'vm-reply-include-text)
;; (define-key vm-summary-mode-map [(R)] 'vm-followup-include-text)

(define-key vm-summary-mode-map [(control o)] 'ff/vm-mime-save-file)

(define-key vm-summary-mode-map [(control t)]
  (lambda () (interactive)
    (vm-toggle-threads-display)
    (unless vm-summary-show-threads
      (vm-sort-messages "date"))))

(defun ff/vm-select-thread-for-next-command () (interactive)
  (vm-mark-thread-subtree)
  (vm-next-command-uses-marks))

(define-key vm-summary-mode-map "T" 'ff/vm-select-thread-for-next-command)

(defun ff/vm-attach-file-or-dir
  (&optional dir)
  "Attaches the file or recursively the content of the directory with
`vm-mime-attach-file'."
  (interactive "fFile or directory: ")

  (save-excursion
    (goto-char (point-max))
    (insert "\n")
    (if (file-regular-p dir)
        (vm-mime-attach-file dir (vm-mime-default-type-from-filename dir))
      (if (file-directory-p dir)
          (mapcar
           (lambda (x)
             (when (not (string-match "^\\." (car x)))
               (ff/vm-attach-file-or-dir
                (concat dir
                        (unless (string-match "/$" dir) "/")
                        (car x)))))
           (directory-files-and-attributes dir)
           )

        (error "Can attach only files and directories")
        ))))

(define-key vm-mail-mode-map [(control c) (control a)] 'ff/vm-attach-file-or-dir)

;; Found no other way to avoid displaying the icones
(load "vm-mime")
(defun vm-mime-set-image-stamp-for-type (e type))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Summary stuff

(defun vm-summary-function-A (message)
  (let* ((from (vm-su-from message)))
    (if (string-match vm-summary-uninteresting-senders from)
        (concat vm-summary-uninteresting-senders-arrow " " (ff/explicit-name (vm-su-to message)))
      (ff/explicit-name from))))

(defun vm-summary-function-S (&optional message)
  (let ((s (string-to-int (vm-su-byte-count message))))
    (if (> s 32768)
        (propertize (concat (int-to-string (/ s 1024)) "k")
                    'face 'italic
                    )
      "")))

(defun ff/vm-delete-and-go-down () (interactive)
  ;; (vm-goto-message)
  (vm-delete-message 1)
  (condition-case nil (vm-next-message-no-skip 1) (error nil)))

(defun ff/vm-expunge-folder ()
  (unless vm-folder-read-only (vm-expunge-folder)))

(add-hook 'vm-quit-hook 'ff/vm-expunge-folder)
(add-hook 'vm-quit-hook 'bbdb-save-db)
(add-hook 'vm-retrieved-spooled-mail-hook 'display-time-update)

(ff/configure-faces '((ff/summary-highlight-face :background "yellow"
                                                 ;; :weight 'bold
                                                 )))

(setq vm-summary-highlight-face 'ff/summary-highlight-face)

(define-key vm-summary-mode-map [(K)] 'ff/vm-delete-and-go-down)

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Activate the required modes and authorize the commenting

(defun ff/prepare-mail-mode ()
  (bbdb-define-all-aliases)
  (flyspell-mode)
  (auto-fill-mode)
  (mail-abbrevs-setup)

  ;; (setq fill-paragraph-function 'mail-mode-fill-paragraph)

  ;; Since I set the comment prefix, I have to tell the filling
  ;; functions not to use it

  ;; ******************* removed Aug 23
  ;; (setq fill-paragraph-handle-comment nil)
  ;; ;; (when message-yank-prefix
  (set (make-local-variable 'comment-start) vm-included-text-prefix)
  ;; (set (make-local-variable 'comment-start-skip)
  ;; (concat "^\\(" (regexp-quote vm-included-text-prefix) "\\)"))
  ;; ;; )
  )

(add-hook 'mail-mode-hook 'ff/prepare-mail-mode)
;; (add-hook 'mail-mode-hook 'orgtbl-mode)

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; To have a slightly darker background for headers

(ff/configure-faces
 ;; '((ff/mail-header-face :background "#c8c8ff"))
 '((ff/mail-header-face :foreground "blue4"))
 )

(defun ff/colorize-headers () (interactive)
  (let ((inhibit-read-only t))
    (save-excursion
      (goto-char (point-min))
      (while (vm-match-header)
        (goto-char (vm-matched-header-end)))
      (add-text-properties
       ;; (vm-matched-header-contents-start)
       ;; (vm-matched-header-contents-end)
       (point-min)
       (point-at-bol)
       '(face ff/mail-header-face)
       )
      )))

(defadvice vm-highlight-headers (after ff/colorize-headers nil activate)
  (ff/colorize-headers))

(defun ff/highlight-important-words ()
  (let ((inhibit-read-only t))
    (save-excursion
      (goto-char (point-min))
      (while (re-search-forward "Fleuret" nil t)
        (message "%d-%d"  (match-beginning 0) (match-end 0))
        ;; (add-text-properties (match-beginning 0) (match-end 0)
                             ;; '(face (:background "red"))
                             ;; )
        ))
    ))

;; (add-hook 'vm-select-message-hook 'ff/highlight-important-words)

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; I want to have a file associated to every mail I am writing

(defcustom ff/vm-mail-draft-directory "~/"
  "Where to save mail drafts with VM")

(defun ff/associate-file-to-vm-mail-buffer ()
  "Associate the current buffer to a file whose name is built from the current time."
  (unless (buffer-file-name)
    (set-visited-file-name (format
                            "%s/mail-%s"
                            ff/vm-mail-draft-directory
                            (format-time-string
                             "%04Y%02m%02d-%02H%02M%02S"
                             (current-time))))
    (set-buffer-modified-p nil)))

(add-hook 'mail-setup-hook 'ff/associate-file-to-vm-mail-buffer)

(defun ff/mail-header-field (field) (interactive)
  "Grab the value of a certain field from the mail header."
  (let ((s "no-subject"))
    (save-excursion
      (goto-char (point-min))
      (let ((l (re-search-forward (concat "^" mail-header-separator "$") nil t)))
        (when l
          (goto-char (point-min))
          (when (re-search-forward (concat "^" field ": ") l t nil)
            (setq s (buffer-substring-no-properties (point) (point-at-eol))))
          )
        )
      )
    s))

(defun ff/dissociate-file-from-vm-mail-buffer ()
  "Save the file under a new name and set the associated file to nil."
  (let ((bn (buffer-file-name)))
    (when bn
      (set-visited-file-name
       (concat (file-name-directory bn)
               "sent-"
               (file-name-nondirectory bn)
               "-"
               (replace-regexp-in-string "[^a-zA-Z0-9]+" "_"
                                         (ff/mail-header-field "Subject"))
               ))
      (save-buffer)
      (set-visited-file-name nil))
    )
  )

(defun ff/find-file-in-vm-mail-mode (filename) (interactive)
  ;; No easy way to activate vm-mail-mode, so we create such a
  ;; buffer, erase its content and insert the file
  (vm-compose-mail)
  (when (file-exists-p filename)
    (erase-buffer)
    (insert-file filename))
  (set-visited-file-name filename)
  (set-buffer-modified-p nil)
  ;; (run-hooks find-file-hooks)
  (when (functionp 'alarm-vc-check) (alarm-vc-check))
  ;; Move the cursor at a convenient location
  (when (re-search-forward (concat "^" mail-header-separator "$") nil t)
    (if (re-search-forward "^-- $" nil t)
        (previous-line 1)
      (next-line 1))
    (end-of-line))
  )

;; All this mess to activate the vm-mail-mode when loading a file
;; looking like a mail draft. Did I miss something ?

(defadvice find-file (around ff/find-file-or-mail
                             (filename &optional wildcards)
                             activate)

  (interactive "FFind file: \np")

  (if (string-match "^\\(mail\\|sent\\)-[^/]+$"
                    (file-name-nondirectory filename))

      (if (find-buffer-visiting filename)
          (switch-to-buffer (find-buffer-visiting filename))
        (ff/find-file-in-vm-mail-mode filename))
    ad-do-it
    ))

(setq ff/vm-mail-draft-directory "~/private/drafts")

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Check there are no missing attachment (the idea comes from
;; http://home.cc.gatech.edu/eaganj/MailApp) and no leading "From"
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(defcustom ff/check-vm-attachement-regexp "attach"
  "*A mail whose body matches this regular expression should contain
an attachment")

(defun ff/check-vm-attachment ()
  (when (save-excursion
          (goto-char (point-min))
          (and (re-search-forward "\\[ATTACHMENT" nil t)
               (not (get-text-property (point) 'vm-mime-object))))
    (error "Buggy attachment"))

  (if (and
       (save-excursion (goto-char (point-min))
                       (re-search-forward ff/check-vm-attachement-regexp nil t))
       (not (save-excursion (goto-char (point-min))
                            (re-search-forward "\\[ATTACHMENT" nil t)))
       (not (y-or-n-p "An attachment seems to be missing, send message ? ")))
      (error "You refer to an unexisting attachment."))

  )

;; You can not have a line starting with "From:" in a pure text
;; mail. The smtp server would add a leading character to prevent it.

(defun ff/check-no-leading-from ()
  (and (let ((case-fold-search nil))
         (save-excursion
           (goto-char (point-min))
           (re-search-forward (concat "^" mail-header-separator "$"))
           (re-search-forward "^From " nil t)))
       (not (y-or-n-p "There is a leading ``From '', send message ? "))
       (error "There is a leading ``From ''.")))

;; An attempt at limiting excess wording in sent mails

(defface ff/strong-words
  '((t (:background "red")))
  "The face to highlight upper caps, exclamation marks and such.")

(defun ff/max-in-a-row (overlay regexp max)
  (let ((case-fold-search nil))
    (save-excursion
      (goto-char (point-min))
      (re-search-forward (concat "^" mail-header-separator "$"))
      (when (and (re-search-forward regexp nil t nil)
                 (>= (- (match-end 0) (match-beginning 0)) max))
        (move-overlay overlay (match-beginning 0) (match-end 0))
        t))))

(defun ff/check-no-excess-wording () (interactive)
  (let ((overlay (make-overlay 0 0)))
    (overlay-put overlay 'face 'media/current-tune-face)
    (let ((err (and
                (or (ff/max-in-a-row overlay "[A-Z\?\!][A-Z\?\! ]+[A-Z\?\!]" 6)
                    (ff/max-in-a-row overlay "[\?\!]+" 2)
                    )
                (not (y-or-n-p "That does not look good. Send message ? ")))))
      (delete-overlay overlay)
      (when err (error "Good idea. Chill out a bit.")))
    ))

(defun ff/check-badly-encoded-address () (interactive)
  (let (bodysep bad-adr)
    (save-excursion
      (goto-char (point-min))
      (search-forward mail-header-separator)
      (setq bodysep (vm-marker (match-beginning 0)))
      (goto-char (point-min))
      (setq bad-adr (re-search-forward "[^<a-zA-Z_0-9\-\. \n\t]+[^ \n]*@" nil t))
      (when (and bad-adr (< bad-adr bodysep))
        (error "There is an invalid address in the header (%s)"
               (match-string 0)))))
  )

(add-hook 'vm-mail-send-hook 'ff/check-vm-attachment)
(add-hook 'vm-mail-send-hook 'ff/check-no-leading-from)
(add-hook 'vm-mail-send-hook 'ff/check-no-excess-wording)
(add-hook 'vm-mail-send-hook 'flyspell-mode-off)
;; Append so that it happens after the mime encoding
;; (add-hook 'vm-mail-send-hook 'ff/check-badly-encoded-address t)
;; Append this hook so that it runs after all other checks
(add-hook 'vm-mail-send-hook 'ff/dissociate-file-from-vm-mail-buffer t)

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; If we can, encrypt!

(add-hook 'vm-mode-hook 'mc-install-read-mode)
(add-hook 'vm-summary-mode-hook 'mc-install-read-mode)
(add-hook 'vm-virtual-mode-hook 'mc-install-read-mode)
(add-hook 'vm-mail-mode-hook 'mc-install-write-mode)

;; (defun ff/encrypt-mail-if-possible () (interactive)
;; (condition-case nil (mc-encrypt)
;; (error nil)))

;; (add-hook 'vm-mail-send-hook 'ff/encrypt-mail-if-possible t)

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Composing a mail

;; Move through important points in the mail ("To:" field, "Subject:"
;; field and the end of the body)

(defun ff/goto-next-mail-field () (interactive)
  (let ((field (save-excursion
                 (end-of-line)
                 (re-search-backward (concat "\\(^[a-zA-Z\-]*: \\|^" mail-header-separator "$\\)") nil t)
                 (match-string 1))))

    (cond ((string= field "To: ")
           (expand-abbrev)
           (re-search-forward "Subject: ")
           (end-of-line))

          ((string= field "Subject: ")
           (re-search-forward (concat "^" mail-header-separator "$"))
           (if (re-search-forward "^-- $" nil t)
               (previous-line 1)
             (next-line 1))
           (end-of-line))

          (t (beginning-of-buffer)
             (re-search-forward "^To: ")
             (end-of-line)
             (re-search-forward "^[a-zA-Z\-]*: ")
             (beginning-of-line)
             (backward-char)))))

;; (define-key vm-mail-mode-map [(control tab)] 'ff/goto-next-mail-field)
(define-key vm-mail-mode-map [(iso-lefttab)] 'ff/goto-next-mail-field)
;; (define-key vm-mail-mode-map [(shift iso-lefttab)] 'mail-mode-smart-tab)
(define-key vm-mail-mode-map [(shift iso-lefttab)] 'bbdb-complete-name)

;; The definition of "\t" is forced through a hook defined in
;; vm-init.el, so I add mine. This is ugly.

(add-hook 'mail-setup-hook
          '(lambda () (local-set-key "\t" 'ff/goto-next-mail-field))
          t)

(substitute-key-definition 'next-line 'mail-abbrev-next-line vm-mail-mode-map global-map)
(substitute-key-definition 'end-of-buffer 'mail-abbrev-end-of-buffer vm-mail-mode-map global-map)

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; I rarely edit two mails at the same time, and it makes sense to
;; come back to the one currently being edited with the same function

(defun ff/first-buffer-in-mode (l m)
  (if l
      (if (eq (save-excursion
                (set-buffer (car l)) major-mode) m)
          (car l)
        (ff/first-buffer-in-mode (cdr l) m))))

(defun ff/compose-mail (&optional force-new)
  "Cycles through an existing buffers with major mode `mail-mode',
or invoke `vm-compose-mail' if none can be found or if FORCE-NEW
is t."
  (interactive "P")
  (when (eq major-mode 'mail-mode) (bury-buffer))
  (let ((buf (and (not force-new)
                  (ff/first-buffer-in-mode (buffer-list) 'mail-mode))))
    (if buf (switch-to-buffer buf)
      (vm-compose-mail))))

(define-key global-map [(control x) (m)] 'ff/compose-mail)

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; bbdb

(load "bbdb")
(load "bbdb-hooks")

(when (load "bbdb-vm" t)

  (defun ff/mail-aliases-from-bbdb ()
    "Creates automatically mail aliases from the bbdb records. For
instance, someone in bbdb named \"Paul Smith\" would generate an alias
'pm'. Does not replace existing aliases."
    (interactive)
    (let* ((records (bbdb-records)))
      (while records
        (let* ((record (car records))
               (name (concat (elt record 0) " " (elt record 1)))
               (email (car (elt record 6)))
               (alias (downcase (replace-regexp-in-string
                                 "\\([a-zA-Z]?\\)[^- ]*[- ]*" "\\1" name))))
          (if (and (> (length alias) 1)
                   ;; Do not overwrite an existing alias
                   (not (and mail-abbrevs (intern-soft alias mail-abbrevs))))
              (define-mail-abbrev alias email))
          (setq records (cdr records))))))

  (when (>= emacs-major-version 22)
    (bbdb-insinuate-vm)
    (ff/mail-aliases-from-bbdb))
  )