--- /dev/null
+;; -*-Emacs-Lisp-*-
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; 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-startup-message-displayed t ;; Yes, we already saw it, no need to insist
+ vm-use-menus nil
+ vm-skip-deleted-messages nil
+ vm-skip-read-messages nil
+ vm-use-toolbar nil
+ ;; vm-jump-to-new-messages nil
+ vm-startup-with-summary t
+ ;; vm-preview-read-messages t
+ vm-preview-lines nil
+ vm-auto-get-new-mail t
+ vm-circular-folders nil
+ vm-confirm-new-folders t
+ vm-mutable-windows t
+ vm-mutable-frames nil
+ vm-summary-uninteresting-senders-arrow "->"
+ vm-summary-arrow "> "
+ vm-included-text-prefix " > "
+ vm-forwarding-digest-type "mime"
+ vm-mime-attachment-save-directory "~/"
+ vm-use-toolbar nil
+ vm-frame-per-folder nil
+ vm-frame-per-summary nil
+ vm-mime-yank-attachments nil
+
+ ;; vm-mime-7bit-composition-charset "latin-1"
+ vm-mime-8bit-composition-charset "iso-8859-1"
+ ;; vm-mime-8bit-composition-charset "utf-8"
+ ;; browse-url-mozilla-program "iceweasel"
+ vm-netscape-program browse-url-mozilla-program
+ ;; vm-coding-system-priorities '(utf-8)
+ ;; mail-from-style nil
+ ;; mail-complete-style nil
+
+ ;; vm-summary-format " %*%A %-3.3m %2d %5US %I%UA %s\n"
+ vm-summary-format " %*%a %-3.3m %2d %5US %I%UA %s\n"
+ ;; vm-highlighted-header-regexp "From:\\|Subject:\\|Cc:\\|To:\\|Bcc:\\|Reply-To:"
+ vm-highlighted-header-regexp "From:\\|Subject:"
+
+ vm-auto-folder-case-fold-search t
+
+ vm-keep-sent-messages nil
+ vm-delete-after-saving t
+ vm-delete-after-archiving t
+
+ vm-forwarding-subject-format "(forwarded from %F) %s"
+ vm-in-reply-to-format nil
+ vm-included-text-attribution-format "\nOn %w, %m %d, %y (%h), %F wrote:\n\n"
+ ;; vm-included-text-attribution-format "\nOn %w, %m %d, at %H, you wrote:\n\n"
+ vm-reply-subject-prefix "Re: "
+
+ mail-signature t
+ mail-specify-envelope-from t
+
+ bbdb/mail-auto-create-p nil
+ bbdb-send-mail-style 'vm
+
+ )
+
+;; (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-auto-displayed-mime-content-types '("text/plain" "text" "image" "multipart")
+ ;; vm-display-using-mime t
+ ;; vm-coding-system-priorities '(iso-8859-1 iso-8859-15 utf-8)
+
+ vm-infer-mime-types t
+ vm-mime-use-image-strips nil
+ vm-mime-base64-decoder-program "mimencode"
+ vm-mime-base64-decoder-switches '("-u")
+ vm-mime-base64-encoder-program "mimencode"
+ vm-mime-base64-encoder-switches '()
+
+ vm-auto-displayed-mime-content-types '(
+ ;; "plain text"
+ "text"
+ "multipart"
+ "image/xpm"
+ )
+
+ ;; vm-auto-displayed-mime-content-type-exceptions '("text/html")
+
+ 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/pdf" "epdfview")
+ ("application/postscript" "gv")
+ ;;("image" "feh")
+ ("video" "mplayer")
+ ;; ("text/html" "iceweasel")
+ )
+
+ )
+
+(require 'vm-rfaddons)
+
+;; (add-to-list 'vm-mime-default-face-charsets "utf-8")
+
+(add-to-list 'vm-mime-default-face-charsets "iso-8859-1")
+(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 -nobs"
+ ))
+
+(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 'bold)
+ "")))
+
+(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)))
+
+(add-hook 'vm-quit-hook '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 "#ffe090"
+ :background "#d8d8e0"
+ )))
+
+(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 (:background "gray85"))
+ ;; '(face (:background "gray50" :foreground "gray95"))
+ '(face ff/mail-header-face)
+ )
+ )))
+
+(defadvice vm-highlight-headers (after ff/colorize-headers nil activate)
+ (ff/colorize-headers))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; 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-mail\\)-[^/]+$"
+ (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!
+
+;; (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)
+ "Switch to an existing buffer with major mode `mail-mode',
+or invoke `vm-compose-mail' if none can be found or if FORCE-NEW
+is t. If already in a mail buffer, burry it and go to the next."
+ (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)
+
+ ;; (defadvice define-mail-abbrev (before ff/remove-explicit-name (name definition &optional from-mailrc-file) activate)
+ ;; (message "%s -> %s" name definition))
+
+ (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))
+ )
projects / elisp.git / commitdiff