;; -*-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 . ;;
;; ;;
;; 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 "#d0d0e8"))
)
(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 "[^ %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))
)