cgit.sxemacs.org Git - packages/blob - xemacs-packages/mew/mew/mew-complete.el

   1 ;;; mew-complete.el --- Completion magic for Mew
   2
   3 ;; Author:  Kazu Yamamoto <Kazu@Mew.org>
   4 ;; Created: May 30, 1997
   5 ;; Revised: Aug 30, 1999
   6
   7 ;;; Code:
   8
   9 (defconst mew-complete-version "mew-complete.el version 0.04")
  10
  11 (require 'mew)
  12
  13 ;; hoping the functions here are free from marker problem
  14 ;; because it inserts any chars before \n. It is important
  15 ;; to use the position's color.
  16 (fset 'mew-complete-insert (symbol-function 'insert))
  17
  18 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  19 ;;;
  20 ;;; Low level functions
  21 ;;;
  22
  23 (defun mew-draft-on-field-p ()
  24   (if (bolp)
  25       (if (bobp)
  26           t
  27         (save-excursion
  28           (forward-line -1)
  29           (if (looking-at ".*,[ \t]?$") nil t)))
  30     (let ((pos (point)))
  31       (save-excursion
  32         (beginning-of-line)
  33         (if (looking-at mew-lwsp)
  34             nil
  35           (if (search-forward ":" pos t) nil t))))))
  36
  37 (defun mew-draft-on-value-p (switch)
  38   (save-excursion
  39     (beginning-of-line)
  40     (while (and (< (point-min) (point)) (looking-at mew-lwsp))
  41       (forward-line -1))
  42     (if (looking-at "\\([^:]*:\\)")
  43         (mew-assoc-match (mew-match 1) switch 0)
  44       nil))) ;; what a case reachs here?
  45
  46 ;;
  47 ;; Window management for completion candidates
  48 ;;
  49
  50 (defvar mew-complete-candidates nil)
  51
  52 (defun mew-complete-window-delete ()
  53   (if (null mew-complete-window-config)
  54       ()
  55     ;; mew-complete-window-config remains when the last completion
  56     ;; finished with multiple candidates.
  57     ;; (e.g. foo<RET> when foo and foobar are displayed.)
  58     ;; In this case, this function is called in another
  59     ;; completion thread but setting window configuration is not
  60     ;; desired. If we set window configuration with the old
  61     ;; mew-complete-window-config, the cursor jumps to mini buffer.
  62     ;; This was a stupid bug of Mew. So, let's see if the complete
  63     ;; buffer is displayed or not.
  64     (if (get-buffer-window mew-buffer-completions)
  65         (set-window-configuration mew-complete-window-config))
  66     (setq mew-complete-window-config nil))
  67   (and (get-buffer mew-buffer-completions)
  68        (kill-buffer mew-buffer-completions))
  69   (setq mew-complete-candidates nil))
  70
  71 (defun mew-complete-window-show (all)
  72   (or mew-complete-window-config
  73       (setq mew-complete-window-config (current-window-configuration)))
  74   (if (and (get-buffer-window mew-buffer-completions)
  75            (equal mew-complete-candidates all))
  76       (let ((win (get-buffer-window mew-buffer-completions)))
  77         (save-excursion
  78           (set-buffer mew-buffer-completions)
  79           (if (pos-visible-in-window-p (point-max) win)
  80               (set-window-start win 1)
  81             (scroll-other-window))))
  82     (setq mew-complete-candidates all)
  83     (with-output-to-temp-buffer
  84         mew-buffer-completions
  85       (display-completion-list all))))
  86
  87 (defun mew-complete-backscroll ()
  88   "Backscroll the *Completion* buffer."
  89   (interactive)
  90   (let* ((win (get-buffer-window mew-buffer-completions))
  91          (height (and win (window-height win))))
  92     (and win (scroll-other-window (- 3 height)))))
  93
  94 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  95 ;;;
  96 ;;; Completion function: C-i
  97 ;;;
  98
  99 (defun mew-draft-header-comp ()
 100   "Complete and expand address short names.
 101 First, a short name is completed. When completed solely or the @ character
 102 is inserted before the cursor, the short name is expanded to its address."
 103   (interactive)
 104   (if (mew-draft-on-field-p)
 105       (mew-complete-field)
 106     (let ((func (mew-draft-on-value-p mew-field-completion-switch)))
 107       (if func
 108           (funcall (cdr func))
 109         (tab-to-tab-stop))))) ;; default keybinding
 110
 111 (defun mew-complete-field ()
 112   "Field complete function."
 113   (interactive)
 114   (let ((word (mew-delete-key))) ;; capitalized
 115     (if (null word)
 116         (mew-complete-window-show mew-fields)
 117       (mew-complete
 118        word
 119        (mapcar (function (lambda (x) (list (concat (capitalize x) " "))))
 120                mew-fields)
 121        "field"
 122        nil))))
 123
 124 (defun mew-complete-folder ()
 125   "Folder complete function for Fcc:."
 126   (interactive)
 127   (let ((word (mew-delete-backward-char)))
 128     (if (null word)
 129         (if mew-use-imap
 130             (mew-complete-window-show (list "+" "=" "%"))
 131           (mew-complete-window-show (list "+" "=")))
 132       (mew-complete word mew-folder-alist "folder" nil))))
 133
 134 (defun mew-complete-address ()
 135   "Complete and expand an address short name.
 136 First alias key is completed. When completed solely or the @ character
 137 is inserted before the cursor, the short name is expanded to its address."
 138   (interactive)
 139   (let ((word (mew-delete-backward-char)))
 140     (if (null word)
 141         (tab-to-tab-stop)
 142       (if (string-match "@." word)
 143           (mew-complete-insert (or (mew-alias-next word) word))
 144         (mew-complete
 145          word mew-addrbook-alist "alias" ?@ nil nil
 146          (function mew-addrbook-alias-get)
 147          (function mew-addrbook-alias-hit))))))
 148
 149 (defun mew-complete-config ()
 150   "Complete function for Config:."
 151   (interactive)
 152   (let ((word (or (mew-delete-value ",") "")))
 153     (mew-complete
 154      word
 155      (mew-slide-pair mew-config-list)
 156      "mew-config-list"
 157      nil)))
 158
 159 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 160 ;;;
 161 ;;; Circular completion: C-cC-i
 162 ;;;
 163
 164 (defun mew-draft-circular-comp ()
 165   "Switch function for circular complete functions."
 166   (interactive)
 167   (let ((func (mew-draft-on-value-p mew-field-circular-completion-switch)))
 168     (if func
 169         (funcall (cdr func))
 170       (message "No circular completion here"))))
 171
 172 (defun mew-circular-complete-domain ()
 173   "Circular completion of domains for To:, Cc:, etc.
 174 If the @ character does not exist, the first value of
 175 mew-mail-domain-list is inserted. If exists, the next value of
 176 mew-mail-domain-list concerned with the string between @ and
 177 the cursor is inserted."
 178   (interactive)
 179   (let ((word (mew-delete-backward-char "@"))
 180         (completion-ignore-case t))
 181     (cond
 182      ((equal word nil) ;; @ doesn't exist.
 183       (if (null mew-mail-domain-list)
 184           (message "For domain circular completion, set mew-mail-domain-list")
 185         (mew-complete-insert "@")
 186         (mew-complete-insert (car mew-mail-domain-list))
 187         (mew-complete-window-delete)))
 188      ((equal word t) ;; just after @
 189       (if (null mew-mail-domain-list)
 190           (message "For domain circular completion, set mew-mail-domain-list")
 191         (mew-complete-insert (car mew-mail-domain-list))
 192         (mew-complete-window-delete)))
 193      (t
 194       ;; can't use mew-get-next since completion is necessary sometime.
 195       (mew-complete
 196        word
 197        (mew-slide-pair mew-mail-domain-list)
 198        "domain"
 199        t)) ;; use cdr
 200      )))
 201
 202 (defun mew-circular-complete (msg clist cname &optional here)
 203   "General circular complete function to call mew-complete."
 204   (interactive)
 205   (let ((str (mew-delete-value here)))
 206     (if (null str)
 207         (if (car clist)
 208             (mew-complete-insert (car clist))
 209           (message "For circular completion, set %s" cname))
 210       (mew-complete
 211        str
 212        (mew-slide-pair clist)
 213        msg
 214        t)))) ;; use cdr
 215
 216 (defun mew-circular-complete-from ()
 217   "Circular complete function for From:."
 218   (interactive)
 219   (mew-circular-complete "from" mew-from-list "mew-from-list"))
 220
 221 (defun mew-circular-complete-config ()
 222   "Circular complete function for Config:."
 223   (interactive)
 224   (mew-circular-complete "config" mew-config-list "mew-config-list" ","))
 225
 226 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 227 ;;;
 228 ;;; Expansion : M-C-i
 229 ;;;
 230
 231 (defun mew-draft-expand ()
 232   "Switch function for expand functions."
 233   (interactive)
 234   (let ((func (mew-draft-on-value-p mew-field-expansion-switch)))
 235     (if func
 236         (funcall (cdr func))
 237       (message "No expansion here"))))
 238
 239 (defun mew-expand-address ()
 240   "Address expansion function for To:, Cc:, etc.
 241 'user@domain' will be expands 'name <user@domain>' if
 242 the name exists."
 243   (interactive)
 244   (let ((word (mew-delete-backward-char)) func name)
 245     (if (null word)
 246         (message "No address here")
 247       (setq func (mew-addrbook-func mew-addrbook-for-address-expansion))
 248       (if (null func)
 249           (mew-complete-insert word)
 250         (setq name (funcall func word))
 251         (mew-complete-insert (if name (format "%s <%s>" name word) word))))))
 252
 253 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 254 ;;;
 255 ;;; Other completion stuff
 256 ;;;
 257
 258 ;; dummy
 259 (defvar mew-ext-host "")
 260 (defvar mew-ext-user "")
 261
 262 (defun mew-complete-rfile ()
 263   "Complete a remote file."
 264   (interactive)
 265   (let* ((path-file (mew-delete-file))
 266          (path (car path-file))
 267          (file (cdr path-file))
 268          rpath)
 269     (setq rpath (format "/%s@%s:%s" mew-ext-user mew-ext-host path))
 270     (mew-complete
 271      file
 272      rpath
 273      "remote file"
 274      nil
 275      (function mew-ext-file-name-completion)
 276      (function mew-ext-file-name-all-completions))))
 277
 278 (defun mew-complete-pick-pattern ()
 279   "Complete pick patterns."
 280   (interactive)
 281   (let* ((pat (mew-delete-pattern))
 282          (clist (append '("(" "!")
 283                         mew-pick-field-list
 284                         (mapcar (function car) mew-pick-macro-alist))))
 285     (if (null pat)
 286         (mew-complete-window-show clist)
 287       (mew-complete
 288        pat
 289        (mapcar (function list) clist)
 290        "pick pattern"
 291        nil))))
 292
 293 (defun mew-complete-sort-key ()
 294   "Complete sort keys."
 295   (interactive)
 296   (let* ((word (mew-delete-line))
 297          field alist)
 298     (if (string-match ":" word)
 299         (progn
 300           ;; If WORD contains ':', change alist for completion.
 301           (setq field (car (mew-split word ?:)))
 302           (setq alist
 303                 (mapcar (function (lambda (str) (list (concat field ":" str))))
 304                         mew-sort-modes)))
 305       ;; Otherwise, alist is mew-sort-key-alist itself.
 306       (setq alist mew-sort-key-alist))
 307     (mew-complete word alist "sort key" nil)))
 308
 309 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 310 ;;;
 311 ;;; Hart function for completions
 312 ;;;
 313
 314 (fset 'mew-complete-hit (symbol-function 'assoc))
 315
 316 (defun mew-complete-get (key alist)
 317   (cdr (mew-complete-hit key alist)))
 318
 319 (defun mew-complete (WORD ALIST MSG EXPAND-CHAR &optional TRY ALL GET HIT)
 320   (let* ((ftry (or TRY (function try-completion)))
 321          (fall (or ALL (function all-completions)))
 322          (fget (or GET (function mew-complete-get)))
 323          (fhit (or HIT (function mew-complete-hit)))
 324          (cmp (funcall ftry WORD ALIST))
 325          (all (funcall fall WORD ALIST))
 326          (len (length WORD))
 327          subkey)
 328     (cond
 329      ;; already completed
 330      ((eq cmp t)
 331       (if EXPAND-CHAR ;; may be "t"
 332           (mew-complete-insert (funcall fget WORD ALIST)) ;; use cdr
 333         (mew-complete-insert WORD)) ;; use car
 334       (mew-complete-window-delete))
 335      ;; EXPAND
 336      ((and (mew-characterp EXPAND-CHAR)
 337            (char-equal (aref WORD (1- len)) EXPAND-CHAR)
 338            (setq subkey (substring WORD 0 (1- len)))
 339            (funcall fhit subkey ALIST))
 340       (mew-complete-insert (funcall fget subkey ALIST)) ;; use cdr
 341       (mew-complete-window-delete))
 342      ;; just one candidate
 343      ((equal 1 (length all))
 344       (mew-complete-insert cmp)
 345       (mew-complete-window-delete)
 346       (if (window-minibuffer-p (get-buffer-window (current-buffer)))
 347           (mew-temp-minibuffer-message " [Sole completion]")
 348         (message "Sole completion")))
 349      ;; two or more candidates
 350      ((stringp cmp) ;; (length all) > 1
 351       (mew-complete-insert cmp)
 352       (mew-complete-window-show all)
 353       (if (and EXPAND-CHAR (funcall fhit cmp ALIST))
 354           (message
 355            (substitute-command-keys
 356             "To expand '%s', type '%c' then '\\<mew-draft-header-map>\\[mew-draft-header-comp]'.")
 357            cmp EXPAND-CHAR)))
 358      ;; no candidate
 359      (t
 360       (mew-complete-insert WORD)
 361       ;;(mew-complete-window-delete)
 362       (if (window-minibuffer-p (get-buffer-window (current-buffer)))
 363           (mew-temp-minibuffer-message (concat " No matching " MSG))
 364         (message "No matching %s" MSG))))))
 365
 366 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 367 ;;;
 368 ;;; Minibuf magic
 369 ;;;
 370
 371 (defun mew-temp-minibuffer-message (m)
 372   (let ((savemax (point-max)))
 373     (save-excursion
 374       (goto-char (point-max))
 375       (mew-complete-insert m))
 376     (let ((inhibit-quit t))
 377       (sit-for 2)
 378       (delete-region savemax (point-max))
 379       (if quit-flag (setq quit-flag nil unread-command-events 7)))))
 380
 381 ;;
 382 ;; Extracting completion key
 383 ;;
 384
 385 (defun mew-delete-backward-char (&optional here)
 386   "Delete appropriate preceding word and return it."
 387   (interactive)
 388   (let ((case-fold-search t)
 389         (start nil)
 390         (end (point))
 391         (regex (concat "[^" mew-address-separator "]")))
 392     (save-excursion
 393       (while (and (not (bobp))
 394                   (string-match regex (mew-buffer-substring
 395                                        (1- (point)) (point))))
 396         (forward-char -1))
 397       (if (and here (not (re-search-forward (regexp-quote here) end t)))
 398           nil ;; "here" doesn't exist.
 399           (setq start (point))
 400           (if (= start end)
 401               (if here t nil) ;; just after "here",  just after separator
 402             (prog1
 403                 (mew-buffer-substring start end)
 404               (delete-region start end)))))))
 405
 406 (defun mew-delete-file ()
 407   (if (search-backward mew-path-separator nil t)
 408       (forward-char 1)
 409     (beginning-of-line))
 410   (prog1
 411       (cons (mew-buffer-substring (point-min) (point))
 412             (mew-buffer-substring (point) (point-max)))
 413     (delete-region (point) (point-max))))
 414
 415 (defun mew-delete-pattern ()
 416   (let ((pos (point)))
 417     (if (re-search-backward " \\|(\\|&\\||\\|!" nil t)
 418         (forward-char 1)
 419       (beginning-of-line))
 420     (prog1
 421         (mew-buffer-substring (point) pos)
 422       (delete-region (point) pos))))
 423
 424 (defun mew-delete-line ()
 425   (let ((pos (point)))
 426     (beginning-of-line)
 427     (prog1
 428         (mew-buffer-substring (point) pos)
 429       (delete-region (point) pos))))
 430
 431 (defun mew-delete-key ()
 432   (let ((pos (point)))
 433     (beginning-of-line)
 434     (prog1
 435         (capitalize (mew-buffer-substring (point) pos))
 436       (delete-region (point) pos))))
 437
 438 (defun mew-delete-value (&optional here)
 439   (beginning-of-line)
 440   (if (not (looking-at "[^:]+:"))
 441       ()
 442     (goto-char (match-end 0))
 443     (if (looking-at "[ \t]")
 444         (forward-char 1)
 445       (mew-complete-insert " "))
 446     (if (eolp)
 447         nil
 448       (let ((start (point)) ret)
 449         (end-of-line)
 450         (if (and here (re-search-backward (regexp-quote here) start t))
 451             (progn
 452               (setq start (1+ (point)))
 453               (end-of-line)))
 454         (setq ret (mew-buffer-substring start (point)))
 455         (delete-region start (point))
 456         ret))))
 457
 458 ;;
 459 ;; Making alist
 460 ;;
 461
 462 (defun mew-slide-pair (x)
 463   (let ((ret nil)
 464         (first (car x)))
 465     (cond
 466      ((eq x 0) nil)
 467      ((eq x 1) (cons first first))
 468      (t
 469       (while (cdr x)
 470         (setq ret (cons (cons (nth 0 x) (nth 1 x)) ret))
 471         (setq x (cdr x)))
 472       (setq ret (cons (cons (car x) first) ret))
 473       (nreverse ret)))))
 474
 475 (provide 'mew-complete)
 476
 477 ;;; Copyright Notice:
 478
 479 ;; Copyright (C) 1997, 1998, 1999 Mew developing team.
 480 ;; All rights reserved.
 481
 482 ;; Redistribution and use in source and binary forms, with or without
 483 ;; modification, are permitted provided that the following conditions
 484 ;; are met:
 485 ;;
 486 ;; 1. Redistributions of source code must retain the above copyright
 487 ;;    notice, this list of conditions and the following disclaimer.
 488 ;; 2. Redistributions in binary form must reproduce the above copyright
 489 ;;    notice, this list of conditions and the following disclaimer in the
 490 ;;    documentation and/or other materials provided with the distribution.
 491 ;; 3. Neither the name of the team nor the names of its contributors
 492 ;;    may be used to endorse or promote products derived from this software
 493 ;;    without specific prior written permission.
 494 ;;
 495 ;; THIS SOFTWARE IS PROVIDED BY THE TEAM AND CONTRIBUTORS ``AS IS'' AND
 496 ;; ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE
 497 ;; IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
 498 ;; PURPOSE ARE DISCLAIMED.  IN NO EVENT SHALL THE TEAM OR CONTRIBUTORS BE
 499 ;; LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
 500 ;; CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
 501 ;; SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR
 502 ;; BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY,
 503 ;; WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE
 504 ;; OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN
 505 ;; IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
 506
 507 ;;; mew-complete.el ends here