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