(require 'sendmail)
(defgroup mail-abbrev nil
"Expand mail aliases as abbrevs, in certain mail headers."
:group 'abbrev-mode)
(defcustom mail-abbrevs-mode nil
"*Non-nil means expand mail aliases as abbrevs, in certain message headers."
:type 'boolean
:group 'mail-abbrev
:require 'mailabbrev
:set (lambda (symbol value)
(setq mail-abbrevs-mode value)
(if value (mail-abbrevs-enable) (mail-abbrevs-disable)))
:initialize 'custom-initialize-default
:version "20.3")
(defcustom mail-abbrevs-only nil
"*Non-nil means only mail abbrevs should expand automatically.
Other abbrevs expand only when you explicitly use `expand-abbrev'."
:type 'boolean
:group 'mail-abbrev)
(defvar mail-abbrevs nil
"Word-abbrev table of mail address aliases.
If this is nil, it means the aliases have not yet been initialized and
should be read from the .mailrc file. (This is distinct from there being
no aliases, which is represented by this being a table with no entries.)")
(defvar mail-abbrev-modtime nil
"The modification time of your mail alias file when it was last examined.")
(defun mail-abbrevs-sync-aliases ()
(if (file-exists-p mail-personal-alias-file)
(let ((modtime (nth 5 (file-attributes mail-personal-alias-file))))
(if (not (equal mail-abbrev-modtime modtime))
(progn
(setq mail-abbrev-modtime modtime)
(build-mail-abbrevs))))))
(defun mail-abbrevs-setup ()
"Initialize use of the `mailabbrev' package."
(if (and (not (vectorp mail-abbrevs))
(file-exists-p mail-personal-alias-file))
(progn
(setq mail-abbrev-modtime
(nth 5 (file-attributes mail-personal-alias-file)))
(build-mail-abbrevs)))
(mail-abbrevs-sync-aliases)
(make-local-hook 'pre-abbrev-expand-hook)
(add-hook 'pre-abbrev-expand-hook 'sendmail-pre-abbrev-expand-hook
nil t)
(abbrev-mode 1))
(defun mail-abbrevs-enable ()
(add-hook 'mail-mode-hook 'mail-abbrevs-setup))
(defun mail-abbrevs-disable ()
"Turn off use of the `mailabbrev' package."
(remove-hook 'mail-mode-hook 'mail-abbrevs-setup)
(abbrev-mode (if (default-value 'abbrev-mode) 1 -1)))
(defun build-mail-abbrevs (&optional file recursivep)
"Read mail aliases from personal mail alias file and set `mail-abbrevs'.
By default this is the file specified by `mail-personal-alias-file'."
(setq file (expand-file-name (or file mail-personal-alias-file)))
(if (vectorp mail-abbrevs)
nil
(setq mail-abbrevs nil)
(define-abbrev-table 'mail-abbrevs '()))
(message "Parsing %s..." file)
(let ((buffer nil)
(obuf (current-buffer)))
(unwind-protect
(progn
(setq buffer (generate-new-buffer " mailrc"))
(buffer-disable-undo buffer)
(set-buffer buffer)
(cond ((get-file-buffer file)
(insert (save-excursion
(set-buffer (get-file-buffer file))
(buffer-substring (point-min) (point-max)))))
((not (file-exists-p file)))
(t (insert-file-contents file)))
(goto-char (point-max))
(or (eq (preceding-char) ?\n) (newline))
(goto-char (point-min))
(while (search-forward "# " nil t)
(let ((p (- (point) 2)))
(end-of-line)
(delete-region p (point))))
(goto-char (point-min))
(while (not (eobp))
(end-of-line)
(if (= (preceding-char) ?\\)
(progn (delete-char -1) (delete-char 1) (insert ?\ ))
(forward-char 1)))
(goto-char (point-min))
(while (re-search-forward
"^\\(a\\(lias\\)?\\|g\\(roup\\)?\\|source\\)[ \t]+" nil t)
(beginning-of-line)
(if (looking-at "source[ \t]+\\([^ \t\n]+\\)")
(progn
(end-of-line)
(build-mail-abbrevs
(substitute-in-file-name
(buffer-substring (match-beginning 1) (match-end 1)))
t))
(re-search-forward "[ \t]+\\([^ \t\n]+\\)")
(let* ((name (buffer-substring
(match-beginning 1) (match-end 1)))
(start (progn (skip-chars-forward " \t") (point))))
(end-of-line)
(define-mail-abbrev
name
(buffer-substring start (point))
t))))
(or recursivep (mail-resolve-all-aliases))
mail-abbrevs)
(if buffer (kill-buffer buffer))
(set-buffer obuf)))
(message "Parsing %s... done" file))
(defvar mail-alias-separator-string ", "
"*A string inserted between addresses in multi-address mail aliases.
This has to contain a comma, so \", \" is a reasonable value. You might
also want something like \",\\n \" to get each address on its own line.")
(defvar mail-abbrev-aliases-need-to-be-resolved t)
(defun define-mail-abbrev (name definition &optional from-mailrc-file)
"Define NAME as a mail alias abbrev that translates to DEFINITION.
If DEFINITION contains multiple addresses, separate them with commas."
(interactive "sDefine mail alias: \nsDefine %s as mail alias for: ")
(if (vectorp mail-abbrevs)
nil
(setq mail-abbrevs nil)
(define-abbrev-table 'mail-abbrevs '())
(if (file-exists-p mail-personal-alias-file)
(build-mail-abbrevs)))
(if (string-match "\\`[ \t\n,]+" definition)
(setq definition (substring definition (match-end 0))))
(if (string-match "[ \t\n,]+\\'" definition)
(setq definition (substring definition 0 (match-beginning 0))))
(let* ((result '())
(L (length definition))
(start (if (> L 0) 0))
end)
(while start
(if from-mailrc-file
(if (eq ?\" (aref definition start))
(setq start (1+ start)
end (string-match "\"[ \t,]*" definition start))
(setq end (string-match "[ \t,]+" definition start)))
(setq end (string-match "[ \t\n,]*,[ \t\n,]*" definition start)))
(setq result (cons (substring definition start end) result))
(setq start (and end
(/= (match-end 0) L)
(match-end 0))))
(setq definition (mapconcat (function identity)
(nreverse result)
mail-alias-separator-string)))
(setq mail-abbrev-aliases-need-to-be-resolved t)
(setq name (downcase name))
(let ((abbrevs-changed abbrevs-changed)) (define-abbrev mail-abbrevs name definition 'mail-abbrev-expand-hook)))
(defun mail-resolve-all-aliases ()
"Resolve all forward references in the mail aliases table."
(if mail-abbrev-aliases-need-to-be-resolved
(progn
(if (vectorp mail-abbrevs)
(mapatoms (function mail-resolve-all-aliases-1) mail-abbrevs))
(setq mail-abbrev-aliases-need-to-be-resolved nil)
)))
(defun mail-resolve-all-aliases-1 (sym &optional so-far)
(if (memq sym so-far)
(error "mail alias loop detected: %s"
(mapconcat 'symbol-name (cons sym so-far) " <- ")))
(let ((definition (and (boundp sym) (symbol-value sym))))
(if definition
(let ((result '())
(start 0))
(while start
(let ((end (string-match "[ \t\n]*,[, \t\n]*" definition start)))
(setq result (cons (substring definition start end) result)
start (and end (match-end 0)))))
(setq definition
(mapconcat (function (lambda (x)
(or (mail-resolve-all-aliases-1
(intern-soft (downcase x) mail-abbrevs)
(cons sym so-far))
x)))
(nreverse result)
mail-alias-separator-string))
(set sym definition))))
(symbol-value sym))
(defun mail-abbrev-expand-hook ()
"For use as the fourth arg to `define-abbrev'.
After expanding a mail-abbrev, if Auto Fill mode is on and we're past the
fill-column, break the line at the previous comma, and indent the next line."
(let ((abbrev-mode nil))
(save-excursion
(let ((p (point))
bol comma fp)
(beginning-of-line)
(setq bol (point))
(goto-char p)
(while (and auto-fill-function
(>= (current-column) fill-column)
(search-backward "," bol t))
(setq comma (point))
(forward-char 1) (insert "\n")
(delete-horizontal-space)
(setq p (point))
(indent-relative)
(setq fp (buffer-substring p (point)))
(end-of-line)
(if (> (current-column) fill-column)
(let ((fill-prefix (or fp "\t")))
(do-auto-fill)))
(goto-char comma)
)))))
(defvar mail-abbrev-mode-regexp
"^\\(Resent-\\)?\\(To\\|From\\|CC\\|BCC\\|Reply-to\\):"
"*Regexp to select mail-headers in which mail abbrevs should be expanded.
This string will be handed to `looking-at' with point at the beginning
of the current line; if it matches, abbrev mode will be turned on, otherwise
it will be turned off. (You don't need to worry about continuation lines.)
This should be set to match those mail fields in which you want abbreviations
turned on.")
(defvar mail-mode-header-syntax-table
(let ((tab (copy-syntax-table text-mode-syntax-table)))
(modify-syntax-entry ?@ "_" tab)
(modify-syntax-entry ?% "_" tab)
(modify-syntax-entry ?! "_" tab)
(modify-syntax-entry ?. "_" tab)
(modify-syntax-entry ?_ "_" tab)
(modify-syntax-entry ?- "_" tab)
(modify-syntax-entry ?< "(>" tab)
(modify-syntax-entry ?> ")<" tab)
tab)
"The syntax table used in send-mail mode when in a mail-address header.
`mail-mode-syntax-table' is used when the cursor is in the message body or in
non-address headers.")
(defvar mail-abbrev-syntax-table
(let* ((tab (copy-syntax-table mail-mode-header-syntax-table))
(_ (aref (standard-syntax-table) ?_))
(w (aref (standard-syntax-table) ?w)))
(map-char-table
(function (lambda (key value)
(if (equal value _)
(set-char-table-range tab key w))))
tab)
tab)
"The syntax-table used for abbrev-expansion purposes.
This is not actually made the current syntax table of the buffer, but
simply controls the set of characters which may be a part of the name
of a mail alias.")
(defun mail-abbrev-in-expansion-header-p ()
"Whether point is in a mail-address header field."
(let ((case-fold-search t))
(and (save-excursion
(beginning-of-line)
(while (and (looking-at "^[ \t]")
(not (= (point) (point-min))))
(forward-line -1))
(looking-at mail-abbrev-mode-regexp))
(< (point) (mail-header-end)))))
(defvar mail-mode-abbrev-table)
(defun sendmail-pre-abbrev-expand-hook ()
(and (and mail-abbrevs (not (eq mail-abbrevs t)))
(if (mail-abbrev-in-expansion-header-p)
(progn
(and mail-abbrev-aliases-need-to-be-resolved
(mail-resolve-all-aliases))
(setq local-abbrev-table mail-abbrevs)
(set-syntax-table mail-mode-header-syntax-table)
(or (and (integerp last-command-char)
(eq (char-syntax last-command-char) ?_))
(let ((pre-abbrev-expand-hook nil)) (set-syntax-table mail-abbrev-syntax-table)
(expand-abbrev)
(set-syntax-table mail-mode-header-syntax-table)))
(setq abbrev-start-location (point-max) abbrev-start-location-buffer (current-buffer)))
(if (or (not mail-abbrevs-only)
(eq this-command 'expand-abbrev))
(progn
(setq local-abbrev-table (and (boundp 'mail-mode-abbrev-table)
mail-mode-abbrev-table))
(set-syntax-table mail-mode-syntax-table))
(setq abbrev-start-location (point-max)
abbrev-start-location-buffer (current-buffer))))
))
(defun merge-mail-abbrevs (file)
"Merge mail aliases from the given file with existing ones."
(interactive (list
(let ((insert-default-directory t)
(default-directory (expand-file-name "~/"))
(def mail-personal-alias-file))
(read-file-name
(format "Read additional aliases from file: (default %s) "
def)
default-directory
(expand-file-name def default-directory)
t))))
(build-mail-abbrevs file))
(defun rebuild-mail-abbrevs (&optional file)
"Rebuild all the mail aliases from the given file."
(interactive (list
(let ((insert-default-directory t)
(default-directory (expand-file-name "~/"))
(def mail-personal-alias-file))
(read-file-name
(format "Read mail aliases from file: (default %s) " def)
default-directory
(expand-file-name def default-directory)
t))))
(if (null file)
(setq file buffer-file-name))
(setq mail-abbrevs nil)
(build-mail-abbrevs file))
(defun mail-abbrev-insert-alias (&optional alias)
"Prompt for and insert a mail alias."
(interactive (progn
(if (not (vectorp mail-abbrevs)) (mail-abbrevs-setup))
(list (completing-read "Expand alias: " mail-abbrevs nil t))))
(if (not (vectorp mail-abbrevs)) (mail-abbrevs-setup))
(insert (or (and alias (symbol-value (intern-soft alias mail-abbrevs))) ""))
(mail-abbrev-expand-hook))
(defun mail-abbrev-complete-alias ()
"Perform completion on alias preceding point."
(interactive)
(let* ((end (point))
(syntax-table (syntax-table))
(beg (unwind-protect
(save-excursion
(set-syntax-table mail-abbrev-syntax-table)
(backward-word 1)
(point))
(set-syntax-table syntax-table)))
(alias (buffer-substring beg end))
(completion (try-completion alias mail-abbrevs)))
(cond ((eq completion t)
(message "%s" alias)) ((null completion)
(error "[Can't complete \"%s\"]" alias)) ((not (string= completion alias))
(delete-region beg end)
(insert completion))
(t (with-output-to-temp-buffer "*Completions*"
(display-completion-list
(prog2
(message "Making completion list...")
(all-completions alias mail-abbrevs)
(message "Making completion list...done"))))))))
(defun mail-abbrev-next-line (&optional arg)
"Expand any mail abbrev, then move cursor vertically down ARG lines.
If there is no character in the target line exactly under the current column,
the cursor is positioned after the character in that line which spans this
column, or at the end of the line if it is not long enough.
If there is no line in the buffer after this one,
a newline character is inserted to create a line
and the cursor moves to that line.
The command \\[set-goal-column] can be used to create
a semipermanent goal column to which this command always moves.
Then it does not try to move vertically. This goal column is stored
in `goal-column', which is nil when there is none.
If you are thinking of using this in a Lisp program, consider
using `forward-line' instead. It is usually easier to use
and more reliable (no dependence on goal column, etc.)."
(interactive "p")
(if (looking-at "[ \t]*\n") (expand-abbrev))
(setq this-command 'next-line)
(next-line arg))
(defun mail-abbrev-end-of-buffer (&optional arg)
"Expand any mail abbrev, then move point to end of buffer.
Leave mark at previous position.
With arg N, put point N/10 of the way from the true end.
Don't use this command in Lisp programs!
\(goto-char (point-max)) is faster and avoids clobbering the mark."
(interactive "P")
(if (looking-at "[ \t]*\n") (expand-abbrev))
(setq this-command 'end-of-buffer)
(end-of-buffer arg))
(define-key mail-mode-map "\C-c\C-a" 'mail-abbrev-insert-alias)
(define-key mail-mode-map "\e\t" 'mail-abbrev-complete-alias)
(provide 'mailabbrev)
(if mail-abbrevs-mode
(mail-abbrevs-enable))