1 ;;; wl-complete.el --- Completion magic for Wanderlust
3 ;; Author: Masahiro MURATA <muse@ba2.so-net.ne.jp>
4 ;; Kazu Yamamoto <Kazu@Mew.org>
5 ;; Keywords: mail, net news
9 ;; Insert the following lines in your ~/.wl
11 ;; (require 'wl-addrbook)
12 ;; (wl-addrbook-setup)
14 ;; Original code: Kazu Yamamoto <Kazu@Mew.org>
15 ;; mew-complete.el (Mew developing team)
20 (require 'wl-addrbook)
22 (defvar wl-mail-domain-list nil)
23 (defvar wl-from-list nil)
25 (defvar wl-complete-lwsp "^[ \t]")
26 (defvar wl-complete-address-separator ":, \t\n")
28 (defvar wl-field-completion-switch
29 '(("To:" . wl-addrbook-complete-address)
30 ("Cc:" . wl-addrbook-complete-address)
31 ("Dcc:" . wl-addrbook-complete-address)
32 ("Bcc:" . wl-addrbook-complete-address)
33 ("Reply-To:" . wl-addrbook-complete-address)
34 ("Mail-Reply-To:" . wl-addrbook-complete-address)
35 ("Return-Receipt-To:" . wl-addrbook-complete-address)
36 ("Newsgroups:" . wl-complete-newsgroups)
37 ("Followup-To:" . wl-complete-newsgroups)
38 ("Fcc:" . wl-complete-folder)
40 "*Completion function alist concerned with the key.")
42 (defvar wl-field-circular-completion-switch
43 '(("To:" . wl-circular-complete-domain)
44 ("Cc:" . wl-circular-complete-domain)
45 ("Dcc:" . wl-circular-complete-domain)
46 ("Bcc:" . wl-circular-complete-domain)
47 ("Reply-To:" . wl-circular-complete-domain)
48 ("From:" . wl-circular-complete-from))
49 "*Circular completion function alist concerned with the key.")
51 (defvar wl-field-expansion-switch
52 '(("To:" . wl-addrbook-expand-address)
53 ("Cc:" . wl-addrbook-expand-address)
54 ("Dcc:" . wl-addrbook-expand-address)
55 ("Bcc:" . wl-addrbook-expand-address)
56 ("Reply-To:" . wl-addrbook-expand-address))
57 "*expansion function alist concerned with the key.")
61 (defun wl-string-match-assoc (key alist &optional case-ignore)
63 (case-fold-search case-ignore))
69 (string-match key (car a)))
71 (setq alist (cdr alist))))))
73 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
75 ;;; Low level functions
78 (defsubst wl-draft-on-header-p ()
81 (goto-char (point-min))
82 (search-forward (concat "\n" mail-header-separator "\n") nil 0)
85 (defun wl-draft-on-value-p (switch)
86 (if (wl-draft-on-header-p)
89 (while (and (< (point-min) (point)) (looking-at wl-complete-lwsp))
91 (if (looking-at "\\([^:]*:\\)")
92 (wl-string-match-assoc (wl-match-buffer 1) switch t)
93 nil)))) ;; what a case reachs here?
95 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
97 ;;; Completion function: C-i
100 (defun wl-draft-addrbook-header-comp-or-tab (force)
102 (let ((case-fold-search t)
104 (if (wl-draft-on-field-p)
107 (wl-draft-on-header-p)
108 (setq func (wl-draft-on-value-p wl-field-completion-switch)))
110 (indent-for-tab-command)))))
112 (defun wl-complete-newsgroups ()
114 (wl-complete-field-body wl-folder-newsgroups-hashtb))
115 ;;(wl-address-complete-address wl-folder-newsgroups-hashtb))
117 (defun wl-complete-folder ()
118 "Folder complete function for Fcc:."
120 (let ((word (wl-delete-backward-char)))
122 (wl-complete-window-show (list "+" "%"))
123 (wl-complete word wl-folder-entity-hashtb "folder" nil))))
125 (defun wl-addrbook-complete-address ()
126 "Complete and expand address aliases.
127 First alias key is completed. When completed solely or the @ character
128 is inserted before the cursor, the alias key is expanded to its value."
130 (let ((word (wl-delete-backward-char)))
133 (if (string-match "@." word)
134 (insert (or (wl-alias-next word) word))
136 word wl-addrbook-alist "alias" ?@ nil nil
137 (function wl-addrbook-alias-get)
138 (function wl-addrbook-alias-hit))))))
140 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
142 ;;; Circular completion: C-cC-i
145 (defun wl-draft-circular-comp ()
146 "Switch function for circular complete functions."
148 (let ((func (wl-draft-on-value-p wl-field-circular-completion-switch)))
151 (message "No circular completion here"))))
153 (defun wl-circular-complete-domain ()
154 "Circular completion of domains for To:, Cc:, etc.
155 If the @ character does not exist, the first value of
156 wl-mail-domain-list is inserted. If exists, the next value of
157 wl-mail-domain-list concerned with the string between @ and
158 the cursor is inserted."
160 (let ((word (wl-delete-backward-char "@")))
162 ((equal word nil) ;; @ doesn't exist.
163 (if (null wl-mail-domain-list)
164 (message "For domain circular completion, set wl-mail-domain-list")
166 (insert (car wl-mail-domain-list))
167 (wl-complete-window-delete)))
168 ((equal word t) ;; just after @
169 (if (null wl-mail-domain-list)
170 (message "For domain circular completion, set wl-mail-domain-list")
171 (insert (car wl-mail-domain-list))
172 (wl-complete-window-delete)))
174 ;; can't use wl-get-next since completion is necessary sometime.
177 (wl-slide-pair wl-mail-domain-list)
182 (defun wl-circular-complete (msg clist cname &optional here)
183 "General circular complete function to call wl-complete."
185 (let ((str (wl-delete-value here)))
189 (message "For circular completion, set %s" cname))
192 (wl-slide-pair clist)
196 (defun wl-circular-complete-from ()
197 "Circular complete function for From:."
199 (wl-circular-complete "from" wl-from-list "wl-from-list"))
201 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
203 ;;; Expansion : M-C-i
206 (defun wl-draft-addrbook-expand ()
207 "Switch function for expand functions."
209 (let ((func (wl-draft-on-value-p wl-field-expansion-switch)))
212 (message "No expansion here"))))
214 (defun wl-addrbook-expand-address ()
215 "Address expansion fuction for To:, Cc:, etc.
216 \"user@domain\" will be expands \"name <user@domain>\" if
219 (let ((word (wl-delete-backward-char)) name)
221 (message "No address here")
222 (setq name (wl-addrbook-name-get word))
224 (if name (format "%s <%s>" name word) word)))))
226 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
228 ;;; Hart function for completions
231 (defun-maybe characterp (form)
235 (fset 'wl-complete-hit (symbol-function 'assoc)))
237 (defun wl-complete-get (key alist)
238 (cdr (wl-complete-hit key alist)))
240 (defun wl-complete (WORD ALIST MSG EXPAND-CHAR &optional TRY ALL GET HIT)
241 (let* ((ftry (or TRY (function try-completion)))
242 (fall (or ALL (function all-completions)))
243 (fget (or GET (function wl-complete-get)))
244 (fhit (or HIT (function wl-complete-hit)))
245 (cmp (funcall ftry WORD ALIST))
246 (all (funcall fall WORD ALIST))
252 (if EXPAND-CHAR ;; may be "t"
253 (insert (funcall fget WORD ALIST)) ;; use cdr
254 (insert WORD)) ;; use car
255 (wl-complete-window-delete))
257 ((and (characterp EXPAND-CHAR)
258 (char-equal (aref WORD (1- len)) EXPAND-CHAR)
259 (setq subkey (substring WORD 0 (1- len)))
260 (funcall fhit subkey ALIST))
261 (insert (funcall fget subkey ALIST)) ;; use cdr
262 (wl-complete-window-delete))
263 ;; just one candidate
264 ((equal 1 (length all))
266 (wl-complete-window-delete)
267 (if (window-minibuffer-p (get-buffer-window (current-buffer)))
268 (wl-complete-temp-minibuffer-message " [Sole completion]")
269 (message "Sole completion")))
270 ;; two or more candidates
271 ((stringp cmp) ;; (length all) > 1
273 (wl-complete-window-show all)
274 (if (and EXPAND-CHAR (funcall fhit cmp ALIST))
276 (substitute-command-keys
277 "To expand %s, type %c then '\\<wl-draft-mode-map>\\[wl-draft-addrbook-header-comp-or-tab]'.")
282 (if (window-minibuffer-p (get-buffer-window (current-buffer)))
283 (wl-complete-temp-minibuffer-message (concat " No matching " MSG))
284 (message "No matching %s" MSG))))))
286 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
291 (defun wl-complete-temp-minibuffer-message (m)
292 (let ((savemax (point-max)))
294 (goto-char (point-max))
296 (let ((inhibit-quit t))
298 (delete-region savemax (point-max))
299 (if quit-flag (setq quit-flag nil unread-command-events 7)))))
302 ;; Extracting completion key
305 (defun wl-delete-backward-char (&optional here)
306 "Delete appropriate preceeding word and return it."
308 (let ((case-fold-search t)
311 (regex (concat "[^" wl-complete-address-separator "]")))
313 (while (and (not (bobp))
314 (string-match regex (buffer-substring-no-properties
315 (1- (point)) (point))))
317 (if (and here (not (re-search-forward (regexp-quote here) end t)))
318 nil ;; "here" doesn't exist.
321 (if here t nil) ;; just after "here", just after separator
323 (buffer-substring-no-properties start end)
324 (delete-region start end)))))))
326 (defun wl-delete-value (&optional here)
328 (if (not (looking-at "[^:]+:"))
330 (goto-char (match-end 0))
331 (if (looking-at "[ \t]")
336 (let ((start (point)) ret)
338 (if (and here (re-search-backward (regexp-quote here) start t))
340 (setq start (1+ (point)))
342 (setq ret (buffer-substring-no-properties start (point)))
343 (delete-region start (point))
350 (defun wl-slide-pair (x)
355 ((eq x 1) (cons first first))
358 (setq ret (cons (cons (nth 0 x) (nth 1 x)) ret))
360 (setq ret (cons (cons (car x) first) ret))
363 (provide 'wl-complete)
365 ;;; Copyright Notice:
367 ;; Copyright (C) 1997-2001 Mew developing team.
368 ;; Copyright (C) 2001 Masahiro Murata <muse@ba2.so-net.ne.jp>
369 ;; All rights reserved.
371 ;; Redistribution and use in source and binary forms, with or without
372 ;; modification, are permitted provided that the following conditions
375 ;; 1. Redistributions of source code must retain the above copyright
376 ;; notice, this list of conditions and the following disclaimer.
377 ;; 2. Redistributions in binary form must reproduce the above copyright
378 ;; notice, this list of conditions and the following disclaimer in the
379 ;; documentation and/or other materials provided with the distribution.
380 ;; 3. Neither the name of the team nor the names of its contributors
381 ;; may be used to endorse or promote products derived from this software
382 ;; without specific prior written permission.
384 ;; THIS SOFTWARE IS PROVIDED BY THE TEAM AND CONTRIBUTORS ``AS IS'' AND
385 ;; ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE
386 ;; IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
387 ;; PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE TEAM OR CONTRIBUTORS BE
388 ;; LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
389 ;; CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
390 ;; SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR
391 ;; BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY,
392 ;; WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE
393 ;; OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN
394 ;; IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
396 ;;; wl-complete.el ends here