Download Git
;;; message-x.el --- customizable completion in message headers
;; Copyright (C) 1998 Kai Großjohann
;; $Id: message-x.el,v 1.23 2001年05月30日 21:04:47 grossjoh Exp $
;; Author: Kai Grossjohann <grossjohann@ls6.informatik.uni-dortmund.de>
;; Keywords: news, mail, compose, completion
;; This file is not part of GNU Emacs.
;; This is free software; you can redistribute it and/or modify
;; it under the terms of the GNU General Public License as published by
;; the Free Software Foundation; either version 2, or (at your option)
;; any later version.
;; GNU Emacs 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 GNU Emacs; see the file COPYING. If not, write to the
;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
;; Boston, MA 02111-1307, USA.
;;; Commentary:
;; The most recent version of this can always be fetched from the
;; following FTP site:
;; ls6-ftp.cs.uni-dortmund.de:/pub/src/emacs
;; Installation:
;;
;; You must be using Gnus 5 or higher for this to work. Installation
;; is simple: just put this file somewhere in your load-path, run M-x
;; byte-compile-file RET, and put the following line in your .gnus file:
;;
;; (require 'message-x)
;;
;; Customization is possible through the two variables
;; message-x-body-function and message-x-completion-alist, which see.
;;
;; Purpose:
;;
;; This assigns a context-sensitive function to the TAB key in message
;; mode of Gnus. When in a header line, this performs completion
;; based on which header we're in (for example, newsgroup name
;; completion makes sense in the Newsgroups header whereas mail alias
;; expansion makes sense in the To and Cc headers). When in the
;; message body, this executes a different function, by default it is
;; indent-relative.
;;
;; To be more precise, the mechanism is as follows. When point is in
;; a known header (a header mentioned in
;; `message-x-completion-alist'), then the completion function thus
;; specified is executed. For the To and Cc headers, this could be
;; `bbdb-complete-name', for example. Then we look if the completion
;; function has done anything. If the completion function has NOT
;; done anything, then we invoke the function specified by
;; `message-x-unknown-header-function'.
;;
;; When point is in an unknown header (not mentioned in
;; `message-x-completion-alist'), then we invoke the function
;; specified by `message-x-unknown-header-function'. This function
;; could advance point to the next header, for example. (In fact,
;; that's the default behavior.)
;;
;; When point is not in a header (but in the body), then we invoke the
;; function specified by `message-x-body-function'. By default, this
;; is `indent-relative' -- the default indentation function for text
;; mode.
;;; Setup Code:
(defconst message-x-version "$Id: message-x.el,v 1.23 2001年05月30日 21:04:47 grossjoh Exp $"
"Version of message-x.")
(require 'message)
;;; User Customizable Variables:
(defgroup message-x nil
"Customizable completion in message headers.")
(defcustom message-x-body-function 'indent-relative
"message-x-tab executes this if point is in the body of a message."
:type '(function)
:group 'message-x)
(defcustom message-x-unknown-header-function 'message-position-point
"message-x-tab executes this if point is in an unknown header.
This function is also executed on known headers if the completion
function didn't find anything to do."
:type '(function)
:group 'message-x)
(defcustom message-x-completion-alist
'(("\\([rR]esent-\\|[rR]eply-\\)?[tT]o:\\|[bB]?[cC][cC]:" .
message-x-complete-name)
((if (boundp 'message-newgroups-header-regexp)
message-newgroups-header-regexp
message-newsgroups-header-regexp) . message-expand-group))
"Table telling which completion function `message-x-tab' should invoke.
Table is a list of pairs (GROUP . FUNC). GROUP is evaled to produce a
regexp specifying the header names. See `mail-abbrev-in-expansion-header-p'
for details on the regexp. If point is in that header, FUNC is invoked
via `message-x-call-completion-function'."
:type '(repeat (cons string function))
:group 'message-x)
(defcustom message-x-before-completion-functions nil
"`message-x-tab' runs these functions before doing the actual
completion. The functions are called with one argument, a string
specifying the current header name in lower case or nil, which
specifies the message body. Also see `message-x-after-completion-hook'."
:type 'hook
:group 'message-x)
(defcustom message-x-after-completion-functions nil
"`message-x-tab' runs these functions after doing the actual
completion. The functions are called with one argument, a string
specifying the current header name in lower case or nil, which
specifies the message body. Also see `message-x-before-completion-hook'."
:type 'hook
:group 'message-x)
;;; Internal variables:
(defvar message-x-displayed-completion-buffer-flag nil
"Set to `t' from `completion-setup-hook'.
`message-x-call-completion-function' uses this to see if the
completion function has set up the *Completions* buffer.")
;;; Code:
(defun message-x-in-header-p ()
"Returns t iff point is in the header section."
(save-excursion
(let ((p (point)))
(goto-char (point-min))
(and (re-search-forward (concat "^"
(regexp-quote mail-header-separator)
"$")
nil t)
(progn (beginning-of-line) t)
(< p (point))))))
(defun message-x-which-header ()
"Returns the header we're currently in. Returns nil if not in a header.
Example: returns \"to\" if we're in the \"to\" header right now."
(and (message-x-in-header-p)
(save-excursion
(beginning-of-line)
(while (looking-at "^[ \t]+") (forward-line -1))
(looking-at "\\([^:]+\\):")
(downcase (buffer-substring-no-properties (match-beginning 1)
(match-end 1))))))
(defun message-x-complete-name ()
"Does name completion in recipient headers."
(interactive)
(unless (when abbrev-mode
(message-x-call-completion-function 'expand-abbrev))
(cond ((and (boundp 'eudc-server) eudc-server
(boundp 'eudc-protocol) eudc-protocol)
(condition-case nil
(eudc-expand-inline)
(error nil)))
((and (boundp 'bbdb-hashtable) (fboundp 'bbdb-complete-name))
(let ((bbdb-complete-name-hooks nil))
(bbdb-complete-name))))))
(defun message-x-set-displayed-completion-buffer-flag ()
"Set `message-x-displayed-completion-buffer-flag' to t."
(setq message-x-displayed-completion-buffer-flag t))
(add-hook 'completion-setup-hook
'message-x-set-displayed-completion-buffer-flag)
(defun message-x-call-completion-function (func)
"Calls the given completion function, then checks if completion was done.
When doing completion, the following cases are possible:
- The current prefix was complete.
- Some string was inserted.
- A list of possible completions was displayed or updated.
In the first case, the completion function has not done anything, and
so `message-x-call-completion-function' returns nil. In all other
cases, `message-x-call-completion-function' returns non-nil."
(let* ((message-x-displayed-completion-buffer-flag nil)
(cbuf (get-buffer-create "*Completions*"))
(cbufcontents (save-excursion
(set-buffer cbuf)
(buffer-string)))
(cwin (get-buffer-window cbuf))
(thisline (buffer-substring
(save-excursion
(beginning-of-line)
(point))
(point)))
(cws (window-start cwin)))
(funcall func)
(cond ((not (string= thisline
(buffer-substring
(save-excursion
(beginning-of-line)
(point))
(point))))
t)
(message-x-displayed-completion-buffer-flag
(cond ((not (equal cwin (get-buffer-window cbuf)))
t)
((not (string= cbufcontents
(save-excursion
(set-buffer cbuf)
(buffer-string))))
t)
((/= cws (window-start (get-buffer-window cbuf)))
t)
(t nil))))))
;;;###autoload
(defun message-x-tab (&optional skip-completion)
"Smart completion or indentation in message buffers.
Looks at the position of point to decide what to do. If point is in
one of the headers specified by `message-x-completion-alist', then the
completion function specified there is executed. If point is in
another header (not mentioned there), then the function specified by
`message-x-unknown-header-function' is executed. If point is in the
body, the function specified by `message-x-body-function' is executed.
Completion is magic: after the completion function is executed, checks
are performed to see if the completion function has actually done
something. If it has not done anything,
`message-x-unknown-header-function' is executed. See the function
`message-x-call-completion-function' for details on how to check
whether the completion function has done something.
A non-nil optional arg SKIP-COMPLETION (prefix arg if invoked
interactively) means to not attempt completion. Instead,
`message-x-unknown-header-function' function is called in all headers,
known or unknown."
(interactive "P")
(let* ((alist message-x-completion-alist)
(which-header (message-x-which-header))
header)
(run-hook-with-args 'message-x-before-completion-functions which-header)
(while (and (not skip-completion)
alist
(let ((mail-abbrev-mode-regexp (eval (caar alist))))
(not (mail-abbrev-in-expansion-header-p))))
(setq alist (cdr alist)))
(cond ((and alist (not skip-completion))
(let ((p (point))
(func (cdar alist)))
(unless (message-x-call-completion-function func)
(funcall message-x-unknown-header-function))))
((message-x-in-header-p)
(funcall message-x-unknown-header-function))
(t
(funcall message-x-body-function)))
(run-hook-with-args 'message-x-after-completion-functions which-header)))
(define-key message-mode-map "\t" 'message-x-tab)
(provide 'message-x)
;;; message-x.el ends here