git.chise.org Git - chise/xemacs-chise.git.1/blob - lisp/gtk-password-dialog.el

   1 ;;; gtk-password-dialog.el --- Reading passwords in a dialog
   2
   3 ;; Copyright (C) 2000 Free Software Foundation, Inc.
   4
   5 ;; Maintainer: William M. Perry <wmperry@gnu.org>
   6 ;; Keywords: extensions, internal
   7
   8 ;; This file is part of XEmacs.
   9
  10 ;; XEmacs is free software; you can redistribute it and/or modify it
  11 ;; under the terms of the GNU General Public License as published by
  12 ;; the Free Software Foundation; either version 2, or (at your option)
  13 ;; any later version.
  14
  15 ;; XEmacs is distributed in the hope that it will be useful, but
  16 ;; WITHOUT ANY WARRANTY; without even the implied warranty of
  17 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
  18 ;; General Public License for more details.
  19
  20 ;; You should have received a copy of the GNU General Public License
  21 ;; along with XEmacs; see the file COPYING.  If not, write to the
  22 ;; Free Software Foundation, 59 Temple Place - Suite 330,
  23 ;; Boston, MA 02111-1307, USA.
  24
  25 ;;; Synched up with: Not in FSF.
  26
  27 (defun gtk-password-dialog-ok-button (dlg)
  28   (get dlg 'x-ok-button))
  29
  30 (defun gtk-password-dialog-cancel-button (dlg)
  31   (get dlg 'x-cancel-button))
  32
  33 (defun gtk-password-dialog-entry-widget (dlg)
  34   (get dlg 'x-initial-entry))
  35
  36 (defun gtk-password-dialog-confirmation-widget (dlg)
  37   (get dlg 'x-verify-entry))
  38
  39 (defun gtk-password-dialog-new (&rest keywords)
  40   ;; Format is (:keyword value ...)
  41   ;; Allowed keywords are:
  42   ;;
  43   ;;  :callback function
  44   ;;  :default string
  45   ;;  :title string
  46   :;  :prompt string
  47   ;;  :default string
  48   ;;  :verify boolean
  49   ;;  :verify-prompt string
  50   (let* ((callback (plist-get keywords :callback 'ignore))
  51          (dialog (gtk-dialog-new))
  52          (vbox (gtk-dialog-vbox dialog))
  53          (button-area (gtk-dialog-action-area dialog))
  54          (default (plist-get keywords :default))
  55          (widget nil))
  56     (gtk-window-set-title dialog (plist-get keywords :title "Enter password..."))
  57
  58     ;; Make us modal...
  59     (put dialog 'type 'dialog)
  60
  61     ;; Put the buttons in the bottom
  62     (setq widget (gtk-button-new-with-label "OK"))
  63     (gtk-container-add button-area widget)
  64     (gtk-signal-connect widget 'clicked
  65                         (lambda (button data)
  66                           (funcall (car data)
  67                                    (gtk-entry-get-text
  68                                     (get (cdr data) 'x-initial-entry))))
  69                         (cons callback dialog))
  70     (put dialog 'x-ok-button widget)
  71
  72     (setq widget (gtk-button-new-with-label "Cancel"))
  73     (gtk-container-add button-area widget)
  74     (gtk-signal-connect widget 'clicked
  75                         (lambda (button dialog)
  76                           (gtk-widget-destroy dialog))
  77                         dialog)
  78     (put dialog 'x-cancel-button widget)
  79
  80     ;; Now the entry area...
  81     (gtk-container-set-border-width vbox 5)
  82     (setq widget (gtk-label-new (plist-get keywords :prompt "Password:")))
  83     (gtk-misc-set-alignment widget 0.0 0.5)
  84     (gtk-container-add vbox widget)
  85
  86     (setq widget (gtk-entry-new))
  87     (put widget 'visibility nil)
  88     (gtk-container-add vbox widget)
  89     (put dialog 'x-initial-entry widget)
  90
  91     (if (plist-get keywords :verify)
  92         (let ((changed-cb (lambda (editable dialog)
  93                             (gtk-widget-set-sensitive
  94                              (get dialog 'x-ok-button)
  95                              (equal (gtk-entry-get-text
  96                                      (get dialog 'x-initial-entry))
  97                                     (gtk-entry-get-text
  98                                      (get dialog 'x-verify-entry)))))))
  99           (gtk-container-set-border-width vbox 5)
 100           (setq widget (gtk-label-new (plist-get keywords :verify-prompt "Verify:")))
 101           (gtk-misc-set-alignment widget 0.0 0.5)
 102           (gtk-container-add vbox widget)
 103
 104           (setq widget (gtk-entry-new))
 105           (put widget 'visibility nil)
 106           (gtk-container-add vbox widget)
 107           (put dialog 'x-verify-entry widget)
 108
 109           (gtk-signal-connect (get dialog 'x-initial-entry)
 110                               'changed changed-cb dialog)
 111           (gtk-signal-connect (get dialog 'x-verify-entry)
 112                               'changed changed-cb dialog)
 113           (gtk-widget-set-sensitive (get dialog 'x-ok-button) nil)))
 114
 115     (if default
 116         (progn
 117           (gtk-entry-set-text (get dialog 'x-initial-entry) default)
 118           (gtk-entry-select-region (get dialog 'x-initial-entry)
 119                                    0 (length default))))
 120     dialog))
 121
 122 (provide 'gtk-password-dialog)