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

   1 ;;; mew-minibuf.el --- Minibuffer input methods for Mew
   2
   3 ;; Author:  Kazu Yamamoto <Kazu@Mew.org>
   4 ;; Created: Mar 23, 1997
   5 ;; Revised: Aug 30, 1999
   6
   7 ;;; Code:
   8
   9 (defconst mew-minibuf-version "mew-minibuf.el version 0.10")
  10
  11 (require 'mew)
  12
  13 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  14 ;;;
  15 ;;; Keymap and completion switch
  16 ;;;
  17
  18 (defvar mew-input-map nil)
  19
  20 (if mew-input-map
  21     ()
  22   (setq mew-input-map (make-sparse-keymap))
  23   (define-key mew-input-map " "    'mew-input-complete)
  24   (define-key mew-input-map "\t"   'mew-input-complete)
  25 ;;  (define-key mew-input-map "\177" 'backward-delete-char)
  26 ;;  (define-key mew-input-map "\C-h" 'mew-complete-backscroll)
  27   (define-key mew-input-map "\r"   'exit-minibuffer)
  28   (define-key mew-input-map "\n"   'exit-minibuffer)
  29   (define-key mew-input-map "\C-g" 'abort-recursive-edit)
  30   (define-key mew-input-map "\M-p" 'previous-history-element)
  31   (define-key mew-input-map "\M-n" 'next-history-element)
  32   )
  33
  34 (defvar mew-input-complete-function nil)
  35
  36 (defun mew-input-complete ()
  37   "Do completion according to the global variable
  38 \"mew-input-complete-function\"."
  39   (interactive)
  40   (if (and mew-input-complete-function (fboundp mew-input-complete-function))
  41       (funcall mew-input-complete-function)))
  42
  43 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  44 ;;;
  45 ;;; Mew original completion
  46 ;;;
  47
  48 (defun mew-input-clear ()
  49   "A function to clean up side effects of window configuration
  50 at completions."
  51   (save-excursion
  52     (set-buffer (window-buffer (minibuffer-window)))
  53     ;; mew-complete-window-config is shared by many functions
  54     ;; because minibuffer is just one!
  55     (setq mew-complete-window-config nil)))
  56
  57 ;;;
  58 ;;; Folder
  59 ;;;
  60
  61 (defvar mew-input-folder-hist nil)
  62
  63 (defun mew-input-folder (default)
  64   (let ((prefix (substring default 0 1))
  65          folder)
  66     (mew-input-clear)
  67     (setq mew-input-complete-function (function mew-complete-folder))
  68     (setq folder (read-from-minibuffer (format "Folder name (%s): " default)
  69                                        prefix
  70                                        mew-input-map
  71                                        nil
  72                                        'mew-input-folder-hist))
  73     (directory-file-name
  74      (if (or (string= folder "") (string= folder prefix))
  75          default
  76        folder))))
  77
  78 (defun mew-input-folders (default &optional prompt)
  79   (let (form folders)
  80     (if prompt
  81         (progn
  82           (setq form "Folder name : ")
  83           (setq default prompt))
  84       (setq form (format "Folder name (%s): " default))
  85       (setq prompt "+"))
  86     (mew-input-clear)
  87     (setq mew-input-complete-function (function mew-complete-folder))
  88     (setq folders (read-from-minibuffer form
  89                                         prompt
  90                                         mew-input-map
  91                                         nil
  92                                         'mew-input-folder-hist))
  93     (if (or (string= folders "") (string= folders "+"))
  94         (setq folders default))
  95     (mapcar (function directory-file-name)
  96             (mapcar (function mew-chop)
  97                     (mew-split folders ?,)))))
  98
  99 ;;;
 100 ;;; Address
 101 ;;;
 102
 103 (defvar mew-input-address-hist nil)
 104
 105 (defun mew-input-address (prompt &optional default)
 106   (mew-input-clear)
 107   (setq mew-input-complete-function (function mew-complete-address))
 108   (let (tmp)
 109     (setq tmp (read-from-minibuffer
 110                (if default (format prompt default) prompt)
 111                ""
 112                mew-input-map
 113                nil
 114                'mew-input-address-hist))
 115     (if (and default (string= tmp ""))
 116         (setq tmp default))
 117     (mew-addrstr-canonicalize-address tmp)))
 118
 119 ;;;
 120 ;;; Pick pattern
 121 ;;;
 122
 123 (defvar mew-input-pick-pattern-hist nil)
 124
 125 (defun mew-input-pick-pattern ()
 126   (mew-input-clear)
 127   (setq mew-input-complete-function (function mew-complete-pick-pattern))
 128   (let ((keymap (copy-keymap mew-input-map)) ret)
 129     (define-key keymap " " nil)
 130     (setq ret
 131           (mew-pick-canonicalize-pattern
 132            (mew-pick-macro-expand-string
 133             (read-from-minibuffer "pick pattern: "
 134                                   mew-pick-default-field
 135                                   keymap
 136                                   nil
 137                                   'mew-input-pick-pattern-hist))))
 138     (mew-decode-syntax-delete)
 139     ret))
 140
 141 ;;;
 142 ;;; Sort key
 143 ;;;
 144 ;;; mew-sort-default-key-alist
 145
 146 (defvar mew-input-sort-key-hist nil)
 147
 148 (defun mew-input-sort-key (mew-sort-key)
 149   (mew-input-clear)
 150   (setq mew-input-complete-function (function mew-complete-sort-key))
 151   (let* ((field:mode (read-from-minibuffer
 152                       (format "Sort by (%s)? : " mew-sort-key)
 153                       ""
 154                       mew-input-map
 155                       nil
 156                       'mew-input-sort-key-hist))
 157          field mode)
 158     (if (or (null field:mode) (equal field:mode ""))
 159         (setq field:mode mew-sort-key))
 160     (setq field (car (mew-split field:mode ?:)))
 161     (setq mode  (or (car (cdr (mew-split field:mode ?:)))
 162                     (cdr (assoc field mew-sort-key-alist))
 163                     "text"))
 164     (cons field mode)))
 165
 166 ;;;
 167 ;;; Remote file
 168 ;;;
 169
 170 (defvar mew-input-rfile-hist nil)
 171
 172 (defun mew-input-rfile (prompt) ;; prompt="To:"
 173   (mew-input-clear)
 174   (setq mew-input-complete-function (function mew-complete-rfile))
 175   (read-from-minibuffer
 176    (concat prompt " ")
 177    ""
 178    mew-input-map
 179    nil
 180    'mew-input-rfile-hist))
 181
 182 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 183 ;;;
 184 ;;; Emacs primitive completion
 185 ;;;
 186
 187 ;;;
 188 ;;; Range
 189 ;;;
 190
 191 (defun mew-input-range (folder alist askp)
 192   "Return (range erase-update)."
 193   ;; for the case when parts are expanded in the bottom of the folder
 194   (let* ((pair (mew-assoc-match2 folder alist 0))
 195          (default (or (cdr pair) "update")) ;; just in case
 196          range ret)
 197     (if askp
 198         (setq range
 199               (completing-read (format "Range (%s): " default)
 200                                (mapcar (function (lambda (x) (cons x x)))
 201                                        mew-input-range-list))))
 202     (if (or (string= range "") (not range))
 203         (setq range default))
 204     (if (not (string-match "^[0-9a-zA-Z]" range))
 205         (error "Illegal range: %s" range))
 206     (cond
 207      ;; range is other than "update"
 208      ((not (string= range "update"))
 209       (setq ret (list range 'erase))) ;; non-update, erase it
 210      ;; update
 211      ((get-buffer folder)
 212       (setq ret (mew-update-range)))
 213      ;; update but folder doesn't exist in Emacs.
 214      (t (setq ret (list "all" 'update)))) ;; no need to erase
 215     (mew-decode-syntax-delete)
 216     ret))
 217
 218 (defun mew-update-range ()
 219   (save-excursion
 220     (goto-char (point-max))
 221     (if (bobp)
 222         (list "all" 'update) ;; buffer is empty. no need to erase
 223       (forward-line -1)
 224       (mew-summary-goto-message)
 225       (list
 226        (concat
 227         (int-to-string (1+ (string-to-int (mew-summary-message-number))))
 228         "-"
 229         "last")
 230        'update)))) ;; this is update!
 231
 232 ;;;
 233 ;;; File
 234 ;;;
 235
 236 (defun mew-input-file-name (&optional prompt default)
 237   (let ((msg (or prompt "File: "))
 238         (use-dialog-box nil)
 239         file)
 240     (cond
 241      ((null default)
 242       (setq file mew-home))
 243      ((or (string-match (format "^[~%s]" mew-path-separator) default)
 244         ;; allow drive letter -- "^\\([A-Za-z]:\\|[~%s]\\)"
 245         (string-match (format "^[A-Za-z]:%s.+" mew-path-separator) default))
 246       (setq file default))
 247      (t
 248       (setq file (concat mew-home default))))
 249     (expand-file-name (read-file-name msg file file))))
 250
 251 (defun mew-input-directory-name (&optional default)
 252   (let ((dir (expand-file-name (read-file-name "Directory : " default nil t))))
 253     (if (file-directory-p dir)
 254         dir
 255       (message "%s is not directory" dir)
 256       (sit-for 1)
 257       (mew-input-directory-name default))))
 258
 259 (defun mew-convert-to-home-dir (dir)
 260   (let* ((chome (file-name-as-directory mew-home))
 261          (ehome (expand-file-name chome)))
 262     (if (string-match ehome dir)
 263         (concat chome (substring dir (match-end 0) nil))
 264       dir)))
 265
 266 (defvar mew-summary-previous-directory nil)
 267 (defvar mew-draft-previous-directory nil)
 268
 269 (defmacro mew-mode-input-file-name (prompt file preservep previous modedir)
 270   (` (let (dir ret def)
 271        (if (and (, file) (file-name-absolute-p (, file)))
 272            (setq def (mew-convert-to-home-dir (, file)))
 273          (if (, preservep)
 274              (setq dir (or (, previous) (, modedir)))
 275            (setq dir (, modedir)))
 276          (setq dir (and dir (file-name-as-directory dir)))
 277          (setq def (concat dir (, file))))
 278        (setq ret (mew-input-file-name (, prompt) def))
 279        (if (, preservep)
 280            (setq (, previous)
 281                  (file-name-directory (mew-convert-to-home-dir ret))))
 282        ret)))
 283
 284 (defun mew-summary-input-file-name (&optional prompt file)
 285   (mew-mode-input-file-name prompt file mew-summary-preserve-dir
 286                             mew-summary-previous-directory mew-save-dir))
 287
 288 (defun mew-draft-input-file-name (&optional prompt file)
 289   (mew-mode-input-file-name prompt file mew-draft-preserve-dir
 290                             mew-draft-previous-directory mew-copy-dir))
 291
 292 (defmacro mew-mode-input-directory-name (preservep previous modedir)
 293   (` (if (, preservep)
 294          (let (dir ret)
 295            (setq dir (file-name-as-directory (or (, previous) (, modedir))))
 296            (setq ret (mew-input-directory-name dir))
 297            (setq (, previous) (mew-convert-to-home-dir ret))
 298            ret)
 299        (mew-input-directory-name))))
 300
 301 (defun mew-summary-input-directory-name ()
 302   (mew-mode-input-directory-name mew-summary-preserve-dir
 303                                  mew-summary-previous-directory mew-save-dir))
 304
 305 (defun mew-draft-input-directory-name ()
 306   (mew-mode-input-directory-name mew-draft-preserve-dir
 307                                  mew-draft-previous-directory mew-copy-dir))
 308 ;;;
 309 ;;; String
 310 ;;;
 311
 312 (defun mew-input-string (prompt subdir default)
 313   (let ((input (read-string (format prompt subdir default) "")))
 314     (if (string= input "") default input)))
 315
 316 ;;;
 317 ;;; Type
 318 ;;;
 319
 320 (defun mew-input-type (prompt filename default type-list)
 321   (let ((completion-ignore-case t)
 322         (type))
 323     (setq type (completing-read
 324                 (format prompt filename default)
 325                 (mapcar (function (lambda (x) (cons x x))) type-list)
 326                 nil
 327                 t  ;; not require match
 328                 ""))
 329     (if (string= type "") default type)))
 330
 331 ;;;
 332 ;;; Config
 333 ;;;
 334
 335 (defun mew-input-config (default)
 336   (let ((config))
 337     (setq config (completing-read
 338                   (format "Config value (%s): "
 339                           (or default mew-config-default))
 340                   (mapcar (function (lambda (x) (cons x x))) mew-config-list)
 341                   nil t nil))
 342     (if (string= config "")
 343         (or default mew-config-default)
 344       config)))
 345
 346 ;;;
 347 ;;;
 348 ;;;
 349
 350 (defun mew-input-general (prompt alist &optional require-match initial)
 351   (let* ((completion-ignore-case t)
 352          (question (if initial (format "%s (%s) : " prompt initial)
 353                      (format "(%s) : " prompt)))
 354          (value (completing-read question alist nil require-match nil)))
 355     (if (and initial (string= value "")) initial value)))
 356
 357 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 358 ;;;
 359 ;;; password function
 360 ;;;
 361
 362 (defvar mew-passwd-alist nil)
 363 (defvar mew-passwd-timer-id nil)
 364
 365 (defmacro mew-passwd-get-passwd (key)
 366   (` (nth 1 (assoc (, key) mew-passwd-alist))))
 367 (defmacro mew-passwd-get-counter (key)
 368   (` (nth 2 (assoc (, key) mew-passwd-alist))))
 369
 370 (defun mew-passwd-set-passwd (key val)
 371   (if (assoc key mew-passwd-alist)
 372       (setcar (nthcdr 1 (assoc key mew-passwd-alist)) val)
 373     (setq mew-passwd-alist (cons (list key val 0) mew-passwd-alist))))
 374 (defun mew-passwd-set-counter (key val)
 375   (if (assoc key mew-passwd-alist)
 376       (setcar (nthcdr 2 (assoc key mew-passwd-alist)) val)))
 377
 378 (defun mew-passwd-get-keys ()
 379   (mapcar (function car) mew-passwd-alist))
 380
 381 (defmacro mew-passwd-reset ()
 382   '(setq mew-passwd-alist nil))
 383
 384 (defun mew-passwd-setup ()
 385   (if mew-use-timer
 386       (setq mew-passwd-timer-id
 387             (mew-timer mew-passwd-timer-unit (function mew-passwd-timer)))))
 388
 389 (defun mew-passwd-clean-up ()
 390   (mew-passwd-reset)
 391   (if mew-passwd-timer-id
 392       (progn
 393         (if (not (fboundp 'disable-timeout))
 394             (require 'timer))
 395         (cond
 396          ((fboundp 'disable-timeout) (disable-timeout mew-passwd-timer-id))
 397          ((fboundp 'cancel-timer) (cancel-timer mew-passwd-timer-id)))))
 398   (setq mew-passwd-timer-id nil))
 399
 400 (defun mew-passwd-timer (&optional arg) ;; for XEmacs
 401   (let ((keys (mew-passwd-get-keys)) key)
 402     (while keys
 403       (setq key (car keys))
 404       (setq keys (cdr keys))
 405       (if (< (mew-passwd-get-counter key) mew-passwd-lifetime)
 406           (mew-passwd-set-counter key (1+ (mew-passwd-get-counter key)))
 407         ;; time out
 408         (mew-passwd-set-passwd key nil)
 409         (mew-passwd-set-counter key 0))))
 410   ;; repeat every 10 minutes
 411   (mew-passwd-setup))
 412
 413 (defun mew-input-passwd (prompt &optional key)
 414   (if key
 415       (if (mew-passwd-get-passwd key)
 416           (progn
 417             (sit-for 0 1)  ;; timing problem, sigh
 418             (if mew-passwd-reset-timer
 419                 (mew-passwd-set-counter key 0))
 420             (mew-passwd-get-passwd key))
 421         (let ((pass (mew-read-passwd prompt)))
 422           (mew-passwd-set-passwd key pass)
 423           (mew-passwd-set-counter key 0)
 424           pass))
 425     (mew-read-passwd prompt)))
 426
 427 (defun mew-read-passwd (prompt)
 428   (let ((inhibit-input-event-recording t))
 429     (if (fboundp 'read-passwd)
 430         (read-passwd prompt)
 431       (let ((pass "")
 432             (c 0)
 433             (echo-keystrokes 0)
 434             (ociea cursor-in-echo-area))
 435         (condition-case nil
 436             (progn
 437               (setq cursor-in-echo-area 1)
 438               (while (and (/= c ?\r) (/= c ?\n) (/= c ?\e) (/= c 7)) ;; ^G
 439                 (message "%s%s"
 440                          prompt
 441                          (make-string (length pass) ?.))
 442                 (setq c (read-char-exclusive))
 443                 (cond
 444                  ((char-equal c ?\C-u)
 445                   (setq pass ""))
 446                  ((or (char-equal c ?\b) (char-equal c ?\177))  ;; BS DELL
 447                   ;; delete one character in the end
 448                   (if (not (equal pass ""))
 449                       (setq pass (substring pass 0 -1))))
 450                  ((< c 32) ()) ;; control, just ignore
 451                  (t
 452                   (setq pass (concat pass (char-to-string c))))))
 453               (setq cursor-in-echo-area -1))
 454           (quit
 455            (setq cursor-in-echo-area ociea)
 456            (signal 'quit nil)))
 457         (setq cursor-in-echo-area ociea)
 458         (message "")
 459         (sit-for 0)
 460         pass))))
 461
 462 (provide 'mew-minibuf)
 463
 464 ;;; Copyright Notice:
 465
 466 ;; Copyright (C) 1997, 1998, 1999 Mew developing team.
 467 ;; All rights reserved.
 468
 469 ;; Redistribution and use in source and binary forms, with or without
 470 ;; modification, are permitted provided that the following conditions
 471 ;; are met:
 472 ;;
 473 ;; 1. Redistributions of source code must retain the above copyright
 474 ;;    notice, this list of conditions and the following disclaimer.
 475 ;; 2. Redistributions in binary form must reproduce the above copyright
 476 ;;    notice, this list of conditions and the following disclaimer in the
 477 ;;    documentation and/or other materials provided with the distribution.
 478 ;; 3. Neither the name of the team nor the names of its contributors
 479 ;;    may be used to endorse or promote products derived from this software
 480 ;;    without specific prior written permission.
 481 ;;
 482 ;; THIS SOFTWARE IS PROVIDED BY THE TEAM AND CONTRIBUTORS ``AS IS'' AND
 483 ;; ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE
 484 ;; IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR
 485 ;; PURPOSE ARE DISCLAIMED.  IN NO EVENT SHALL THE TEAM OR CONTRIBUTORS BE
 486 ;; LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
 487 ;; CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
 488 ;; SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR
 489 ;; BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY,
 490 ;; WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE
 491 ;; OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN
 492 ;; IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
 493
 494 ;;; mew-minibuf.el ends here