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