git.chise.org Git - elisp/gnus.git-/blob - lisp/read-passwd.el

   1 ;; read-passwd.el.el --- Read password function for Pterodactyl Gnus.
   2 ;; Copyright (C) 1996,97,98 Free Software Foundation, Inc. , Tatsuya Ichikawa
   3 ;; Author: Tatsuya Ichikawa <t-ichi@po.shiojiri.ne.jp>
   4 ;; Version: 0.01
   5 ;; Keywords: mail , gnus , pop3 , password
   6 ;;
   7 ;; SPECIAL THANKS
   8 ;;    Katsumi Yamaoka <yamaoka@jpl.org>
   9 ;;
  10 ;; This file is part of Semi-gnus.
  11
  12 ;; GNU Emacs is free software; you can redistribute it and/or modify
  13 ;; it under the terms of the GNU General Public License as published by
  14 ;; the Free Software Foundation; either version 2, or (at your option)
  15 ;; any later version.
  16
  17 ;; GNU Emacs is distributed in the hope that it will be useful,
  18 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  19 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  20 ;; GNU General Public License for more details.
  21
  22 ;; You should have received a copy of the GNU General Public License
  23 ;; along with GNU Emacs; see the file COPYING.  If not, write to the
  24 ;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
  25 ;; Boston, MA 02111-1307, USA.
  26 ;;
  27 ;;
  28 (require 'mail-source)
  29 (provide 'read-passwd)
  30
  31 (defun read-pw-read-passwd (prompt)
  32   (read-pw-read-noecho prompt t))
  33 ;;
  34 (defmacro read-pw-read-char-exclusive ()
  35   (cond ((featurep 'xemacs)
  36          '(let ((table (quote ((backspace . ?\C-h) (delete . ?\C-?)
  37                                (left . ?\C-h))))
  38                 event key)
  39             (while (not
  40                     (and
  41                      (key-press-event-p (setq event (next-command-event)))
  42                      (setq key (or (event-to-character event)
  43                                    (cdr (assq (event-key event) table)))))))
  44             key))
  45         ((fboundp 'read-char-exclusive)
  46          '(read-char-exclusive))
  47         (t
  48          '(read-char))))
  49 ;;
  50 (defun read-pw-read-noecho (prompt &optional stars)
  51   "Read a single line of text from user without echoing, and return it.
  52 Argument PROMPT ."
  53   (let ((ans "")
  54         (c 0)
  55         (echo-keystrokes 0)
  56         (cursor-in-echo-area t)
  57         (log-message-max-size 0)
  58         message-log-max done msg truncate)
  59     (while (not done)
  60       (if (or (not stars) (string-equal "" ans))
  61           (setq msg prompt)
  62         (setq msg (concat prompt (make-string (length ans) ?*)))
  63         (setq truncate
  64               (1+ (- (length msg) (window-width (minibuffer-window)))))
  65         (and (> truncate 0)
  66              (setq msg (concat "$" (substring msg (1+ truncate))))))
  67       (message "%s" msg)
  68       (setq c (read-pw-read-char-exclusive))
  69       (cond ((eq ?\C-g c)
  70              (setq quit-flag t
  71                    done t))
  72             ((memq c '(?\r ?\n ?\e))
  73              (setq done t))
  74             ((eq ?\C-u c)
  75              (setq ans ""))
  76             ((and (/= ?\b c) (/= ?\177 c))
  77              (setq ans (concat ans (char-to-string c))))
  78             ((> (length ans) 0)
  79              (setq ans (substring ans 0 -1)))))
  80     (if quit-flag
  81         (prog1
  82             (setq quit-flag nil)
  83           (message "Quit")
  84           (beep t))
  85       (message "")
  86       ans)))
  87 ;;
  88 (defvar pw nil)
  89 (defun read-pw-set-mail-source-passwd-cache ()
  90   (if (not mail-source-password-cache)
  91       (car (mapcar
  92             (lambda (x)
  93               (when (eq 'pop (car x))
  94                 (mail-source-bind (pop x)
  95                   (let ((from (format "%s:%s:%s" server user port))
  96                         (mail-source-string
  97                          (format "pop:%s@%s" user server)))
  98                     (setq pw (read-pw-return-passwd-string user server))
  99                     (unless (assoc user mail-source-password-cache)
 100                       (set-alist 'mail-source-password-cache
 101                                  (format "%s:%s:%s" server user port)
 102                                  pw))
 103                     (cdr (assoc from mail-source-password-cache))))))
 104             mail-sources))))
 105 ;;
 106 ;;
 107 (defvar passwd nil)
 108 (defun read-pw-return-passwd-string (user server)
 109   (setq passwd (read-pw-read-passwd
 110                 (message "POP Password for %s at %s : " user server)))
 111   passwd)
 112 ;;
 113 ;; read-passwd.el ends here.