(CU+52F5): Apply new conventions for glyph granularity.
[chise/xemacs-chise.git] / 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)