annotate lisp/gtk-password-dialog.el @ 5170:5ddbab03b0e6

various fixes to memory-usage stats -------------------- ChangeLog entries follow: -------------------- lisp/ChangeLog addition: 2010-03-25 Ben Wing <ben@xemacs.org> * diagnose.el (show-memory-usage): * diagnose.el (show-object-memory-usage-stats): Further changes to correspond with changes in the C code; add an additional column in show-object-memory-usage-stats showing the ancillary Lisp overhead used with each type; shrink columns for windows in show-memory-usage to get it to fit in 79 chars. src/ChangeLog addition: 2010-03-25 Ben Wing <ben@xemacs.org> * alloc.c: * alloc.c (struct): * alloc.c (finish_object_memory_usage_stats): * alloc.c (object_memory_usage_stats): * alloc.c (Fobject_memory_usage): * alloc.c (lisp_object_memory_usage_full): * alloc.c (compute_memusage_stats_length): * lrecord.h: * lrecord.h (struct lrecord_implementation): Add fields to the `lrecord_implementation' structure to list an offset into the array of extra statistics in a `struct generic_usage_stats' and a length, listing the first slice of ancillary Lisp-object memory. Compute automatically in compute_memusage_stats_length(). Use to add an entry `FOO-lisp-ancillary-storage' for object type FOO. Don't crash when an int or char is given to object-memory-usage, signal an error instead. Add functions lisp_object_memory_usage_full() and lisp_object_memory_usage() to compute the total memory usage of an object (sum of object, non-Lisp attached, and Lisp ancillary memory). * array.c: * array.c (gap_array_memory_usage): * array.h: Add function to return memory usage of a gap array. * buffer.c (struct buffer_stats): * buffer.c (compute_buffer_usage): * buffer.c (vars_of_buffer): * extents.c (compute_buffer_extent_usage): * marker.c: * marker.c (compute_buffer_marker_usage): * extents.h: * lisp.h: Remove `struct usage_stats' arg from compute_buffer_marker_usage() and compute_buffer_extent_usage() -- these are ancillary Lisp objects and don't get accumulated into `struct usage_stats'; change the value of `memusage_stats_list' so that `markers' and `extents' memory is in Lisp-ancillary, where it belongs. In compute_buffer_marker_usage(), use lisp_object_memory_usage() rather than lisp_object_storage_size(). * casetab.c: * casetab.c (case_table_memory_usage): * casetab.c (vars_of_casetab): * emacs.c (main_1): Add memory usage stats for case tables. * lisp.h: Add comment explaining the `struct generic_usage_stats' more, as well as the new fields in lrecord_implementation. * console-impl.h: * console-impl.h (struct console_methods): * scrollbar-gtk.c: * scrollbar-gtk.c (gtk_compute_scrollbar_instance_usage): * scrollbar-msw.c: * scrollbar-msw.c (mswindows_compute_scrollbar_instance_usage): * scrollbar-x.c: * scrollbar-x.c (x_compute_scrollbar_instance_usage): * scrollbar.c: * scrollbar.c (struct scrollbar_instance_stats): * scrollbar.c (compute_all_scrollbar_instance_usage): * scrollbar.c (scrollbar_instance_memory_usage): * scrollbar.c (scrollbar_objects_create): * scrollbar.c (vars_of_scrollbar): * scrollbar.h: * symsinit.h: * window.c: * window.c (find_window_mirror_maybe): * window.c (struct window_mirror_stats): * window.c (compute_window_mirror_usage): * window.c (window_mirror_memory_usage): * window.c (compute_window_usage): * window.c (window_objects_create): * window.c (syms_of_window): * window.c (vars_of_window): Redo memory-usage associated with windows, window mirrors, and scrollbar instances. Should fix crash in find_window_mirror, among other things. Properly assign memo ry to object memory, non-Lisp extra memory, and Lisp ancillary memory. For example, redisplay structures are non-Lisp memory hanging off a window mirror, not a window; make it an ancillary Lisp-object field. Window mirrors and scrollbar instances have their own statistics, among other things.
author Ben Wing <ben@xemacs.org>
date Thu, 25 Mar 2010 06:07:25 -0500
parents 7039e6323819
children 308d34e9f07d
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
0784d089fdc9 Import from CVS: tag r21-2-46
cvs
parents:
diff changeset
10 ;; XEmacs is free software; you can redistribute it and/or modify it
0784d089fdc9 Import from CVS: tag r21-2-46
cvs
parents:
diff changeset
11 ;; under the terms of the GNU General Public License as published by
0784d089fdc9 Import from CVS: tag r21-2-46
cvs
parents:
diff changeset
12 ;; the Free Software Foundation; either version 2, or (at your option)
0784d089fdc9 Import from CVS: tag r21-2-46
cvs
parents:
diff changeset
13 ;; any later version.
0784d089fdc9 Import from CVS: tag r21-2-46
cvs
parents:
diff changeset
14
0784d089fdc9 Import from CVS: tag r21-2-46
cvs
parents:
diff changeset
15 ;; XEmacs is distributed in the hope that it will be useful, but
0784d089fdc9 Import from CVS: tag r21-2-46
cvs
parents:
diff changeset
16 ;; WITHOUT ANY WARRANTY; without even the implied warranty of
0784d089fdc9 Import from CVS: tag r21-2-46
cvs
parents:
diff changeset
17 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
0784d089fdc9 Import from CVS: tag r21-2-46
cvs
parents:
diff changeset
18 ;; General Public License for more details.
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
0784d089fdc9 Import from CVS: tag r21-2-46
cvs
parents:
diff changeset
21 ;; along with XEmacs; see the file COPYING. If not, write to the
0784d089fdc9 Import from CVS: tag r21-2-46
cvs
parents:
diff changeset
22 ;; Free Software Foundation, 59 Temple Place - Suite 330,
0784d089fdc9 Import from CVS: tag r21-2-46
cvs
parents:
diff changeset
23 ;; Boston, MA 02111-1307, USA.
0784d089fdc9 Import from CVS: tag r21-2-46
cvs
parents:
diff changeset
24
0784d089fdc9 Import from CVS: tag r21-2-46
cvs
parents:
diff changeset
25 ;;; Synched up with: Not in FSF.
0784d089fdc9 Import from CVS: tag r21-2-46
cvs
parents:
diff changeset
26
502
7039e6323819 [xemacs-hg @ 2001-05-04 22:41:46 by ben]
ben
parents: 462
diff changeset
27 (globally-declare-fboundp
7039e6323819 [xemacs-hg @ 2001-05-04 22:41:46 by ben]
ben
parents: 462
diff changeset
28 '(gtk-dialog-new
7039e6323819 [xemacs-hg @ 2001-05-04 22:41:46 by ben]
ben
parents: 462
diff changeset
29 gtk-dialog-vbox gtk-dialog-action-area
7039e6323819 [xemacs-hg @ 2001-05-04 22:41:46 by ben]
ben
parents: 462
diff changeset
30 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
31 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
32 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
33 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
34 gtk-entry-set-text gtk-entry-select-region))
7039e6323819 [xemacs-hg @ 2001-05-04 22:41:46 by ben]
ben
parents: 462
diff changeset
35
462
0784d089fdc9 Import from CVS: tag r21-2-46
cvs
parents:
diff changeset
36 (defun gtk-password-dialog-ok-button (dlg)
0784d089fdc9 Import from CVS: tag r21-2-46
cvs
parents:
diff changeset
37 (get dlg 'x-ok-button))
0784d089fdc9 Import from CVS: tag r21-2-46
cvs
parents:
diff changeset
38
0784d089fdc9 Import from CVS: tag r21-2-46
cvs
parents:
diff changeset
39 (defun gtk-password-dialog-cancel-button (dlg)
0784d089fdc9 Import from CVS: tag r21-2-46
cvs
parents:
diff changeset
40 (get dlg 'x-cancel-button))
0784d089fdc9 Import from CVS: tag r21-2-46
cvs
parents:
diff changeset
41
0784d089fdc9 Import from CVS: tag r21-2-46
cvs
parents:
diff changeset
42 (defun gtk-password-dialog-entry-widget (dlg)
0784d089fdc9 Import from CVS: tag r21-2-46
cvs
parents:
diff changeset
43 (get dlg 'x-initial-entry))
0784d089fdc9 Import from CVS: tag r21-2-46
cvs
parents:
diff changeset
44
0784d089fdc9 Import from CVS: tag r21-2-46
cvs
parents:
diff changeset
45 (defun gtk-password-dialog-confirmation-widget (dlg)
0784d089fdc9 Import from CVS: tag r21-2-46
cvs
parents:
diff changeset
46 (get dlg 'x-verify-entry))
0784d089fdc9 Import from CVS: tag r21-2-46
cvs
parents:
diff changeset
47
0784d089fdc9 Import from CVS: tag r21-2-46
cvs
parents:
diff changeset
48 (defun gtk-password-dialog-new (&rest keywords)
0784d089fdc9 Import from CVS: tag r21-2-46
cvs
parents:
diff changeset
49 ;; Format is (:keyword value ...)
0784d089fdc9 Import from CVS: tag r21-2-46
cvs
parents:
diff changeset
50 ;; Allowed keywords are:
0784d089fdc9 Import from CVS: tag r21-2-46
cvs
parents:
diff changeset
51 ;;
0784d089fdc9 Import from CVS: tag r21-2-46
cvs
parents:
diff changeset
52 ;; :callback function
0784d089fdc9 Import from CVS: tag r21-2-46
cvs
parents:
diff changeset
53 ;; :default string
0784d089fdc9 Import from CVS: tag r21-2-46
cvs
parents:
diff changeset
54 ;; :title string
0784d089fdc9 Import from CVS: tag r21-2-46
cvs
parents:
diff changeset
55 :; :prompt string
0784d089fdc9 Import from CVS: tag r21-2-46
cvs
parents:
diff changeset
56 ;; :default string
0784d089fdc9 Import from CVS: tag r21-2-46
cvs
parents:
diff changeset
57 ;; :verify boolean
0784d089fdc9 Import from CVS: tag r21-2-46
cvs
parents:
diff changeset
58 ;; :verify-prompt string
0784d089fdc9 Import from CVS: tag r21-2-46
cvs
parents:
diff changeset
59 (let* ((callback (plist-get keywords :callback 'ignore))
0784d089fdc9 Import from CVS: tag r21-2-46
cvs
parents:
diff changeset
60 (dialog (gtk-dialog-new))
0784d089fdc9 Import from CVS: tag r21-2-46
cvs
parents:
diff changeset
61 (vbox (gtk-dialog-vbox dialog))
0784d089fdc9 Import from CVS: tag r21-2-46
cvs
parents:
diff changeset
62 (button-area (gtk-dialog-action-area dialog))
0784d089fdc9 Import from CVS: tag r21-2-46
cvs
parents:
diff changeset
63 (default (plist-get keywords :default))
0784d089fdc9 Import from CVS: tag r21-2-46
cvs
parents:
diff changeset
64 (widget nil))
0784d089fdc9 Import from CVS: tag r21-2-46
cvs
parents:
diff changeset
65 (gtk-window-set-title dialog (plist-get keywords :title "Enter password..."))
0784d089fdc9 Import from CVS: tag r21-2-46
cvs
parents:
diff changeset
66
0784d089fdc9 Import from CVS: tag r21-2-46
cvs
parents:
diff changeset
67 ;; Make us modal...
0784d089fdc9 Import from CVS: tag r21-2-46
cvs
parents:
diff changeset
68 (put dialog 'type 'dialog)
0784d089fdc9 Import from CVS: tag r21-2-46
cvs
parents:
diff changeset
69
0784d089fdc9 Import from CVS: tag r21-2-46
cvs
parents:
diff changeset
70 ;; Put the buttons in the bottom
0784d089fdc9 Import from CVS: tag r21-2-46
cvs
parents:
diff changeset
71 (setq widget (gtk-button-new-with-label "OK"))
0784d089fdc9 Import from CVS: tag r21-2-46
cvs
parents:
diff changeset
72 (gtk-container-add button-area widget)
0784d089fdc9 Import from CVS: tag r21-2-46
cvs
parents:
diff changeset
73 (gtk-signal-connect widget 'clicked
0784d089fdc9 Import from CVS: tag r21-2-46
cvs
parents:
diff changeset
74 (lambda (button data)
0784d089fdc9 Import from CVS: tag r21-2-46
cvs
parents:
diff changeset
75 (funcall (car data)
0784d089fdc9 Import from CVS: tag r21-2-46
cvs
parents:
diff changeset
76 (gtk-entry-get-text
0784d089fdc9 Import from CVS: tag r21-2-46
cvs
parents:
diff changeset
77 (get (cdr data) 'x-initial-entry))))
0784d089fdc9 Import from CVS: tag r21-2-46
cvs
parents:
diff changeset
78 (cons callback dialog))
0784d089fdc9 Import from CVS: tag r21-2-46
cvs
parents:
diff changeset
79 (put dialog 'x-ok-button widget)
0784d089fdc9 Import from CVS: tag r21-2-46
cvs
parents:
diff changeset
80
0784d089fdc9 Import from CVS: tag r21-2-46
cvs
parents:
diff changeset
81 (setq widget (gtk-button-new-with-label "Cancel"))
0784d089fdc9 Import from CVS: tag r21-2-46
cvs
parents:
diff changeset
82 (gtk-container-add button-area widget)
0784d089fdc9 Import from CVS: tag r21-2-46
cvs
parents:
diff changeset
83 (gtk-signal-connect widget 'clicked
0784d089fdc9 Import from CVS: tag r21-2-46
cvs
parents:
diff changeset
84 (lambda (button dialog)
0784d089fdc9 Import from CVS: tag r21-2-46
cvs
parents:
diff changeset
85 (gtk-widget-destroy dialog))
0784d089fdc9 Import from CVS: tag r21-2-46
cvs
parents:
diff changeset
86 dialog)
0784d089fdc9 Import from CVS: tag r21-2-46
cvs
parents:
diff changeset
87 (put dialog 'x-cancel-button widget)
0784d089fdc9 Import from CVS: tag r21-2-46
cvs
parents:
diff changeset
88
0784d089fdc9 Import from CVS: tag r21-2-46
cvs
parents:
diff changeset
89 ;; Now the entry area...
0784d089fdc9 Import from CVS: tag r21-2-46
cvs
parents:
diff changeset
90 (gtk-container-set-border-width vbox 5)
0784d089fdc9 Import from CVS: tag r21-2-46
cvs
parents:
diff changeset
91 (setq widget (gtk-label-new (plist-get keywords :prompt "Password:")))
0784d089fdc9 Import from CVS: tag r21-2-46
cvs
parents:
diff changeset
92 (gtk-misc-set-alignment widget 0.0 0.5)
0784d089fdc9 Import from CVS: tag r21-2-46
cvs
parents:
diff changeset
93 (gtk-container-add vbox widget)
0784d089fdc9 Import from CVS: tag r21-2-46
cvs
parents:
diff changeset
94
0784d089fdc9 Import from CVS: tag r21-2-46
cvs
parents:
diff changeset
95 (setq widget (gtk-entry-new))
0784d089fdc9 Import from CVS: tag r21-2-46
cvs
parents:
diff changeset
96 (put widget 'visibility nil)
0784d089fdc9 Import from CVS: tag r21-2-46
cvs
parents:
diff changeset
97 (gtk-container-add vbox widget)
0784d089fdc9 Import from CVS: tag r21-2-46
cvs
parents:
diff changeset
98 (put dialog 'x-initial-entry widget)
0784d089fdc9 Import from CVS: tag r21-2-46
cvs
parents:
diff changeset
99
0784d089fdc9 Import from CVS: tag r21-2-46
cvs
parents:
diff changeset
100 (if (plist-get keywords :verify)
0784d089fdc9 Import from CVS: tag r21-2-46
cvs
parents:
diff changeset
101 (let ((changed-cb (lambda (editable dialog)
0784d089fdc9 Import from CVS: tag r21-2-46
cvs
parents:
diff changeset
102 (gtk-widget-set-sensitive
0784d089fdc9 Import from CVS: tag r21-2-46
cvs
parents:
diff changeset
103 (get dialog 'x-ok-button)
0784d089fdc9 Import from CVS: tag r21-2-46
cvs
parents:
diff changeset
104 (equal (gtk-entry-get-text
0784d089fdc9 Import from CVS: tag r21-2-46
cvs
parents:
diff changeset
105 (get dialog 'x-initial-entry))
0784d089fdc9 Import from CVS: tag r21-2-46
cvs
parents:
diff changeset
106 (gtk-entry-get-text
0784d089fdc9 Import from CVS: tag r21-2-46
cvs
parents:
diff changeset
107 (get dialog 'x-verify-entry)))))))
0784d089fdc9 Import from CVS: tag r21-2-46
cvs
parents:
diff changeset
108 (gtk-container-set-border-width vbox 5)
0784d089fdc9 Import from CVS: tag r21-2-46
cvs
parents:
diff changeset
109 (setq widget (gtk-label-new (plist-get keywords :verify-prompt "Verify:")))
0784d089fdc9 Import from CVS: tag r21-2-46
cvs
parents:
diff changeset
110 (gtk-misc-set-alignment widget 0.0 0.5)
0784d089fdc9 Import from CVS: tag r21-2-46
cvs
parents:
diff changeset
111 (gtk-container-add vbox widget)
0784d089fdc9 Import from CVS: tag r21-2-46
cvs
parents:
diff changeset
112
0784d089fdc9 Import from CVS: tag r21-2-46
cvs
parents:
diff changeset
113 (setq widget (gtk-entry-new))
0784d089fdc9 Import from CVS: tag r21-2-46
cvs
parents:
diff changeset
114 (put widget 'visibility nil)
0784d089fdc9 Import from CVS: tag r21-2-46
cvs
parents:
diff changeset
115 (gtk-container-add vbox widget)
0784d089fdc9 Import from CVS: tag r21-2-46
cvs
parents:
diff changeset
116 (put dialog 'x-verify-entry widget)
0784d089fdc9 Import from CVS: tag r21-2-46
cvs
parents:
diff changeset
117
0784d089fdc9 Import from CVS: tag r21-2-46
cvs
parents:
diff changeset
118 (gtk-signal-connect (get dialog 'x-initial-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-signal-connect (get dialog 'x-verify-entry)
0784d089fdc9 Import from CVS: tag r21-2-46
cvs
parents:
diff changeset
121 'changed changed-cb dialog)
0784d089fdc9 Import from CVS: tag r21-2-46
cvs
parents:
diff changeset
122 (gtk-widget-set-sensitive (get dialog 'x-ok-button) nil)))
0784d089fdc9 Import from CVS: tag r21-2-46
cvs
parents:
diff changeset
123
0784d089fdc9 Import from CVS: tag r21-2-46
cvs
parents:
diff changeset
124 (if default
0784d089fdc9 Import from CVS: tag r21-2-46
cvs
parents:
diff changeset
125 (progn
0784d089fdc9 Import from CVS: tag r21-2-46
cvs
parents:
diff changeset
126 (gtk-entry-set-text (get dialog 'x-initial-entry) default)
0784d089fdc9 Import from CVS: tag r21-2-46
cvs
parents:
diff changeset
127 (gtk-entry-select-region (get dialog 'x-initial-entry)
0784d089fdc9 Import from CVS: tag r21-2-46
cvs
parents:
diff changeset
128 0 (length default))))
0784d089fdc9 Import from CVS: tag r21-2-46
cvs
parents:
diff changeset
129 dialog))
0784d089fdc9 Import from CVS: tag r21-2-46
cvs
parents:
diff changeset
130
0784d089fdc9 Import from CVS: tag r21-2-46
cvs
parents:
diff changeset
131 (provide 'gtk-password-dialog)