1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
|
# dialog.tcl --
#
# This file defines the procedure tk_dialog, which creates a dialog
# box containing a bitmap, a message, and one or more buttons.
#
# RCS: @(#) $Id: dialog.tcl,v 1.7 2000/01/12 11:45:14 hobbs Exp $
#
# Copyright (c) 1992-1993 The Regents of the University of California.
# Copyright (c) 1994-1997 Sun Microsystems, Inc.
#
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
#
#
# tk_dialog:
#
# This procedure displays a dialog box, waits for a button in the dialog
# to be invoked, then returns the index of the selected button. If the
# dialog somehow gets destroyed, -1 is returned.
#
# Arguments:
# w - Window to use for dialog top-level.
# title - Title to display in dialog's decorative frame.
# text - Message to display in dialog.
# bitmap - Bitmap to display in dialog (empty string means none).
# default - Index of button that is to display the default ring
# (-1 means none).
# args - One or more strings to display in buttons across the
# bottom of the dialog box.
proc tk_dialog {w title text bitmap default args} {
global tkPriv tcl_platform
# Check that $default was properly given
if {[string is int $default]} {
if {$default >= [llength $args]} {
return -code error "default button index greater than number of\
buttons specified for tk_dialog"
}
} elseif {[string equal {} $default]} {
set default -1
} else {
set default [lsearch -exact $args $default]
}
# 1. Create the top-level window and divide it into top
# and bottom parts.
catch {destroy $w}
toplevel $w -class Dialog
wm title $w $title
wm iconname $w Dialog
wm protocol $w WM_DELETE_WINDOW { }
# The following command means that the dialog won't be posted if
# [winfo parent $w] is iconified, but it's really needed; otherwise
# the dialog can become obscured by other windows in the application,
# even though its grab keeps the rest of the application from being used.
wm transient $w [winfo toplevel [winfo parent $w]]
if {[string equal $tcl_platform(platform) "macintosh"]} {
unsupported1 style $w dBoxProc
}
frame $w.bot
frame $w.top
if {[string equal $tcl_platform(platform) "unix"]} {
$w.bot configure -relief raised -bd 1
$w.top configure -relief raised -bd 1
}
pack $w.bot -side bottom -fill both
pack $w.top -side top -fill both -expand 1
# 2. Fill the top part with bitmap and message (use the option
# database for -wraplength and -font so that they can be
# overridden by the caller).
option add *Dialog.msg.wrapLength 3i widgetDefault
if {[string equal $tcl_platform(platform) "macintosh"]} {
option add *Dialog.msg.font system widgetDefault
} else {
option add *Dialog.msg.font {Times 12} widgetDefault
}
label $w.msg -justify left -text $text
pack $w.msg -in $w.top -side right -expand 1 -fill both -padx 3m -pady 3m
if {[string compare $bitmap ""]} {
if {[string equal $tcl_platform(platform) "macintosh"] && \
[string equal $bitmap "error"]} {
set bitmap "stop"
}
label $w.bitmap -bitmap $bitmap
pack $w.bitmap -in $w.top -side left -padx 3m -pady 3m
}
# 3. Create a row of buttons at the bottom of the dialog.
set i 0
foreach but $args {
button $w.button$i -text $but -command [list set tkPriv(button) $i]
if {$i == $default} {
$w.button$i configure -default active
} else {
$w.button$i configure -default normal
}
grid $w.button$i -in $w.bot -column $i -row 0 -sticky ew -padx 10
grid columnconfigure $w.bot $i
# We boost the size of some Mac buttons for l&f
if {[string equal $tcl_platform(platform) "macintosh"]} {
set tmp [string tolower $but]
if {[string equal $tmp "ok"] || [string equal $tmp "cancel"]} {
grid columnconfigure $w.bot $i -minsize [expr {59 + 20}]
}
}
incr i
}
# 4. Create a binding for <Return> on the dialog if there is a
# default button.
if {$default >= 0} {
bind $w <Return> "
[list $w.button$default] configure -state active -relief sunken
update idletasks
after 100
set tkPriv(button) $default
"
}
# 5. Create a <Destroy> binding for the window that sets the
# button variable to -1; this is needed in case something happens
# that destroys the window, such as its parent window being destroyed.
bind $w <Destroy> {set tkPriv(button) -1}
# 6. Withdraw the window, then update all the geometry information
# so we know how big it wants to be, then center the window in the
# display and de-iconify it.
wm withdraw $w
update idletasks
set x [expr {[winfo screenwidth $w]/2 - [winfo reqwidth $w]/2 \
- [winfo vrootx [winfo parent $w]]}]
set y [expr {[winfo screenheight $w]/2 - [winfo reqheight $w]/2 \
- [winfo vrooty [winfo parent $w]]}]
wm geom $w +$x+$y
wm deiconify $w
# 7. Set a grab and claim the focus too.
set oldFocus [focus]
set oldGrab [grab current $w]
if {[string compare $oldGrab ""]} {
set grabStatus [grab status $oldGrab]
}
grab $w
if {$default >= 0} {
focus $w.button$default
} else {
focus $w
}
# 8. Wait for the user to respond, then restore the focus and
# return the index of the selected button. Restore the focus
# before deleting the window, since otherwise the window manager
# may take the focus away so we can't redirect it. Finally,
# restore any grab that was in effect.
tkwait variable tkPriv(button)
catch {focus $oldFocus}
catch {
# It's possible that the window has already been destroyed,
# hence this "catch". Delete the Destroy handler so that
# tkPriv(button) doesn't get reset by it.
bind $w <Destroy> {}
destroy $w
}
if {[string compare $oldGrab ""]} {
if {[string compare $grabStatus "global"]} {
grab $oldGrab
} else {
grab -global $oldGrab
}
}
return $tkPriv(button)
}
|
