;; -*- 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             ;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; A fast indexed / search in mbox
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; This is one of my own things, check my web page to get it

(when (ff/load-or-alert "~/sources/gpl/mymail/mymail-vm.el")

  (define-key vm-summary-mode-map "\\" 'mymail/vm-visit-folder)
  (define-key global-map [S-f7] 'mymail/vm-visit-folder)
  (setq mymail/default-search-request "today"
        mymail/default-additional-search-requests "!s ^\\[SPAM\\],!s \\] STATUS,")
  (add-to-list 'recentf-exclude "/tmp/mymail-vm-.*\.mbox")
  )

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

;; Store and restore the window configuration

(setq ff/window-configuration-before-vm nil)

(defadvice vm (before ff/store-window-configuration nil activate)
  (unless ff/window-configuration-before-vm
    (setq ff/window-configuration-before-vm (current-window-configuration)))
  )

(defadvice vm-quit (after ff/restore-window-configuration nil activate)
  (when ff/window-configuration-before-vm
    (set-window-configuration ff/window-configuration-before-vm)
    (setq ff/window-configuration-before-vm nil)
    )
  )

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

(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/does-not-fill (&optional a b) (interactive) (message "Nope"))

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

  ;; Let's try the visual-line mode for mails

  (auto-fill-mode)
  ;; (setq fill-paragraph-function 'ff/does-not-fill)
  ;; (visual-line-mode)

  (set (make-local-variable 'comment-start) vm-included-text-prefix)
  )

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

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

(ff/configure-faces
 ;; '((ff/mail-header-face :background "#c8c8ff"))
 '((ff/mail-header-face :background "#eaf0ff"))
 ;; '((ff/mail-header-face :background "#fff0a0"))
 ;; '((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."))

  )

(defun ff/check-no-prolematic-dest ()
  "Check that there are no \">,[^\ $]\" in the header"
  (let ((s "no-subject"))
    (save-excursion
      (goto-char (point-min))
      (let ((end-header (re-search-forward (concat "^" mail-header-separator "$") nil t)))
        (when end-header
          (goto-char (point-min))
          (re-search-forward ">,[^\ ]" end-header t nil)
          )
        )
      )
    s))

;; 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)

(defadvice vm-mail-send-and-exit (before ff/switch-flyspell-off nil activate)
  (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!

;; (autoload 'mc-install-write-mode "mailcrypt" nil t)
;; (autoload 'mc-install-read-mode "mailcrypt" nil t)

;; (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)
;; (add-hook 'vm-presentation-mode-hook 'mc-install-read-mode)

;; (defun ff/encrypt-mail-if-possible () (interactive)
;; (condition-case nil (mc-encrypt-message)
;; (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)

(defun ff/kill-to-signature () (interactive)
       (save-excursion
         (delete-region
          (point)
          (progn
            (search-forward-regexp "^-- *$")
            (- (match-beginning 0) 1))
          )
         )
       )

(define-key vm-mail-mode-map [(control c) (k)] 'ff/kill-to-signature)

;; 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)
           (with-current-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 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)
                  ;; (not (eq major-mode 'mail-mode))
                  (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 email
                   (> (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)
    )
  )

(defun ff/pipe-to-tmp (universal)
  (interactive "P")

  (if universal (vm-pipe-message-to-command)

    (let ((link "/tmp/at")
          (dir (format-time-string "/tmp/at-%Y%m%d-%H%M%S" (current-time))))
      (mkdir dir)

      (when (file-symlink-p (concat link "~~"))
        (delete-file (concat link "~~")))

      (when (and (file-symlink-p (concat link "~"))
                 (not (file-exists-p (concat link "~~"))))
        (rename-file (concat link "~") (concat link "~~")))

      (when (and (file-symlink-p link)
                 (not (file-exists-p (concat link "~"))))
        (file-symlink-p link) (rename-file link (concat link "~")))

      (unless (file-exists-p link)
        (make-symbolic-link dir link 1))

      ;; (vm-pipe-message-to-command (concat "munpack -C " dir))

      (vm-pipe-message-to-command (concat "munpack -t -C " dir))
      (message "Wrote files to %s" dir)
      )
    )
  )

(define-key vm-mode-pipe-map "\\" 'ff/pipe-to-tmp)

(defun ff/make-nonexisting-filename (filename)
  (let ((root filename)
        (extension "")
        (result filename))
    (when (file-exists-p result)
      (when (string-match "^\\(.*\\)\\(\\.[^\\.]*\\)$" filename)
        (setq root (match-string 1 filename)
              extension (match-string 2 filename)))
      (let ((n 0))
        (while (file-exists-p (setq result (format "%s_%03d%s" root n extension)))
          (setq n (+ n 1)))))
    result))

(defun ff/vm-mime-save-all-attachments (&optional count
                                                  directory
                                                  no-delete-after-saving)
  "Save all attachments in the next COUNT messages or marked
messages.  For the purpose of this function, an \"attachment\" is
a mime part part which has \"attachment\" as its disposition or
simply has an associated filename.  Any mime types that match
`vm-mime-savable-types' but not `vm-mime-savable-type-exceptions'
are also included.

The attachments are saved to the specified DIRECTORY.  The
variables `vm-all-attachments-directory' or
`vm-mime-attachment-save-directory' can be used to set the
default location.  When directory does not exist it will be
created."
  (interactive
   (list current-prefix-arg
         (vm-read-file-name
          "Attachment directory: "
          (or vm-mime-all-attachments-directory
              vm-mime-attachment-save-directory
              default-directory)
          (or vm-mime-all-attachments-directory
              vm-mime-attachment-save-directory
              default-directory)
          nil nil
          vm-mime-save-all-attachments-history)))

  (vm-check-for-killed-summary)
  (if (interactive-p) (vm-follow-summary-cursor))

  (let ((n 0))
    (vm-mime-action-on-all-attachments
     count
     ;; the action to be performed BEGIN
     (lambda (msg layout type file)
       (let ((directory (if (functionp directory)
                            (funcall directory msg)
                          directory)))
         (setq file
	       (if file
		   (expand-file-name (file-name-nondirectory file) directory)
		 (vm-read-file-name
		  (format "Save %s to file: " type)
		  (or directory
		      vm-mime-all-attachments-directory
		      vm-mime-attachment-save-directory)
		  (or directory
		      vm-mime-all-attachments-directory
		      vm-mime-attachment-save-directory)
		  nil nil
		  vm-mime-save-all-attachments-history)
		 ))

         (setq file (ff/make-nonexisting-filename file))

         (when file
           (message "Saving `%s%s" type (if file (format " (%s)" file) ""))
           (make-directory (file-name-directory file) t)
           (vm-mime-send-body-to-file layout file file)
           (if vm-mime-delete-after-saving
               (let ((vm-mime-confirm-delete nil))
                 (vm-mime-discard-layout-contents
		  layout (expand-file-name file))))
           (setq n (+ 1 n)))))
     ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; the action to be performed END
     ;; attachment filters
     vm-mime-savable-types
     vm-mime-savable-type-exceptions)

    (when (interactive-p)
      (vm-discard-cached-data)
      (vm-preview-current-message))

    (if (> n 0)
        (message "%d attachment%s saved" n (if (= n 1) "" "s"))
      (message "No attachments to be saved!"))))

(define-key vm-summary-mode-map [(control c) (control s)] 'ff/vm-mime-save-all-attachments)

;; I do not like relief

(ff/configure-faces
 '(

   ;; (vm-highlight-url :weight 'bold :foreground "#0000f0" :box nil)
   (vm-highlight-url :underline nil :foreground "#0000f0" :box nil)
   ;; (vm-highlight-url :background "white" :foreground "#0000f0" :box nil)
   (vm-highlighted-header :box nil) ;; :weight 'bold :background "white")

   (vm-attachment-button :background "#f0d0d0" :box nil)
   (vm-attachment-button-mouse :background "#f0d0d0" :box nil)
   (vm-attachment-button-pressed-face :background "#f0d0d0" :box nil)
   (vm-mime-button :background "#f0d0d0" :box nil)
   (vm-mime-button-mouse :background "#f0d0d0" :box nil)
   (vm-mime-button-pressed-face :background "#f0d0d0" :box nil)
   ))