From: Francois Fleuret Date: Sun, 28 Feb 2010 10:14:42 +0000 (+0100) Subject: Initial commit X-Git-Url: https://fleuret.org/cgi-bin/gitweb/gitweb.cgi?a=commitdiff_plain;h=401324b320f9b32d8009d0c71c47b392dba7b66b;p=elisp.git Initial commit --- diff --git a/vm b/vm new file mode 100644 index 0000000..458d30d --- /dev/null +++ b/vm @@ -0,0 +1,612 @@ +;; -*-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 "#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 "[^ %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)) + )