Some helpfule vm elisp functions
blueman
back to the group for a while... Well, I finally had a chance to look
through my own custom vm.el code and clean it up to contribute back to
the group.
(Robert I know I have promised to send you this a long time ago...)
-----------------------------------------------------------------------
; Did you ever find yourself navigating dired and visited a file only
; to find out that it is a mail file and requires vm to read it?
(defun dired-vm-visit-folder ()
"*Visit mail folder (file) mentioned on current dired line. (JJK)"
(interactive)
(or (string-equal major-mode "dired-mode")
(error "Error: must be in dired-mode..."))
(vm-visit-folder (dired-get-filename)))
(add-hook
'dired-load-hook
(define-key dired-mode-map "V" 'dired-vm-visit-folder))
; Here are some useful advice to wrap around some of the mime
; attachment functions to allow you to decide whether or not to also
; delete attachments
(defadvice vm-mime-save-all-attachments
(around vm-mime-delete-confirm nil activate)
"Query whether to delete attachments after saving. (JJK - advice)"
(let ((vm-mime-delete-after-saving vm-mime-delete-after-saving))
(and (yes-or-no-p "DELETE *all* MIME attachments after saving? ")
(setq vm-mime-delete-after-saving t))
ad-do-it))
(defadvice vm-mime-delete-all-attachments
(around vm-mime-delete-confirm nil activate)
"Confirm whether to delete all MIME attachments. (JJK - advice)"
(and (yes-or-no-p "DELETE *all* MIME attachments? ")
ad-do-it))
; Here is some advice that remembers where you previously saved stuff
; so that you don't have to keep typing the whole directory path
(defadvice vm-mime-send-body-to-file
(after vm-mime-attachment-save-directory nil activate)
"Set `vm-mime-attachment-save-directory' to directory where last
attachment was saved. (JJK - advice)"
(setq vm-mime-attachment-save-directory
(directory-file-name (file-name-directory ad-return-value)))
)
(defadvice vm-mime-attach-file
(after vm-mime-attachment-source-directory nil activate)
"Set `vm-mime-attachment-source-directory' to directory where last
attachment was attached. (JJK - advice)"
(setq vm-mime-attachment-source-directory
(directory-file-name (file-name-directory (ad-get-arg 0))))
)
(defadvice vm-mime-attach-mime-file
(after vm-mime-attachment-source-directory nil activate)
"Set `vm-mime-attachment-source-directory' to directory where last
attachment was attached. (JJK - advice)"
(setq vm-mime-attachment-source-directory
(directory-file-name (file-name-directory (ad-get-arg 0))))
)
; Here is a hack to w32-drag-n-drop event that allows you to
; drag-n-drop files (in Windoze) to email compositions as mime attachments
(defun w32-drag-n-drop (event)
"Edit the files listed in the drag-n-drop EVENT.
Switch to a buffer editing the last file dropped.
JJK: Added logic so that adds mime attachments if dragged over a buffer
in \"Mail\" mode"
(interactive "e")
(save-excursion
;; Make sure the drop target has positive co-ords
;; before setting the selected frame - otherwise it
;; won't work. <s...@tardis.ed.ac.uk>
(let* ((window (posn-window (event-start event)))
(coords (posn-x-y (event-start event)))
(x (car coords))
(y (cdr coords)))
(if (and (> x 0) (> y 0))
(set-frame-selected-window nil window))
; JJK addition start
(if (eq (current-local-map) vm-mail-mode-map)
(mapcar
(lambda (file)
(vm-mime-attach-file file
(or (vm-mime-default-type-from-filename file)
"application/octet-stream")))
(car (cdr (cdr event))))
(mapcar 'find-file (car (cdr (cdr event))))))
; JJK addition end
; (mapcar 'find-file (car (cdr (cdr event)))))
(raise-frame)))
;; Stretch/Shrink mime image to fit exactly in frame width.
;; The shrink functionality is particularly helpful since images displayed
;; by emacs look wacked when they extend past a line width
(defun vm-mime-fitwidth-image (extent)
"Stretch/Shrink mime image to fit exactly in frame width (JJK)."
(let* ((layout (vm-extent-property extent 'vm-mime-layout))
(blob (get (vm-mm-layout-cache layout)
'vm-mime-display-internal-image-xxxx))
dims tempfile factor)
;; Emacs 19 uses a different layout cache than XEmacs or Emacs 21+.
;; The cache blob is a list in that case.
(if (consp blob)
(setq tempfile (car blob))
(setq tempfile blob))
(setq dims (vm-get-image-dimensions tempfile))
(setq factor (/ (float (* (1- (frame-width)) (frame-char-width))) (car dims)))
(vm-mime-frob-image-xxxx extent
"-scale"
(concat (int-to-string (* factor (car dims)))
"x"
(int-to-string (* factor (nth 1 dims)))))))
;; Functionality to add above function to standard attachment menu
(add-hook 'vm-menu-setup-hook
(lambda ()
(require 'easymenu)
(easy-menu-add-item vm-menu-fsfemacs-image-menu
nil
["Fit to width"
(vm-mime-run-display-function-at-point 'vm-mime-fitwidth-image)
(stringp vm-imagemagick-convert-program)]
"4x Larger" )
(easy-menu-add-item vm-menu-fsfemacs-attachment-menu
nil
["Save attachment..."
(vm-mime-run-display-function-at-point
'vm-mime-send-body-to-file)
t ]
"Set Content Disposition..." )
(easy-menu-add-item vm-menu-fsfemacs-attachment-menu
nil
["Delete attachment..."
(vm-delete-mime-object)
t ]
"Set Content Disposition..." )
(easy-menu-add-item vm-menu-fsfemacs-attachment-menu
nil
["Attach to message..."
(call-interactively 'vm-mime-attach-object-from-message)
t ]
"Set Content Disposition..." )
(easy-menu-add-item vm-menu-fsfemacs-attachment-menu
nil
["Display as Ascii"
(vm-mime-run-display-function-at-point
'vm-mime-display-body-as-text)
t ]
"Set Content Disposition..." )
(easy-menu-add-item vm-menu-fsfemacs-attachment-menu
nil
["Pipe to Command"
(vm-mime-run-display-function-at-point
'vm-mime-pipe-body-to-queried-command-discard-output)
t ]
"Set Content Disposition..." )
))
; Ever get lots of hex characters (e.g., \225) in your email due to
; weird encodings? The folllowing converts many of the weird ones I
; have encountered over the years to the closest ascii representation
;;; vm-presentation-mode-hook
(add-hook 'vm-presentation-mode-hook
(lambda ()
(or buffer-display-table
;; Don't let disp-table.el overwrite standard-display-table:
(let ((standard-display-table standard-display-table))
(setq buffer-display-table (make-display-table))))
(aset buffer-display-table ?\x85 [?.?.?.]) ; \205 ellipsis
(aset buffer-display-table ?\x91 [?\']) ; \221 left single quote
(aset buffer-display-table ?\x92 [?\']) ; \222 right single quote
(aset buffer-display-table ?\x93 [?\"]) ; \223 left double quote
(aset buffer-display-table ?\x94 [?\"]) ; \224 right double quote
(aset buffer-display-table ?\x95 [?\*]) ; \225
(aset buffer-display-table ?\x96 [?\-]) ; \226
(aset buffer-display-table ?\x97 [?\-?\-]) ; \227 long dash
(aset buffer-display-table ?\xA0 [? ]) ; \240 non-breaking space
(aset buffer-display-table ?\xA9 [?(?C?)]) ; \251 copyright
(aset buffer-display-table ?\xAE [?(?R?)]) ; \256 registered
(aset buffer-display-table ?\xB7 [?*]) ; \267 center dot
(aset buffer-display-table ?\xE9 [?e?\']) ; \351 e'
;; Make ^M invisible:
(aset buffer-display-table ?\x0D [])))
; If you ever use smtpmail to hold off on sending emails when you are
; offline, then you may run into the problem that you forget to send
; them when you are back online. So the following advice helps out...
(require 'smtpmail)
(setq
send-mail-function 'smtpmail-send-it
smtpmail-queue-mail t ; don't set if you don't want to queue mail
)
(defun smtpmail-send-queued-mail-check ()
"*If mail exist in queue, query whether user wants to send it. (JJK)"
(and (featurep 'smtpmail)
(file-exists-p smtpmail-queue-index)
(plusp ; size > 0
(nth 7 (file-attributes smtpmail-queue-index)))
(y-or-n-p "Do you want to send queued mail now? ")
(smtpmail-send-queued-mail))
)
(add-hook
'vm-quit-hook ; Ask before quitting vm
'smtpmail-send-queued-mail-check)
))
(defadvice vm
(after smtpmail-send-queued-mail-check nil disable)
"Check for queued mail when starting vm (JJK - advice)"
(smtpmail-send-queued-mail-check))
(defadvice vm-mail-send
(after smtpmail-send-queued-mail-check nil disable)
"Check for queued mail when sending mail (JJK - advice)"
(smtpmail-send-queued-mail-check))
(defadvice vm-get-new-mail
(after smtpmail-send-queued-mail-check nil disable)
"Check for queued mail when gettin mail (JJK - advice)"
(smtpmail-send-queued-mail-check))
(ad-enable-regexp "smtpmail-send-queued-mail-check")
(ad-activate-regexp "smtpmail-send-queued-mail-check")
; When sending mail, the following functionality first tries to set
; the 'from' address based on comparing the TO/CC/BCC fields with
; values in a user-defined alist. Then it asks the user whether he/she
; wants to use the guessed value or to input his/her own value.
;; Allow for both automatic and user-specified determination of the
;; 'from' address. Automatic determination is based on the recipient
;; (i.e., 'To:', 'Cc:', 'Bcc:') fields
(defvar vm-user-mail-address-alist nil
"*Alist of user-mail-address values to use for different mail recipients
Entries are of form
\"<Regexp to match in To/CC/BCC-address>\" . \"<Corresponding from address>\"
If using address just for completion, then set the car to nil. (JJK)")
(defun mail-get-header-value (field)
"Return the string corresponding to the value of the mail header FIELD.
Strip out leading and trailing white space.
Returns nil if FIELD not present. (JJK)"
(let ((case-fold-search t)
(field-regex (concat "^" (regexp-quote field) ":[ \t]*"))
(header-end (1+ (mail-header-end)))
field-start result)
(save-excursion
(goto-char (point-min))
(while ; 'while' is used to allow for repeated headers
(setq field-start (re-search-forward field-regex header-end t))
(re-search-forward "[ \t\n]*\n[^ \t]" header-end t) ; End of field
; Note need to use a separate re-search-forward because headers can be split across multiple lines
(setq result
(concat result
(buffer-substring field-start (match-beginning 0))
" "))
(beginning-of-line))
result
)))
(defadvice vm-mail-send (around vm-user-mail-address-alist nil activate)
"Set the 'From' address based on matches in the recipient lines
(To, Cc, Bcc) against vm-user-mail-address-alist. If match exists then confirm.
If prefix-argument then query for a new 'From' address even if recipient
is a match.
NOTE: For now default is to always query for from (JJK)"
(let
((user-mail-address user-mail-address) ; local variable wrapper
address-string new-mail-address invalid)
(setq address-string
(mapconcat
'mail-get-header-value
'("To" "Cc" "Bcc") ""))
(setq new-mail-address ; use alist to find 'from' address
(assoc-default ; don't match 'nil' alist members
address-string vm-user-mail-address-alist
'(lambda (elem key) (if elem (string-match elem key)))))
(and new-mail-address (setq user-mail-address new-mail-address))
(if (or new-mail-address
current-prefix-arg
t) ; NOTE: For now default is to always query for from
(while ; query and confirm valid 'from' address
(progn
(setq user-mail-address
(completing-read
(concat invalid "'From' address: ")
(mapcar ; Generate possible 'From' addresses
'(lambda (elem) (list (cdr elem))) vm-user-mail-address-alist)
nil nil
user-mail-address))
(setq invalid "INVALID ")
(not (string-match "^[-_+.a-zA-Z0-9]+\\(@[-_+.a-zA-Z0-9]+\\)?$"
user-mail-address)))))
ad-do-it ; call vm-mail-send
(message "%s [From: %s]" (current-message) user-mail-address)
))
; The following vm summary function is useful when using virtual
; folders and you want to know which folder a message comes from.
; Here is an example vm-summary-format using it:
; "%n%*%1UA%a %-17.17F %-3.3m %2d %UY %-4.4US %-12.12(\(%.10UF\)%) %I%s\n")
(defun vm-summary-function-F (MSG)
"Return the actual buffer folder name where message is stored.
You may add this to the summary line by \"%UF\".
Argument MSG is a message pointer.(JJK)"
(buffer-name (vm-buffer-of (vm-real-message-of MSG))))
; The following vm summary function is useful when looking through a
; long history of old mail where there may be year ambiguity, but you
; don't want to waste summary line real estate on the year for recent mail
; Here is an example vm-summary-format using it:
; "%n%*%1UA%a %-17.17F %-3.3m %2d %UY %-4.4US %I%s\n")
(defun vm-summary-function-Y (MSG)
"Return: \"YYYY\" if not within -10 or +1 months of current date;
otherwise, return \"\"
You may add this to the summary line by \"%UY\".
Argument MSG is a message pointer.(JJK)"
(let* ((msg-year (vm-year-of MSG))
(msg-month (+ (string-to-number (vm-month-number-of MSG))
(* 12 (string-to-number msg-year))))
(time (decode-time))
(curr-month (+ (nth 4 time) (* 12 (nth 5 time)))))
(cond
((or (> (- curr-month msg-month) 10)
(> (- msg-month curr-month) 1))
msg-year)
(t ""))))
; Here is some messaging marking functionality that I have found
; useful
(defun vm-mark-message-next (count)
"Mark the current message and go to the next message.
Numeric prefix argument N means mark the current message and the next
N-1 messages. A negative N means mark the current message and the
previous N-1 messages. (JJK)"
(interactive "p")
(if (interactive-p)
(vm-follow-summary-cursor))
(vm-mark-message count)
(if (interactive-p)
(vm-next-message-no-skip count)))
(defun vm-unmark-message-next (count)
"Remove the mark from the current message and go to the next message.
Numeric prefix argument N means unmark the current message and the next
N-1 messages. A negative N means unmark the current message and the
previous N-1 messages. (JJK)"
(interactive "p")
(if (interactive-p)
(vm-follow-summary-cursor))
(vm-unmark-message count)
(if (interactive-p)
(vm-next-message-no-skip count)))
(defun vm-next-message-no-skip-noerr (&optional count)
"Like vm-next-message-no-skip but will not give error if at beginning or end of buffer. (JJK)"
(interactive "p")
(if (interactive-p)
(vm-follow-summary-cursor))
(vm-select-folder-buffer)
(vm-display nil nil '(vm-next-message-no-skip)
'(vm-next-message-no-skip))
(let ((vm-skip-deleted-messages nil)
(vm-skip-read-messages nil))
(vm-next-message count nil nil)))
; And last but not least, the following is one of my true favorites...
; Ever finding yourself continually waiting for your existing fetchmail daemon
; to hurry up and finally fetch your mail. Well, instead just call this
; function from emacs to call fetchmail when you want it.
;Note this runs the users local fetchmail process as configured by
;~/.fetchmailrc
(defvar vm-fetchmail-function "/usr/bin/fetchmail"
"Function used to fetch remote mail (JJK)")
(defvar vm-fetchmail-options nil
"Optional string of options to pass to fetchmail (JJK)")
(defvar vm-fetchmail-mailservers nil
"Optional string of mailservers to fetch from (JJK)")
; Note if you need to provide a password and don't either in your
; ~/.fetchmailrc folder or as a command line option then the process will hang
(defun vm-fetchmail ()
"*Fetch mail asynchronously from remote server (JJK)"
(interactive)
(cond
((file-executable-p vm-fetchmail-function)
(set-process-sentinel
(apply 'start-process "Fetchmail" "*Fetchmail*"
(delete nil
(list vm-fetchmail-function
vm-fetchmail-options
vm-fetchmail-mailservers)))
; Note above is needed because start-process requires PROGRAM-ARGS
; to be strings while fetchmail will interpret strings as mailservers
'vm-fetchmail-sentinel)
(message "Fetching new mail..."))
(t (error "Error: Fetchmail not found on system!"))))
(defun vm-fetchmail-sentinel (process status)
(beep t)
(setq status (substring status -2 -1))
(message "Finished fetching... %s"
(if (string= status "d") "*New mail*"
(setq status (string-to-number status))
(cond
((= status 1) "No new mail")
((= status 2) "Error opening socket")
((= status 3) "User authentication failed")
((= status 4) "Fatal protocol error")
((= status 5) "Syntax error")
((= status 6) "Bad permissions on run control file")
((= status 7) "Error condition reported by server")
((= status 8) "Client-side exclusion error")
((= status 9) "Lock busy")
(t "Other error")))))
blueman
Found one error, the vm-presentation-mode-hook should instead be
vm-showing-message-hook.