Ship more local files
[emacs.git] / .emacs.d / elisp / local / message-x.el
1 ;;; message-x.el --- customizable completion in message headers
2 ;; Copyright (C) 1998 Kai Gro├čjohann
3
4 ;; $Id: message-x.el,v 1.23 2001/05/30 21:04:47 grossjoh Exp $
5
6 ;; Author: Kai Grossjohann <grossjohann@ls6.informatik.uni-dortmund.de>
7 ;; Keywords: news, mail, compose, completion
8
9 ;; This file is not part of GNU Emacs.
10
11 ;; This is free software; you can redistribute it and/or modify
12 ;; it under the terms of the GNU General Public License as published by
13 ;; the Free Software Foundation; either version 2, or (at your option)
14 ;; any later version.
15
16 ;; GNU Emacs is distributed in the hope that it will be useful,
17 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
18 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
19 ;; GNU General Public License for more details.
20
21 ;; You should have received a copy of the GNU General Public License
22 ;; along with GNU Emacs; see the file COPYING. If not, write to the
23 ;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
24 ;; Boston, MA 02111-1307, USA.
25
26 ;;; Commentary:
27
28 ;; The most recent version of this can always be fetched from the
29 ;; following FTP site:
30 ;; ls6-ftp.cs.uni-dortmund.de:/pub/src/emacs
31
32 ;; Installation:
33 ;;
34 ;; You must be using Gnus 5 or higher for this to work. Installation
35 ;; is simple: just put this file somewhere in your load-path, run M-x
36 ;; byte-compile-file RET, and put the following line in your .gnus file:
37 ;;
38 ;; (require 'message-x)
39 ;;
40 ;; Customization is possible through the two variables
41 ;; message-x-body-function and message-x-completion-alist, which see.
42 ;;
43 ;; Purpose:
44 ;;
45 ;; This assigns a context-sensitive function to the TAB key in message
46 ;; mode of Gnus. When in a header line, this performs completion
47 ;; based on which header we're in (for example, newsgroup name
48 ;; completion makes sense in the Newsgroups header whereas mail alias
49 ;; expansion makes sense in the To and Cc headers). When in the
50 ;; message body, this executes a different function, by default it is
51 ;; indent-relative.
52 ;;
53 ;; To be more precise, the mechanism is as follows. When point is in
54 ;; a known header (a header mentioned in
55 ;; `message-x-completion-alist'), then the completion function thus
56 ;; specified is executed. For the To and Cc headers, this could be
57 ;; `bbdb-complete-name', for example. Then we look if the completion
58 ;; function has done anything. If the completion function has NOT
59 ;; done anything, then we invoke the function specified by
60 ;; `message-x-unknown-header-function'.
61 ;;
62 ;; When point is in an unknown header (not mentioned in
63 ;; `message-x-completion-alist'), then we invoke the function
64 ;; specified by `message-x-unknown-header-function'. This function
65 ;; could advance point to the next header, for example. (In fact,
66 ;; that's the default behavior.)
67 ;;
68 ;; When point is not in a header (but in the body), then we invoke the
69 ;; function specified by `message-x-body-function'. By default, this
70 ;; is `indent-relative' -- the default indentation function for text
71 ;; mode.
72
73 ;;; Setup Code:
74
75 (defconst message-x-version "$Id: message-x.el,v 1.23 2001/05/30 21:04:47 grossjoh Exp $"
76 "Version of message-x.")
77
78 (require 'message)
79
80 ;;; User Customizable Variables:
81
82 (defgroup message-x nil
83 "Customizable completion in message headers.")
84
85 (defcustom message-x-body-function 'indent-relative
86 "message-x-tab executes this if point is in the body of a message."
87 :type '(function)
88 :group 'message-x)
89
90 (defcustom message-x-unknown-header-function 'message-position-point
91 "message-x-tab executes this if point is in an unknown header.
92 This function is also executed on known headers if the completion
93 function didn't find anything to do."
94 :type '(function)
95 :group 'message-x)
96
97 (defcustom message-x-completion-alist
98 '(("\\([rR]esent-\\|[rR]eply-\\)?[tT]o:\\|[bB]?[cC][cC]:" .
99 message-x-complete-name)
100 ((if (boundp 'message-newgroups-header-regexp)
101 message-newgroups-header-regexp
102 message-newsgroups-header-regexp) . message-expand-group))
103 "Table telling which completion function `message-x-tab' should invoke.
104 Table is a list of pairs (GROUP . FUNC). GROUP is evaled to produce a
105 regexp specifying the header names. See `mail-abbrev-in-expansion-header-p'
106 for details on the regexp. If point is in that header, FUNC is invoked
107 via `message-x-call-completion-function'."
108 :type '(repeat (cons string function))
109 :group 'message-x)
110
111 (defcustom message-x-before-completion-functions nil
112 "`message-x-tab' runs these functions before doing the actual
113 completion. The functions are called with one argument, a string
114 specifying the current header name in lower case or nil, which
115 specifies the message body. Also see `message-x-after-completion-hook'."
116 :type 'hook
117 :group 'message-x)
118
119 (defcustom message-x-after-completion-functions nil
120 "`message-x-tab' runs these functions after doing the actual
121 completion. The functions are called with one argument, a string
122 specifying the current header name in lower case or nil, which
123 specifies the message body. Also see `message-x-before-completion-hook'."
124 :type 'hook
125 :group 'message-x)
126
127 ;;; Internal variables:
128
129 (defvar message-x-displayed-completion-buffer-flag nil
130 "Set to `t' from `completion-setup-hook'.
131 `message-x-call-completion-function' uses this to see if the
132 completion function has set up the *Completions* buffer.")
133
134 ;;; Code:
135
136 (defun message-x-in-header-p ()
137 "Returns t iff point is in the header section."
138 (save-excursion
139 (let ((p (point)))
140 (goto-char (point-min))
141 (and (re-search-forward (concat "^"
142 (regexp-quote mail-header-separator)
143 "$")
144 nil t)
145 (progn (beginning-of-line) t)
146 (< p (point))))))
147
148 (defun message-x-which-header ()
149 "Returns the header we're currently in. Returns nil if not in a header.
150 Example: returns \"to\" if we're in the \"to\" header right now."
151 (and (message-x-in-header-p)
152 (save-excursion
153 (beginning-of-line)
154 (while (looking-at "^[ \t]+") (forward-line -1))
155 (looking-at "\\([^:]+\\):")
156 (downcase (buffer-substring-no-properties (match-beginning 1)
157 (match-end 1))))))
158
159 (defun message-x-complete-name ()
160 "Does name completion in recipient headers."
161 (interactive)
162 (unless (when abbrev-mode
163 (message-x-call-completion-function 'expand-abbrev))
164 (cond ((and (boundp 'eudc-server) eudc-server
165 (boundp 'eudc-protocol) eudc-protocol)
166 (condition-case nil
167 (eudc-expand-inline)
168 (error nil)))
169 ((and (boundp 'bbdb-hashtable) (fboundp 'bbdb-complete-name))
170 (let ((bbdb-complete-name-hooks nil))
171 (bbdb-complete-name))))))
172
173 (defun message-x-set-displayed-completion-buffer-flag ()
174 "Set `message-x-displayed-completion-buffer-flag' to t."
175 (setq message-x-displayed-completion-buffer-flag t))
176 (add-hook 'completion-setup-hook
177 'message-x-set-displayed-completion-buffer-flag)
178
179 (defun message-x-call-completion-function (func)
180 "Calls the given completion function, then checks if completion was done.
181 When doing completion, the following cases are possible:
182 - The current prefix was complete.
183 - Some string was inserted.
184 - A list of possible completions was displayed or updated.
185 In the first case, the completion function has not done anything, and
186 so `message-x-call-completion-function' returns nil. In all other
187 cases, `message-x-call-completion-function' returns non-nil."
188 (let* ((message-x-displayed-completion-buffer-flag nil)
189 (cbuf (get-buffer-create "*Completions*"))
190 (cbufcontents (save-excursion
191 (set-buffer cbuf)
192 (buffer-string)))
193 (cwin (get-buffer-window cbuf))
194 (thisline (buffer-substring
195 (save-excursion
196 (beginning-of-line)
197 (point))
198 (point)))
199 (cws (window-start cwin)))
200 (funcall func)
201 (cond ((not (string= thisline
202 (buffer-substring
203 (save-excursion
204 (beginning-of-line)
205 (point))
206 (point))))
207 t)
208 (message-x-displayed-completion-buffer-flag
209 (cond ((not (equal cwin (get-buffer-window cbuf)))
210 t)
211 ((not (string= cbufcontents
212 (save-excursion
213 (set-buffer cbuf)
214 (buffer-string))))
215 t)
216 ((/= cws (window-start (get-buffer-window cbuf)))
217 t)
218 (t nil))))))
219
220 ;;;###autoload
221 (defun message-x-tab (&optional skip-completion)
222 "Smart completion or indentation in message buffers.
223
224 Looks at the position of point to decide what to do. If point is in
225 one of the headers specified by `message-x-completion-alist', then the
226 completion function specified there is executed. If point is in
227 another header (not mentioned there), then the function specified by
228 `message-x-unknown-header-function' is executed. If point is in the
229 body, the function specified by `message-x-body-function' is executed.
230
231 Completion is magic: after the completion function is executed, checks
232 are performed to see if the completion function has actually done
233 something. If it has not done anything,
234 `message-x-unknown-header-function' is executed. See the function
235 `message-x-call-completion-function' for details on how to check
236 whether the completion function has done something.
237
238 A non-nil optional arg SKIP-COMPLETION (prefix arg if invoked
239 interactively) means to not attempt completion. Instead,
240 `message-x-unknown-header-function' function is called in all headers,
241 known or unknown."
242 (interactive "P")
243 (let* ((alist message-x-completion-alist)
244 (which-header (message-x-which-header))
245 header)
246 (run-hook-with-args 'message-x-before-completion-functions which-header)
247 (while (and (not skip-completion)
248 alist
249 (let ((mail-abbrev-mode-regexp (eval (caar alist))))
250 (not (mail-abbrev-in-expansion-header-p))))
251 (setq alist (cdr alist)))
252 (cond ((and alist (not skip-completion))
253 (let ((p (point))
254 (func (cdar alist)))
255 (unless (message-x-call-completion-function func)
256 (funcall message-x-unknown-header-function))))
257 ((message-x-in-header-p)
258 (funcall message-x-unknown-header-function))
259 (t
260 (funcall message-x-body-function)))
261 (run-hook-with-args 'message-x-after-completion-functions which-header)))
262
263 (define-key message-mode-map "\t" 'message-x-tab)
264
265 (provide 'message-x)
266 ;;; message-x.el ends here