utils/wl-complete.el

   1 ;;; wl-complete.el --- Completion magic for Wanderlust
   2
   3 ;; Author:  Masahiro MURATA <muse@ba2.so-net.ne.jp>
   4 ;;      Kazu Yamamoto <Kazu@Mew.org>
   5 ;; Keywords: mail, net news
   6
   7 ;;; Commentary:
   8
   9 ;;  Insert the following lines in your ~/.wl
  10 ;;
  11 ;; (require 'wl-addrbook)
  12 ;; (wl-addrbook-setup)
  13
  14 ;; Original code: Kazu Yamamoto <Kazu@Mew.org>
  15 ;;      mew-complete.el (Mew developing team)
  16
  17 ;;; Code:
  18
  19 (require 'wl-util)
  20 (require 'wl-addrbook)
  21
  22 (defvar wl-mail-domain-list nil)
  23 (defvar wl-from-list nil)
  24
  25 (defvar wl-complete-lwsp "^[ \t]")
  26 (defvar wl-complete-address-separator ":, \t\n")
  27
  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)
  39     )
  40   "*Completion function alist concerned with the key.")
  41
  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.")
  50
  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.")
  58
  59 ;;; Code:
  60
  61 (defun wl-string-match-assoc (key alist &optional case-ignore)
  62   (let (a
  63         (case-fold-search case-ignore))
  64     (catch 'loop
  65       (while alist
  66         (setq a (car alist))
  67         (if (and (consp a)
  68                  (stringp (car a))
  69                  (string-match key (car a)))
  70             (throw 'loop a))
  71         (setq alist (cdr alist))))))
  72
  73 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  74 ;;;
  75 ;;; Low level functions
  76 ;;;
  77
  78 (defsubst wl-draft-on-header-p ()
  79   (< (point)
  80      (save-excursion
  81        (goto-char (point-min))
  82        (search-forward (concat "\n" mail-header-separator "\n") nil 0)
  83        (point))))
  84
  85 (defun wl-draft-on-value-p (switch)
  86   (if (wl-draft-on-header-p)
  87       (save-excursion
  88         (beginning-of-line)
  89         (while (and (< (point-min) (point)) (looking-at wl-complete-lwsp))
  90           (forward-line -1))
  91         (if (looking-at "\\([^:]*:\\)")
  92             (wl-string-match-assoc (wl-match-buffer 1) switch t)
  93           nil)))) ;; what a case reachs here?
  94
  95 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  96 ;;;
  97 ;;; Completion function: C-i
  98 ;;;
  99
 100 (defun wl-draft-addrbook-header-comp-or-tab (force)
 101   (interactive "P")
 102   (let ((case-fold-search t)
 103         func)
 104     (if (wl-draft-on-field-p)
 105         (wl-complete-field)
 106       (if (and
 107            (wl-draft-on-header-p)
 108            (setq func (wl-draft-on-value-p wl-field-completion-switch)))
 109           (funcall (cdr func))
 110         (indent-for-tab-command)))))
 111
 112 (defun wl-complete-newsgroups ()
 113   (interactive)
 114   (wl-complete-field-body wl-folder-newsgroups-hashtb))
 115   ;;(wl-address-complete-address wl-folder-newsgroups-hashtb))
 116
 117 (defun wl-complete-folder ()
 118   "Folder complete function for Fcc:."
 119   (interactive)
 120   (let ((word (wl-delete-backward-char)))
 121     (if (null word)
 122         (wl-complete-window-show (list "+" "%"))
 123       (wl-complete word wl-folder-entity-hashtb "folder" nil))))
 124
 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."
 129   (interactive)
 130   (let ((word (wl-delete-backward-char)))
 131     (if (null word)
 132         (tab-to-tab-stop)
 133       (if (string-match "@." word)
 134           (insert (or (wl-alias-next word) word))
 135         (wl-complete
 136          word wl-addrbook-alist "alias" ?@ nil nil
 137          (function wl-addrbook-alias-get)
 138          (function wl-addrbook-alias-hit))))))
 139
 140 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 141 ;;;
 142 ;;; Circular completion: C-cC-i
 143 ;;;
 144
 145 (defun wl-draft-circular-comp ()
 146   "Switch function for circular complete functions."
 147   (interactive)
 148   (let ((func (wl-draft-on-value-p wl-field-circular-completion-switch)))
 149     (if func
 150         (funcall (cdr func))
 151       (message "No circular completion here"))))
 152
 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."
 159   (interactive)
 160   (let ((word (wl-delete-backward-char "@")))
 161     (cond
 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")
 165         (insert "@")
 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)))
 173      (t
 174       ;; can't use wl-get-next since completion is necessary sometime.
 175       (wl-complete
 176        word
 177        (wl-slide-pair wl-mail-domain-list)
 178        "domain"
 179        t)) ;; use cdr
 180      )))
 181
 182 (defun wl-circular-complete (msg clist cname &optional here)
 183   "General circular complete function to call wl-complete."
 184   (interactive)
 185   (let ((str (wl-delete-value here)))
 186     (if (null str)
 187         (if (car clist)
 188             (insert (car clist))
 189           (message "For circular completion, set %s" cname))
 190       (wl-complete
 191        str
 192        (wl-slide-pair clist)
 193        msg
 194        t)))) ;; use cdr
 195
 196 (defun wl-circular-complete-from ()
 197   "Circular complete function for From:."
 198   (interactive)
 199   (wl-circular-complete "from" wl-from-list "wl-from-list"))
 200
 201 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 202 ;;;
 203 ;;; Expansion : M-C-i
 204 ;;;
 205
 206 (defun wl-draft-addrbook-expand ()
 207   "Switch function for expand functions."
 208   (interactive)
 209   (let ((func (wl-draft-on-value-p wl-field-expansion-switch)))
 210     (if func
 211         (funcall (cdr func))
 212       (message "No expansion here"))))
 213
 214 (defun wl-addrbook-expand-address ()
 215   "Address expansion fuction for To:, Cc:, etc.
 216 \"user@domain\" will be expands \"name <user@domain>\" if
 217 the name exists."
 218   (interactive)
 219   (let ((word (wl-delete-backward-char)) name)
 220     (if (null word)
 221         (message "No address here")
 222       (setq name (wl-addrbook-name-get word))
 223       (insert
 224        (if name (format "%s <%s>" name word) word)))))
 225
 226 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 227 ;;;
 228 ;;; Hart function for completions
 229 ;;;
 230
 231 (defun-maybe characterp (form)
 232   (numberp form))
 233
 234 (eval-and-compile
 235   (fset 'wl-complete-hit (symbol-function 'assoc)))
 236
 237 (defun wl-complete-get (key alist)
 238   (cdr (wl-complete-hit key alist)))
 239
 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))
 247          (len (length WORD))
 248          subkey)
 249     (cond
 250      ;; already completed
 251      ((eq cmp t)
 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))
 256      ;; EXPAND
 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))
 265       (insert cmp)
 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
 272       (insert cmp)
 273       (wl-complete-window-show all)
 274       (if (and EXPAND-CHAR (funcall fhit cmp ALIST))
 275           (message
 276            (substitute-command-keys
 277             "To expand %s, type %c then '\\<wl-draft-mode-map>\\[wl-draft-addrbook-header-comp-or-tab]'.")
 278            cmp EXPAND-CHAR)))
 279      ;; no candidate
 280      (t
 281       (insert WORD)
 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))))))
 285
 286 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 287 ;;;
 288 ;;; Minibuf magic
 289 ;;;
 290
 291 (defun wl-complete-temp-minibuffer-message (m)
 292   (let ((savemax (point-max)))
 293     (save-excursion
 294       (goto-char (point-max))
 295       (insert m))
 296     (let ((inhibit-quit t))
 297       (sit-for 2)
 298       (delete-region savemax (point-max))
 299       (if quit-flag (setq quit-flag nil unread-command-events 7)))))
 300
 301 ;;
 302 ;; Extracting completion key
 303 ;;
 304
 305 (defun wl-delete-backward-char (&optional here)
 306   "Delete appropriate preceeding word and return it."
 307   (interactive)
 308   (let ((case-fold-search t)
 309         (start nil)
 310         (end (point))
 311         (regex (concat "[^" wl-complete-address-separator "]")))
 312     (save-excursion
 313       (while (and (not (bobp))
 314                   (string-match regex (buffer-substring-no-properties
 315                                        (1- (point)) (point))))
 316         (forward-char -1))
 317       (if (and here (not (re-search-forward (regexp-quote here) end t)))
 318           nil ;; "here" doesn't exist.
 319           (setq start (point))
 320           (if (= start end)
 321               (if here t nil) ;; just after "here",  just after separator
 322             (prog1
 323                 (buffer-substring-no-properties start end)
 324               (delete-region start end)))))))
 325
 326 (defun wl-delete-value (&optional here)
 327   (beginning-of-line)
 328   (if (not (looking-at "[^:]+:"))
 329       ()
 330     (goto-char (match-end 0))
 331     (if (looking-at "[ \t]")
 332         (forward-char 1)
 333       (insert " "))
 334     (if (eolp)
 335         nil
 336       (let ((start (point)) ret)
 337         (end-of-line)
 338         (if (and here (re-search-backward (regexp-quote here) start t))
 339             (progn
 340               (setq start (1+ (point)))
 341               (end-of-line)))
 342         (setq ret (buffer-substring-no-properties start (point)))
 343         (delete-region start (point))
 344         ret))))
 345
 346 ;;
 347 ;; Making alist
 348 ;;
 349
 350 (defun wl-slide-pair (x)
 351   (let ((ret nil)
 352         (first (car x)))
 353     (cond
 354      ((eq x 0) nil)
 355      ((eq x 1) (cons first first))
 356      (t
 357       (while (cdr x)
 358         (setq ret (cons (cons (nth 0 x) (nth 1 x)) ret))
 359         (setq x (cdr x)))
 360       (setq ret (cons (cons (car x) first) ret))
 361       (nreverse ret)))))
 362
 363 (provide 'wl-complete)
 364
 365 ;;; Copyright Notice:
 366
 367 ;; Copyright (C) 1997-2001 Mew developing team.
 368 ;; Copyright (C) 2001 Masahiro Murata <muse@ba2.so-net.ne.jp>
 369 ;; All rights reserved.
 370
 371 ;; Redistribution and use in source and binary forms, with or without
 372 ;; modification, are permitted provided that the following conditions
 373 ;; are met:
 374 ;;
 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.
 383 ;;
 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.
 395
 396 ;;; wl-complete.el ends here