[Date Prev][Date Next][Thread Prev][Thread Next][Date Index][Thread Index]
Making mail-envelope-from buffer-local
Making mail-envelope-from buffer-local
4 Jul 2003 03:05:13 -0000
In GNU Emacs 21.2.1 (i586-suse-linux, X toolkit, Xaw3d scroll bars)
of 2002-09-11 on amdsimb
configured using `configure '--with-gcc' '--with-pop' '--with-system-malloc'
'--prefix=/usr' '--exec-prefix=/usr' '--infodir=/usr/share/info'
'--mandir=/usr/share/man' '--sharedstatedir=/var/lib' '--libexecdir=/usr/lib'
'--with-x' '--with-xpm' '--with-jpeg' '--with-tiff' '--with-gif' '--with-png'
'--x-libraries=/usr/X11R6/lib' 'i586-suse-linux' 'CC=gcc' 'CFLAGS=-O2
-march=i586 -mcpu=i686 -fmessage-length=0 -pipe
-D_GNU_SOURCE ' 'LDFLAGS=-s' 'build_alias=i586-suse-linux'
value of $LC_ALL: nil
value of $LC_COLLATE: POSIX
value of $LC_CTYPE: nil
value of $LC_MESSAGES: nil
value of $LC_MONETARY: nil
value of $LC_NUMERIC: nil
value of $LC_TIME: nil
value of $LANG: en_US
This is more of the nature of a small enhancement.
In emacs 20.7, I developed a hack to specify envelope senders for
each message independently. This is useful for managing mailing lists
with qmail address extensions, for example. When I upgraded to 21.2
(with SuSE 8.1), I found that the new sendmail-send-it has a much nicer
mechanism than the kludge I had been using. I now only need to do the
(setq mail-specify-envelope-from t)
(setq mail-envelope-from new-return-address)
However, it doesn't work to make these buffer-local in the *mail*
(set (make-local-variable 'mail-specify-envelope-from) t)
(set (make-local-variable 'mail-envelope-from) new-return-address)
This is because the switch to the temporary buffer used by
sendmail-send-it leaves these variables behind. The patch below
"samples" these variables before the buffer switch, which is enough to
make the assign-to-local-variables version above work. It also has the
minor advantage of not passing "-f" to sendmail if user-mail-address is
nil, an admittedly odd situation.
I have also included my vm+qmail.el source, on the off chance that
you might find it easier to use v+q-set-return-address to test the
patch. If this is not sufficient, and you are not convinced of the
value/workingness of the patch, please let me know, as I am eager to see
this feature adopted so that I can flush my original kludge.
Thanks in advance,
-- Bob Rogers
address@hidden> cd /usr/share/emacs/21.2/lisp/mail/
address@hidden> diff -u sendmail.el.~2~ sendmail.el
--- sendmail.el.~2~ 2002-02-02 09:47:39.000000000 -0500
+++ sendmail.el 2003-07-03 22:35:57.000000000 -0400
@@ -807,7 +807,11 @@
(program (if (boundp 'sendmail-program)
- (mail-envelope-from mail-envelope-from))
+ ;; Compute the sender before switching to tembuf, so that these
+ ;; variables can be buffer-local to the mail buffer. -- rgr, 3-Jul-03.
+ (envelope-sender (and mail-specify-envelope-from
+ (or mail-envelope-from
@@ -973,9 +977,8 @@
(append (list (point-min) (point-max)
nil errbuf nil "-oi")
- (and mail-specify-envelope-from
- (list "-f" (or mail-envelope-from
+ (and envelope-sender
+ (list "-f" envelope-sender))
;;; ;; Don't say "from root" if running under su.
;;; (and (equal (user-real-login-name) "root")
;;; (list "-f" (user-login-name)))
;;; Hacks for using qmail (as MTA) with VM (as MUA).
;;; Modification history:
;;; created. -- rgr, 21-Feb-00.
;;; v+q-base-return-address override, related changes. -- rgr, 5-Mar-00.
;;; v+q-set-return-address: now a command, actually sets envelope 'From:'
;;; address properly (at least for sendmail-send-it). -- rgr, 2-Apr-00.
;;; v+q-set-return-address: user-mail-address hacking. -- rgr, 4-Apr-00.
;;; v+q-user-full-name feature. -- rgr, 17-Apr-00.
;;; v+q-mbox-status: use dir instead of vm-spool-files. -- rgr, 18-Apr-00.
;;; "From:" header now obeys mail-from-style, change v+q-base-return-address
;;; and v+q-user-full-name defaults to nil. -- rgr, 20-Apr-00.
;;; took a stab at vm Maildir support, v+q-mbox-status now handles Maildir.
;;; -- rgr, 23-Apr-00.
;;; vm-maildir-move-mail-internal: fix date format. -- rgr, 9-May-00.
;;; v+q-display-message, related v+q-mbox-status cleanup. -- rgr, 15-May-00.
;;; v+q-generate-password: use prefix for length, case-p. -- rgr, 31-May-00.
;;; v+q-set-return-address: new terms, addr in inbox list. -- rgr, 17-Dec-00.
;;; extend v+q-mbox-directory syntax in v+q-mbox-status, loosen
;;; v+q-folder-special-return-address maildir "syntax." -- rgr, 2-Jan-01.
;;; v+q-mbox-status: directory name ellipsis. -- rgr, 6-Feb-01.
;;; v+q-mbox-status: vm-session-initialization call. -- rgr, 11-Feb-01.
;;; v+q-mbox-status: mboxes in v+q-mbox-directory list. -- rgr, 22-Apr-02.
;;; allow maildirs to end in "/" in v+q-folder-special-return-address, fix
;;; vm-maildir-move-mail-internal verbosity and no-mail-but-modified bug.
;;; -- rgr, 24-Jul-02.
;; [disabled, so we can leave rmail-mbox-status here. -- rgr, 13-May-03.]
;; (require 'vm)
(defvar v+q-base-return-address nil
"This is the base 'address@hidden' string that should be augmented to
'address@hidden' for replies to mailing list 'list'. If nil (the
default), the value of user-mail-address is used instead.")
(defvar v+q-user-full-name nil
"*Full name (e.g. \"Bob Rogers\") for augmenting return lists. Must
be RFC822-friendly -- \"Joe O'Rourke\" is OK, but \"Joe...Shmoe\" isn't.
\(Actually, I think this is now quoted correctly. -- rgr, 2-Jan-01.)")
(defvar v+q-mbox-directory "~/"
"*For the v+q-mbox-status command. Can be either a string naming an
mbox file or a Maildir directory, or a list of such strings and/or
\(directory-name regxep) pairs. If specified, the regexp will override
v+q-mbox-regexp, which supplies the default. All files/subdirs in each
directory that match the corresponding regexp are considered
inboxes/maildirs (so be careful of . and ..!).")
(defvar v+q-mbox-regexp "^Mailbox\\|^Maildir"
"*Default inbox regexp for the v+q-mbox-status command.")
(defvar v+q-verbose-p nil
"*Enable this to get extra spew.")
(defvar folder-buffer) ;; to make the byte-compiler happy.
(defvar buffer-user-mail-address) ;; ditto.
(defun v+q-incoming-message-count (mbox-or-maildir)
;; Return the number of messages in mbox-or-maildir. If an mbox, use grep to
;; count them; if a maildir use ls/wc. [the maildir case is not actually used
;; any more. -- rgr, 15-May-00.]
(let ((maildir-p (file-directory-p mbox-or-maildir)))
(set-buffer (get-buffer-create " *v+q temp*"))
(call-process "csh" nil t nil "-c"
(format "ls '%s/new' | wc -l" mbox-or-maildir))
;; This isn't quite right, since there must be a blank line before it.
(call-process "grep" nil t nil "-c" "^From " mbox-or-maildir))
(defun v+q-maildir-incoming-message-count (maildir)
;; Return the number of messages in maildir by counting the directory entries
;; in the maildir/new/ subdirectory.
(let ((files (directory-files (expand-file-name "new/" maildir)))
(or (member (car files) '("." ".."))
(setq count (1+ count)))
(setq files (cdr files)))
(defun v+q-display-message (message)
;; Display a message with minimum fuss, as long as the user can read it.
;; Steals from the ispell interface.
(if (< (length message) (frame-width))
(message "%s" message)
(let* ((buffer (get-buffer-create "*v+q message*"))
(let ((fill-column (1- (frame-width))))
(count-lines (point-min) (point-max)))))
;; this overlays the top N lines of the current window.
;; unfortunately, it doesn't seem to like to do less than 4
;; lines, but this does have to include the window mode line.
(ispell-overlay-window (max 4 (1+ buffer-lines)))
(if (fboundp 'read-char-exclusive)
(read-char-exclusive "Type any character to dismiss: ")
(read-char "Type any character to dismiss: "))))
(defun v+q-mbox-status-internal (inbox-list)
(let ((result nil)
(directory-tail (if (listp inbox-list)
(let* ((entry (car directory-tail))
(directory (if (consp entry) (car entry) entry))
(tail (cond ((file-directory-p directory)
(directory-files directory t
;; extract regexp
(if (consp entry)
(car (cdr entry))
;; See if there's any mail in inbox.
(let* ((inbox (car tail))
(if (file-directory-p inbox)
(if (> n-messages 0)
(concat ".../" (file-name-nondirectory inbox))
(format "%s, %d in %s"
result n-messages inbox-short-name)
(format "%d message%s in %s"
n-messages (if (= n-messages 1) "" "s")
(setq dir-printed-p t))))
(setq tail (cdr tail))))
(setq directory-tail (cdr directory-tail)))
(v+q-display-message (concat result "."))
(message "No messages"))))
(defun v+q-mbox-status ()
"Summarize how many messages are waiting in all known mbox files and Maildir
directories, controlled by the v+q-mbox-directory and v+q-mbox-regexp variables.
Messages are reported regardless of whether the box or directory appears as an
inbox in the vm-spool-files list. Doesn't handle POP or IMAP drops."
;; vm-session-initialization is necessary to ensure that ~/.vm is loaded
;; properly. -- rgr, 11-Feb-01.
(defun rmail-mbox-status ()
"Summarize how many messages are waiting in all known mbox files,
controlled by the rmail-primary-inbox-list variable."
;;; Munging return addresses.
(defun v+q-folder-spool-file-entry (folder)
;; Given a folder, return its entry in vm-spool-files, if any.
(let ((result nil)
(let* ((entry (car tail))
(folder-name (and (consp entry)
(if (and folder-name
(eq (get-file-buffer (expand-file-name folder-name)) folder))
(setq result entry
;; no luck; keep searching.
(setq tail (cdr tail)))))
(defun v+q-default-mailing-list-return-address (mailing-list)
;; Return the right "From:" email address to use for replies to messages from
;; the named mailing list.
(let ((new-return-address (or v+q-base-return-address
(if (string-match "@" new-return-address)
(replace-match (concat "-" mailing-list "@")
t t new-return-address)
(defun v+q-folder-special-return-address (folder)
;; Return the right "From:" address for replies to messages from the given
;; folder (a buffer), or nil if the default "From:" address will do. The
;; vm-spool-files might specify a particular address (in the undocumented
;; fourth entry), or the inbox/maildir name might imply a mailing list with a
;; separate subscriber address. For a list "foo" in the latter case, the
;; inbox/maildir name must end with ".foo", and there must be a ~/.qmail-foo
;; file (which presumably directs qmail-local to put it in the given
(let ((entry (v+q-folder-spool-file-entry folder)))
;; overriding name
(or (nth 3 entry)
;; check for the inbox/maildir & .qmail file naming convention.
(let* ((inbox-name (and (consp entry)
(consp (cdr entry))
(car (cdr entry))))
(cond ((null inbox-name) nil)
((string-match "\\.[^./]+$" inbox-name)
(substring inbox-name (1+ (match-beginning 0))))
;; really a maildir; we'll use the whole name in
;; that case.
(let ((len (length inbox-name)))
(if (= (aref inbox-name (1- len)) ?/)
(substring inbox-name 0 (1- len))
(if (and list-name
(file-readable-p (concat "~/.qmail-" list-name)))
(defun v+q-mail-buffer-special-return-address ()
;; Return the mailing list name (not the address) for the list associated with
;; the (current) reply buffer.
;; using just vm-mail-buffer would be cleaner, but vm-mail-internal
;; doesn't set it until after mail-mode is invoked. so we must look
;; at folder-buffer as well, which vm-mail-internal binds.
(or (and (boundp 'vm-mail-buffer) vm-mail-buffer)
(and (boundp 'folder-buffer) folder-buffer))))
(defun v+q-sendmail-send-it ()
;; user-mail-address is a buffer-local variable, but sendmail-send-it won't
;; see the new value because it copies the buffer contents into a scratch
;; buffer before mailing. [haven't tried smtpmail-send-it yet, but it appears
;; to do the same. it'd be nice to have lexical closures here . . . -- rgr,
(kill-local-variable 'user-mail-address) ;; be sure it's gone.
(let ((user-mail-address (or buffer-user-mail-address
;; [this doesn't work; sendmail-send-it sees the old value after doing
;; (set-buffer tembuf). -- rgr, 21-Feb-00.] [works now; the trick is not
;; to try to make user-mail-address buffer-local. -- rgr, 2-Apr-00.]
(message "Binding user-mail-address to %S" user-mail-address))
(defun v+q-insert-from-header (login)
;; Stolen from the sendmail-send-it function; inserts a "From:" header at
;; (point-min) according to message-from-style, with proper RFC822 quoting and
;; encoding. -- rgr, 20-Apr-00.
(let ((fullname (or v+q-user-full-name (user-full-name)))
(if (string-match "[\200-\377]" fullname)
(setq fullname (mail-quote-printable fullname t)
(cond ((eq mail-from-style 'angles)
(insert "From: " fullname)
(let ((fullname-start (+ (point-min) 6))
;; Look for a character that cannot appear unquoted
;; according to RFC 822.
(if (or (re-search-forward "[^- !#-'*+/-9=?A-Z^-~]"
;; Quote fullname, escaping specials.
(while (re-search-forward "[\"\\]"
(replace-match "\\\\\\&" t))
(insert " <" login ">\n"))
((eq mail-from-style 'parens)
(insert "From: " login " (")
(let ((fullname-start (point)))
(let ((fullname-end (point-marker)))
;; RFC 822 says \ and nonmatching parentheses
;; must be escaped in comments.
;; Escape every instance of ()\ ...
(while (re-search-forward "[()\\]" fullname-end 1)
(replace-match "\\\\\\&" t))
;; ... then undo escaping of matching parentheses,
;; including matching nested parentheses.
(replace-match "\\1(\\3)" t)
(insert "From: " login "\n"))
((eq mail-from-style 'system-default)
(t (error "Invalid value for `mail-from-style'")))))
(defun v+q-set-return-address (new-return-address)
"Set the envelope and reply addresses to the given return address.
Interactively prompts for a new return address."
(list (let ((default (or (v+q-mail-buffer-special-return-address)
(read-string "'From' user: " (cons default 0) nil default))))
(let ((old-user-mail-address user-mail-address))
;; Add default Reply-To: field. (actually, vm-mail-internal does this for
;; us once we set mail-default-reply-to appropriately. -- rgr, 21-Feb-00.]
;; [no; better to set the 'From:' header. -- rgr, 2-Apr-00.]
;; (make-local-variable 'mail-default-reply-to)
;; (setq mail-default-reply-to new-return-address)
;; Add a "From:" header based on new-return-address, so that replies go
;; to the same inbox as list mail. If we don't do this, sendmail-send-it
;; will build one based on user-mail-address.
;; [***bug***: this save-excursion works if i call this interactively, but
;; it seems to have the opposite effect from the hook! -- rgr, 17-Dec-00.]
;; Customize send-mail-function for sendmail, since sendmail-send-it copies
;; the buffer contents into a scratch buffer.
(cond ((not (eq send-mail-function 'sendmail-send-it))
(error "Oops; can't set return address for the '%S' sender."
;; emacs 21 supports this directly (but 21.2 requires a patch to
;; make it work when these are buffer-local). -- rgr, 3-Jul-03.
(set (make-local-variable 'mail-specify-envelope-from) t)
(set (make-local-variable 'mail-envelope-from) new-return-address))
;; kludgery for version 20 and earlier.
(setq buffer-user-mail-address new-return-address)
;; This would make the lambda-binding in v+q-sendmail-send-it fail
;; when sendmail-send-it does set-buffer, except that
;; v+q-sendmail-send-it now undoes this binding. And we need this
;; so that mail-self-blind, and perhaps other features, continue to
;; work as if this was our real address. -- rgr, 4-Apr-00.
(setq user-mail-address new-return-address)
(setq send-mail-function 'v+q-sendmail-send-it)))
(if (and v+q-verbose-p
(not (equal new-return-address old-user-mail-address)))
(message "Changed %S to %S."
(defun v+q-maybe-change-return-address ()
"Possibly customize the 'From:' address based on a folder mailing list.
Put this on mail-mode-hook to use it."
(let ((address (v+q-mail-buffer-special-return-address)))
(defun v+q-mail-hook ()
"Customize vm-mail mode for what might be a reply to a mailing list
delivered locally by qmail. Put this on mail-mode-hook to use it."
;; So far, this is just equivalent to v+q-maybe-change-return-address, but I'm
;; keeping it around, as it is a logical place to put key bindings (if I ever
;; need any). -- rgr, 2-Apr-00.
(defun v+q-generate-password (&optional password-length)
"Generate a password using alphanumerics plus unshifted special characters.
It will be echoed in the message area; see the *Messages* buffer if you
want to cut-and-paste it somewhere. The password will be completely
obscure, since it is generated randomly. The default length is 8
characters long, unless you give the command a numeric argument. If the
argument is negative, it will produce something that doesn't use shift
keys at all."
;; part of vm+qmail for no good reason. -- rgr, 21-Feb-00.
(let* ((alphabet "abcdefghijklmnopqrstuvwxyz")
(chars (concat alphabet
(if (and (numberp password-length)
(< password-length 0))
(max (length chars))
(password-length (if password-length
(abs (prefix-numeric-value password-length))
(i 0) (result nil))
(while (< i password-length)
(setq result (cons (aref chars (random max)) result))
(setq i (1+ i)))
(setq result (concat result))
;;; Hacking a maildir reader.
;; Seems to work, but I'm nervous that there's something I'm missing about mbox
;; format. In any case, it would be better to do something more robust, such as
;; generate From_-with-Content-Length format (see vm-get-folder-type, which is
;; used by vm-gobble-crash-box). -- rgr, 23-Apr-00.
(defun vm-maildir-scarf (regexp)
(and (re-search-forward regexp nil t)
(defun vm-maildir-file-date (file)
;; Return the file date in the format used for mbox files, which is the same
;; as that returned by current-time-string, e.g. "Mon May 8 00:22:28 2000".
;; We have to handle the leading zero on the day specially. If your "date"
;; command doesn't handle the "-r" option, replace this function by something
;; that just returns nil.
(let ((buffer (get-buffer-create "*vm-maildir-date*")))
(call-process "date" nil t nil
"-r" file "+%a %b %d %T %Y")
(let ((string (buffer-substring (point-min) (1- (point-max)))))
;; Now we have to deal with possible leading zeros in the day.
(if (eq (aref string 8) ?0)
(aset string 8 ?\ ))
(defun vm-maildir-insert-message (file)
;; protect against accidental "From " lines.
(let ((case-fold-search nil))
(while (re-search-forward "^From " nil t)
(replace-match ">From " t t))))
;; generate the real "From " line.
(let ((sender (vm-maildir-scarf "Return-Path *: *<\\(.*\\)>$"))
(date (vm-maildir-file-date file)))
(insert "From " (or sender "nobody") " "
(or date (current-time-string)) "\n"))
;; Extra newline to buffer the next "From ".
(defun vm-maildir-move-mail-internal (source destination)
(let* ((buffer (generate-new-buffer "*vm-read-maildir*"))
(new-dir (expand-file-name "new" source))
(new-files (directory-files new-dir t))
(message "Got files %S" new-files))
(let ((tail new-files))
(let ((file (car tail)))
(cond ((not (string-match "/[.]+$" file))
(setq new-mail (cons file new-mail)))))
(setq tail (cdr tail))))
;; We've now sucked in all new mail; write to the crash box,
;; after which it will be safe to flush the incoming files.
(write-region (point-min) (point-max) destination)
(mapcar (function delete-file) new-mail))))
(defun vm-maildir-move-mail (source destination)
;; based on the vm-spool-move-mail function. -- rgr, 22-Apr-00.
(let ((handler (and (fboundp 'find-file-name-handler)
(find-file-name-handler source 'vm-maildir-move-mail)
(funcall handler 'vm-maildir-move-mail source destination)
(vm-maildir-move-mail-internal source destination))))
;; (v+q-folder-special-return-address (get-buffer "anna.vm"))
;; (v+q-folder-special-return-address (get-buffer "cmu-cl.vm"))
;; (v+q-folder-special-return-address (get-buffer "queue"))
- Making mail-envelope-from buffer-local,
Bob Rogers <=