annotate lisp/gtk-password-dialog.el @ 5560:58b38d5b32d0

Implement print-circle, allowing recursive and circular structures to be read. src/ChangeLog addition: 2011-09-04 Aidan Kehoe <kehoea@parhasard.net> * alloc.c: * alloc.c (ALLOC_FROB_BLOCK_LISP_OBJECT_1): * alloc.c (ALLOC_FROB_BLOCK_LISP_OBJECT): * alloc.c (cons_print_preprocess): * alloc.c (vector_print_preprocess): * alloc.c (vector_nsubst_structures_descend): * alloc.c (Fmake_symbol): * alloc.c (UNMARK_symbol): * alloc.c (sweep_symbols): * alloc.c (reinit_alloc_objects_early): * alloc.c (reinit_alloc_early): * bytecode.c: * bytecode.c (compiled_function_print_preprocess): * bytecode.c (compiled_function_nsubst_structures_descend): * bytecode.c (set_compiled_function_arglist): * bytecode.c (set_compiled_function_interactive): * bytecode.c (bytecode_objects_create): * chartab.c: * chartab.c (print_preprocess_mapper): * chartab.c (nsubst_structures_mapper): * chartab.c (char_table_nsubst_structures_descend): * chartab.c (chartab_objects_create): * elhash.c: * elhash.c (nsubst_structures_map_hash_table): * elhash.c (hash_table_nsubst_structures_descend): * elhash.c (print_preprocess_mapper): * elhash.c (hash_table_print_preprocess): * elhash.c (inchash_eq): * elhash.c (hash_table_objects_create): * elhash.c (syms_of_elhash): * elhash.h: * emacs.c (main_1): * fns.c: * fns.c (check_eq_nokey): * fns.c (Fnsubst): * fns.c (syms_of_fns): * lisp.h: * lisp.h (struct Lisp_Symbol): * lisp.h (IN_OBARRAY): * lisp.h (struct): * lisp.h (PRINT_PREPROCESS): * lread.c (read1): * lrecord.h: * lrecord.h (struct lrecord_implementation): * lrecord.h (DEFINE_DUMPABLE_MODULE_LISP_OBJECT): * print.c: * print.c (PRINT_CIRCLE_LIMIT): * print.c (print_continuous_numbering_changed): * print.c (print_prepare): * print.c (print_finish): * print.c (Fprin1_to_string): * print.c (print_cons): * print.c (print_preprocess_inchash_eq): * print.c (print_preprocess): * print.c (print_sort_get_numbers): * print.c (print_sort_compare_ordinals): * print.c (print_gensym_or_circle): * print.c (nsubst_structures_descend): * print.c (nsubst_structures): * print.c (print_internal): * print.c (print_symbol): * print.c (vars_of_print): * rangetab.c: * rangetab.c (range_table_print_preprocess): * rangetab.c (range_table_nsubst_structures_descend): * rangetab.c (rangetab_objects_create): * rangetab.c (syms_of_rangetab): * symbols.c: * symbols.c (symbol_print_preprocess): * symbols.c (Fintern): * symbols.c (Funintern): * symbols.c (reinit_symbol_objects_early): * symbols.c (init_symbols_once_early): * symsinit.h: Implement print-circle, printing circular structures in a readable fashion, and treating them appropriately on read. This is by means of two new object methods, print_preprocess (detecting circularities), and nsubst_structures_descend (replacing placeholders with the read objects). Expose the substitution to Lisp via #'nsubst and its new :descend-structures keyword. Store information as to whether symbols are interned in obarray or not in their header, making checking for keywords and uninterned symbols (and thus printing) cheaper. Default print_gensym to t, as Common Lisp does, and as a more-than-decade old comment suggests. lisp/ChangeLog addition: 2011-09-04 Aidan Kehoe <kehoea@parhasard.net> * bytecomp.el (byte-compile-output-file-form): * bytecomp.el (byte-compile-output-docform): Bind print-circle, print-continuous-numbering in these functions, now those variables are available. * lisp.el (forward-sexp): * lisp.el (backward-sexp): Recognise leading #N= as being part of an expression. tests/ChangeLog addition: 2011-09-04 Aidan Kehoe <kehoea@parhasard.net> * automated/lisp-reader-tests.el: * automated/lisp-tests.el (literal-with-uninterned): * automated/symbol-tests.el (foo): Test print-circle, for printing (mutually-)recursive and circular structures. Bind print-continuous-numbering where appropriate.
author Aidan Kehoe <kehoea@parhasard.net>
date Sun, 04 Sep 2011 19:51:35 +0100
parents 308d34e9f07d
children
Ignore whitespace changes - Everywhere: Within whitespace: At end of lines:
rev   line source
462
0784d089fdc9 Import from CVS: tag r21-2-46
cvs
parents:
diff changeset
1 ;;; gtk-password-dialog.el --- Reading passwords in a dialog
0784d089fdc9 Import from CVS: tag r21-2-46
cvs
parents:
diff changeset
2
0784d089fdc9 Import from CVS: tag r21-2-46
cvs
parents:
diff changeset
3 ;; Copyright (C) 2000 Free Software Foundation, Inc.
0784d089fdc9 Import from CVS: tag r21-2-46
cvs
parents:
diff changeset
4
0784d089fdc9 Import from CVS: tag r21-2-46
cvs
parents:
diff changeset
5 ;; Maintainer: William M. Perry <wmperry@gnu.org>
0784d089fdc9 Import from CVS: tag r21-2-46
cvs
parents:
diff changeset
6 ;; Keywords: extensions, internal
0784d089fdc9 Import from CVS: tag r21-2-46
cvs
parents:
diff changeset
7
0784d089fdc9 Import from CVS: tag r21-2-46
cvs
parents:
diff changeset
8 ;; This file is part of XEmacs.
0784d089fdc9 Import from CVS: tag r21-2-46
cvs
parents:
diff changeset
9
5402
308d34e9f07d Changed bulk of GPLv2 or later files identified by script
Mats Lidell <matsl@xemacs.org>
parents: 502
diff changeset
10 ;; XEmacs is free software: you can redistribute it and/or modify it
308d34e9f07d Changed bulk of GPLv2 or later files identified by script
Mats Lidell <matsl@xemacs.org>
parents: 502
diff changeset
11 ;; under the terms of the GNU General Public License as published by the
308d34e9f07d Changed bulk of GPLv2 or later files identified by script
Mats Lidell <matsl@xemacs.org>
parents: 502
diff changeset
12 ;; Free Software Foundation, either version 3 of the License, or (at your
308d34e9f07d Changed bulk of GPLv2 or later files identified by script
Mats Lidell <matsl@xemacs.org>
parents: 502
diff changeset
13 ;; option) any later version.
462
0784d089fdc9 Import from CVS: tag r21-2-46
cvs
parents:
diff changeset
14
5402
308d34e9f07d Changed bulk of GPLv2 or later files identified by script
Mats Lidell <matsl@xemacs.org>
parents: 502
diff changeset
15 ;; XEmacs is distributed in the hope that it will be useful, but WITHOUT
308d34e9f07d Changed bulk of GPLv2 or later files identified by script
Mats Lidell <matsl@xemacs.org>
parents: 502
diff changeset
16 ;; ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or
308d34e9f07d Changed bulk of GPLv2 or later files identified by script
Mats Lidell <matsl@xemacs.org>
parents: 502
diff changeset
17 ;; FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
308d34e9f07d Changed bulk of GPLv2 or later files identified by script
Mats Lidell <matsl@xemacs.org>
parents: 502
diff changeset
18 ;; for more details.
462
0784d089fdc9 Import from CVS: tag r21-2-46
cvs
parents:
diff changeset
19
0784d089fdc9 Import from CVS: tag r21-2-46
cvs
parents:
diff changeset
20 ;; You should have received a copy of the GNU General Public License
5402
308d34e9f07d Changed bulk of GPLv2 or later files identified by script
Mats Lidell <matsl@xemacs.org>
parents: 502
diff changeset
21 ;; along with XEmacs. If not, see <http://www.gnu.org/licenses/>.
462
0784d089fdc9 Import from CVS: tag r21-2-46
cvs
parents:
diff changeset
22
0784d089fdc9 Import from CVS: tag r21-2-46
cvs
parents:
diff changeset
23 ;;; Synched up with: Not in FSF.
0784d089fdc9 Import from CVS: tag r21-2-46
cvs
parents:
diff changeset
24
502
7039e6323819 [xemacs-hg @ 2001-05-04 22:41:46 by ben]
ben
parents: 462
diff changeset
25 (globally-declare-fboundp
7039e6323819 [xemacs-hg @ 2001-05-04 22:41:46 by ben]
ben
parents: 462
diff changeset
26 '(gtk-dialog-new
7039e6323819 [xemacs-hg @ 2001-05-04 22:41:46 by ben]
ben
parents: 462
diff changeset
27 gtk-dialog-vbox gtk-dialog-action-area
7039e6323819 [xemacs-hg @ 2001-05-04 22:41:46 by ben]
ben
parents: 462
diff changeset
28 gtk-window-set-title gtk-button-new-with-label
7039e6323819 [xemacs-hg @ 2001-05-04 22:41:46 by ben]
ben
parents: 462
diff changeset
29 gtk-container-add gtk-signal-connect gtk-entry-get-text
7039e6323819 [xemacs-hg @ 2001-05-04 22:41:46 by ben]
ben
parents: 462
diff changeset
30 gtk-widget-destroy gtk-container-set-border-width gtk-label-new
7039e6323819 [xemacs-hg @ 2001-05-04 22:41:46 by ben]
ben
parents: 462
diff changeset
31 gtk-misc-set-alignment gtk-entry-new gtk-widget-set-sensitive
7039e6323819 [xemacs-hg @ 2001-05-04 22:41:46 by ben]
ben
parents: 462
diff changeset
32 gtk-entry-set-text gtk-entry-select-region))
7039e6323819 [xemacs-hg @ 2001-05-04 22:41:46 by ben]
ben
parents: 462
diff changeset
33
462
0784d089fdc9 Import from CVS: tag r21-2-46
cvs
parents:
diff changeset
34 (defun gtk-password-dialog-ok-button (dlg)
0784d089fdc9 Import from CVS: tag r21-2-46
cvs
parents:
diff changeset
35 (get dlg 'x-ok-button))
0784d089fdc9 Import from CVS: tag r21-2-46
cvs
parents:
diff changeset
36
0784d089fdc9 Import from CVS: tag r21-2-46
cvs
parents:
diff changeset
37 (defun gtk-password-dialog-cancel-button (dlg)
0784d089fdc9 Import from CVS: tag r21-2-46
cvs
parents:
diff changeset
38 (get dlg 'x-cancel-button))
0784d089fdc9 Import from CVS: tag r21-2-46
cvs
parents:
diff changeset
39
0784d089fdc9 Import from CVS: tag r21-2-46
cvs
parents:
diff changeset
40 (defun gtk-password-dialog-entry-widget (dlg)
0784d089fdc9 Import from CVS: tag r21-2-46
cvs
parents:
diff changeset
41 (get dlg 'x-initial-entry))
0784d089fdc9 Import from CVS: tag r21-2-46
cvs
parents:
diff changeset
42
0784d089fdc9 Import from CVS: tag r21-2-46
cvs
parents:
diff changeset
43 (defun gtk-password-dialog-confirmation-widget (dlg)
0784d089fdc9 Import from CVS: tag r21-2-46
cvs
parents:
diff changeset
44 (get dlg 'x-verify-entry))
0784d089fdc9 Import from CVS: tag r21-2-46
cvs
parents:
diff changeset
45
0784d089fdc9 Import from CVS: tag r21-2-46
cvs
parents:
diff changeset
46 (defun gtk-password-dialog-new (&rest keywords)
0784d089fdc9 Import from CVS: tag r21-2-46
cvs
parents:
diff changeset
47 ;; Format is (:keyword value ...)
0784d089fdc9 Import from CVS: tag r21-2-46
cvs
parents:
diff changeset
48 ;; Allowed keywords are:
0784d089fdc9 Import from CVS: tag r21-2-46
cvs
parents:
diff changeset
49 ;;
0784d089fdc9 Import from CVS: tag r21-2-46
cvs
parents:
diff changeset
50 ;; :callback function
0784d089fdc9 Import from CVS: tag r21-2-46
cvs
parents:
diff changeset
51 ;; :default string
0784d089fdc9 Import from CVS: tag r21-2-46
cvs
parents:
diff changeset
52 ;; :title string
0784d089fdc9 Import from CVS: tag r21-2-46
cvs
parents:
diff changeset
53 :; :prompt string
0784d089fdc9 Import from CVS: tag r21-2-46
cvs
parents:
diff changeset
54 ;; :default string
0784d089fdc9 Import from CVS: tag r21-2-46
cvs
parents:
diff changeset
55 ;; :verify boolean
0784d089fdc9 Import from CVS: tag r21-2-46
cvs
parents:
diff changeset
56 ;; :verify-prompt string
0784d089fdc9 Import from CVS: tag r21-2-46
cvs
parents:
diff changeset
57 (let* ((callback (plist-get keywords :callback 'ignore))
0784d089fdc9 Import from CVS: tag r21-2-46
cvs
parents:
diff changeset
58 (dialog (gtk-dialog-new))
0784d089fdc9 Import from CVS: tag r21-2-46
cvs
parents:
diff changeset
59 (vbox (gtk-dialog-vbox dialog))
0784d089fdc9 Import from CVS: tag r21-2-46
cvs
parents:
diff changeset
60 (button-area (gtk-dialog-action-area dialog))
0784d089fdc9 Import from CVS: tag r21-2-46
cvs
parents:
diff changeset
61 (default (plist-get keywords :default))
0784d089fdc9 Import from CVS: tag r21-2-46
cvs
parents:
diff changeset
62 (widget nil))
0784d089fdc9 Import from CVS: tag r21-2-46
cvs
parents:
diff changeset
63 (gtk-window-set-title dialog (plist-get keywords :title "Enter password..."))
0784d089fdc9 Import from CVS: tag r21-2-46
cvs
parents:
diff changeset
64
0784d089fdc9 Import from CVS: tag r21-2-46
cvs
parents:
diff changeset
65 ;; Make us modal...
0784d089fdc9 Import from CVS: tag r21-2-46
cvs
parents:
diff changeset
66 (put dialog 'type 'dialog)
0784d089fdc9 Import from CVS: tag r21-2-46
cvs
parents:
diff changeset
67
0784d089fdc9 Import from CVS: tag r21-2-46
cvs
parents:
diff changeset
68 ;; Put the buttons in the bottom
0784d089fdc9 Import from CVS: tag r21-2-46
cvs
parents:
diff changeset
69 (setq widget (gtk-button-new-with-label "OK"))
0784d089fdc9 Import from CVS: tag r21-2-46
cvs
parents:
diff changeset
70 (gtk-container-add button-area widget)
0784d089fdc9 Import from CVS: tag r21-2-46
cvs
parents:
diff changeset
71 (gtk-signal-connect widget 'clicked
0784d089fdc9 Import from CVS: tag r21-2-46
cvs
parents:
diff changeset
72 (lambda (button data)
0784d089fdc9 Import from CVS: tag r21-2-46
cvs
parents:
diff changeset
73 (funcall (car data)
0784d089fdc9 Import from CVS: tag r21-2-46
cvs
parents:
diff changeset
74 (gtk-entry-get-text
0784d089fdc9 Import from CVS: tag r21-2-46
cvs
parents:
diff changeset
75 (get (cdr data) 'x-initial-entry))))
0784d089fdc9 Import from CVS: tag r21-2-46
cvs
parents:
diff changeset
76 (cons callback dialog))
0784d089fdc9 Import from CVS: tag r21-2-46
cvs
parents:
diff changeset
77 (put dialog 'x-ok-button widget)
0784d089fdc9 Import from CVS: tag r21-2-46
cvs
parents:
diff changeset
78
0784d089fdc9 Import from CVS: tag r21-2-46
cvs
parents:
diff changeset
79 (setq widget (gtk-button-new-with-label "Cancel"))
0784d089fdc9 Import from CVS: tag r21-2-46
cvs
parents:
diff changeset
80 (gtk-container-add button-area widget)
0784d089fdc9 Import from CVS: tag r21-2-46
cvs
parents:
diff changeset
81 (gtk-signal-connect widget 'clicked
0784d089fdc9 Import from CVS: tag r21-2-46
cvs
parents:
diff changeset
82 (lambda (button dialog)
0784d089fdc9 Import from CVS: tag r21-2-46
cvs
parents:
diff changeset
83 (gtk-widget-destroy dialog))
0784d089fdc9 Import from CVS: tag r21-2-46
cvs
parents:
diff changeset
84 dialog)
0784d089fdc9 Import from CVS: tag r21-2-46
cvs
parents:
diff changeset
85 (put dialog 'x-cancel-button widget)
0784d089fdc9 Import from CVS: tag r21-2-46
cvs
parents:
diff changeset
86
0784d089fdc9 Import from CVS: tag r21-2-46
cvs
parents:
diff changeset
87 ;; Now the entry area...
0784d089fdc9 Import from CVS: tag r21-2-46
cvs
parents:
diff changeset
88 (gtk-container-set-border-width vbox 5)
0784d089fdc9 Import from CVS: tag r21-2-46
cvs
parents:
diff changeset
89 (setq widget (gtk-label-new (plist-get keywords :prompt "Password:")))
0784d089fdc9 Import from CVS: tag r21-2-46
cvs
parents:
diff changeset
90 (gtk-misc-set-alignment widget 0.0 0.5)
0784d089fdc9 Import from CVS: tag r21-2-46
cvs
parents:
diff changeset
91 (gtk-container-add vbox widget)
0784d089fdc9 Import from CVS: tag r21-2-46
cvs
parents:
diff changeset
92
0784d089fdc9 Import from CVS: tag r21-2-46
cvs
parents:
diff changeset
93 (setq widget (gtk-entry-new))
0784d089fdc9 Import from CVS: tag r21-2-46
cvs
parents:
diff changeset
94 (put widget 'visibility nil)
0784d089fdc9 Import from CVS: tag r21-2-46
cvs
parents:
diff changeset
95 (gtk-container-add vbox widget)
0784d089fdc9 Import from CVS: tag r21-2-46
cvs
parents:
diff changeset
96 (put dialog 'x-initial-entry widget)
0784d089fdc9 Import from CVS: tag r21-2-46
cvs
parents:
diff changeset
97
0784d089fdc9 Import from CVS: tag r21-2-46
cvs
parents:
diff changeset
98 (if (plist-get keywords :verify)
0784d089fdc9 Import from CVS: tag r21-2-46
cvs
parents:
diff changeset
99 (let ((changed-cb (lambda (editable dialog)
0784d089fdc9 Import from CVS: tag r21-2-46
cvs
parents:
diff changeset
100 (gtk-widget-set-sensitive
0784d089fdc9 Import from CVS: tag r21-2-46
cvs
parents:
diff changeset
101 (get dialog 'x-ok-button)
0784d089fdc9 Import from CVS: tag r21-2-46
cvs
parents:
diff changeset
102 (equal (gtk-entry-get-text
0784d089fdc9 Import from CVS: tag r21-2-46
cvs
parents:
diff changeset
103 (get dialog 'x-initial-entry))
0784d089fdc9 Import from CVS: tag r21-2-46
cvs
parents:
diff changeset
104 (gtk-entry-get-text
0784d089fdc9 Import from CVS: tag r21-2-46
cvs
parents:
diff changeset
105 (get dialog 'x-verify-entry)))))))
0784d089fdc9 Import from CVS: tag r21-2-46
cvs
parents:
diff changeset
106 (gtk-container-set-border-width vbox 5)
0784d089fdc9 Import from CVS: tag r21-2-46
cvs
parents:
diff changeset
107 (setq widget (gtk-label-new (plist-get keywords :verify-prompt "Verify:")))
0784d089fdc9 Import from CVS: tag r21-2-46
cvs
parents:
diff changeset
108 (gtk-misc-set-alignment widget 0.0 0.5)
0784d089fdc9 Import from CVS: tag r21-2-46
cvs
parents:
diff changeset
109 (gtk-container-add vbox widget)
0784d089fdc9 Import from CVS: tag r21-2-46
cvs
parents:
diff changeset
110
0784d089fdc9 Import from CVS: tag r21-2-46
cvs
parents:
diff changeset
111 (setq widget (gtk-entry-new))
0784d089fdc9 Import from CVS: tag r21-2-46
cvs
parents:
diff changeset
112 (put widget 'visibility nil)
0784d089fdc9 Import from CVS: tag r21-2-46
cvs
parents:
diff changeset
113 (gtk-container-add vbox widget)
0784d089fdc9 Import from CVS: tag r21-2-46
cvs
parents:
diff changeset
114 (put dialog 'x-verify-entry widget)
0784d089fdc9 Import from CVS: tag r21-2-46
cvs
parents:
diff changeset
115
0784d089fdc9 Import from CVS: tag r21-2-46
cvs
parents:
diff changeset
116 (gtk-signal-connect (get dialog 'x-initial-entry)
0784d089fdc9 Import from CVS: tag r21-2-46
cvs
parents:
diff changeset
117 'changed changed-cb dialog)
0784d089fdc9 Import from CVS: tag r21-2-46
cvs
parents:
diff changeset
118 (gtk-signal-connect (get dialog 'x-verify-entry)
0784d089fdc9 Import from CVS: tag r21-2-46
cvs
parents:
diff changeset
119 'changed changed-cb dialog)
0784d089fdc9 Import from CVS: tag r21-2-46
cvs
parents:
diff changeset
120 (gtk-widget-set-sensitive (get dialog 'x-ok-button) nil)))
0784d089fdc9 Import from CVS: tag r21-2-46
cvs
parents:
diff changeset
121
0784d089fdc9 Import from CVS: tag r21-2-46
cvs
parents:
diff changeset
122 (if default
0784d089fdc9 Import from CVS: tag r21-2-46
cvs
parents:
diff changeset
123 (progn
0784d089fdc9 Import from CVS: tag r21-2-46
cvs
parents:
diff changeset
124 (gtk-entry-set-text (get dialog 'x-initial-entry) default)
0784d089fdc9 Import from CVS: tag r21-2-46
cvs
parents:
diff changeset
125 (gtk-entry-select-region (get dialog 'x-initial-entry)
0784d089fdc9 Import from CVS: tag r21-2-46
cvs
parents:
diff changeset
126 0 (length default))))
0784d089fdc9 Import from CVS: tag r21-2-46
cvs
parents:
diff changeset
127 dialog))
0784d089fdc9 Import from CVS: tag r21-2-46
cvs
parents:
diff changeset
128
0784d089fdc9 Import from CVS: tag r21-2-46
cvs
parents:
diff changeset
129 (provide 'gtk-password-dialog)