1# -*- tcl -*-
2#
3# dialog.tcl -
4#
5#	Generic dialog widget (themed)
6#
7# RCS: @(#) $Id: dialog.tcl,v 1.23 2010/06/01 18:06:52 hobbs Exp $
8#
9
10# Creation and Options - widget::dialog $path ...
11#    -command	-default {} ; # gets appended: $win $reason
12#    -focus     -default {} ; # subwindow to set focus on display
13#    -modal	-default none
14#    -padding	-default 0
15#    -parent	-default ""
16#    -place	-default center
17#    -separator	-default 1
18#    -synchronous -default 1
19#    -title	-default ""
20#    -transient -default 1
21#    -type	-default custom ; # {ok okcancel okcancelapply custom}
22#    -timeout	-default 0 ; # only active with -synchronous
23#
24# Methods
25#  $path add $what $args... => $id
26#  $path getframe           => $frame
27#  $path setwidget $widget  => ""
28#  $path display
29#  $path cancel
30#  $path withdraw
31#
32# Bindings
33#  Escape            => invokes [$dlg close cancel]
34#  WM_DELETE_WINDOW  => invokes [$dlg close cancel]
35#
36
37if 0 {
38    # Samples
39    package require widget::dialog
40    set dlg [widget::dialog .pkgerr -modal local -separator 1 \
41		 -place right -parent . -type okcancel \
42		 -title "Dialog Title"]
43    set frame [frame $dlg.f]
44    label $frame.lbl -text "Type Something In:"
45    entry $frame.ent
46    grid $frame.lbl $frame.ent -sticky ew
47    grid columnconfigure $frame 1 -weight 1
48    $dlg setwidget $frame
49    puts [$dlg display]
50    destroy $dlg
51
52    # Using -synchronous with a -type custom dialog requires that the
53    # custom buttons call [$dlg close $reason] to trigger the close
54    set dlg [widget::dialog .pkgerr -title "Yes/No Dialog" -separator 1 \
55		 -parent . -type custom]
56    set frame [frame $dlg.f]
57    label $frame.lbl -text "Type Something In:"
58    entry $frame.ent
59    grid $frame.lbl $frame.ent -sticky ew
60    grid columnconfigure $frame 1 -weight 1
61    $dlg setwidget $frame
62    $dlg add button -text "Yes" -command [list $dlg close yes]
63    $dlg add button -text "No" -command [list $dlg close no]
64    puts [$dlg display]
65}
66
67# ### ######### ###########################
68## Prerequisites
69
70#package require image   ; # bitmaps
71package require snit    ; # object system
72package require msgcat
73
74# ### ######### ###########################
75## Implementation
76
77snit::widget widget::dialog {
78    # ### ######### ###########################
79    hulltype toplevel
80
81    component frame
82    component separator
83    component buttonbox
84
85    delegate option -padding to frame;
86    delegate option * to hull
87    delegate method * to hull
88
89    option -command	-default {};
90    # {none local global}
91    option -modal	-default none -configuremethod C-modal;
92    #option -padding	-default 0 -configuremethod C-padding;
93    option -parent	-default "" -configuremethod C-parent;
94    # {none center left right above below over}
95    option -place	-default center -configuremethod C-place;
96    option -separator	-default 1 -configuremethod C-separator;
97    option -synchronous -default 1;
98    option -title	-default "" -configuremethod C-title;
99    option -transient	-default 1 -configuremethod C-transient;
100    option -type	-default custom -configuremethod C-type;
101    option -timeout	-default 0;
102    option -focus	-default "";
103
104    # We may make this an easier customizable messagebox, but not yet
105    #option -anchor      c; # {n e w s c}
106    #option -text	"";
107    #option -bitmap	"";
108    #option -image	"";
109
110    # ### ######### ###########################
111    ## Public API. Construction
112
113    constructor {args} {
114	wm withdraw $win
115
116	install frame using ttk::frame $win._frame
117	install separator using ttk::separator $win._separator \
118	    -orient horizontal
119	if {[tk windowingsystem] eq "aqua"} {
120	    # left top right bottom - Aqua corner resize control padding
121	    set btnpad [list 0 6 14 4]
122	} else {
123	    # left top right bottom
124	    set btnpad [list 0 6 0 4]
125	}
126	install buttonbox using ttk::frame $win._buttonbox -padding $btnpad
127
128	grid $frame     -row 0 -column 0 -sticky news
129	grid $separator -row 1 -column 0 -sticky ew
130	# Should padding effect the buttonbox?
131	grid $buttonbox -row 2 -column 0 -sticky ew
132
133	grid columnconfigure $win 0 -weight 1
134	grid rowconfigure    $win 0 -weight 1
135
136	# Default to invoking no/cancel/withdraw
137	wm protocol $win WM_DELETE_WINDOW [mymethod close cancel]
138	bind $win <Key-Escape> [mymethod close cancel]
139	# Ensure grab release on unmap?
140	#bind $win <Unmap> [list grab release $win]
141
142	# Handle defaults
143	if {!$options(-separator)} {
144	    grid remove $separator
145	}
146
147	$self configurelist $args
148    }
149
150    # ### ######### ###########################
151    ## Public API. Extend container by application specific content.
152
153    # getframe and setwidget are somewhat mutually exlusive.
154    # Use one or the other.
155    method getframe {} {
156	return $frame
157    }
158
159    method setwidget {w} {
160	if {[winfo exists $setwidget]} {
161	    grid remove $setwidget
162	    set setwidget {}
163	}
164	if {[winfo exists $w]} {
165	    grid $w -in $frame -row 0 -column 0 -sticky news
166	    grid columnconfigure $frame 0 -weight 1
167	    grid rowconfigure    $frame 0 -weight 1
168	    set setwidget $w
169	}
170    }
171
172    variable uid 0
173    method add {what args} {
174	if {$what eq "button"} {
175	    set w [eval [linsert $args 0 ttk::button $buttonbox._b[incr uid]]]
176	} elseif {[winfo exists $what]} {
177	    set w $what
178	} else {
179	    return -code error "unknown add type \"$what\", must be:\
180		button or a pathname"
181	}
182	set col [lindex [grid size $buttonbox] 0]; # get last column
183	if {$col == 0} {
184	    # ensure weighted 0 column
185	    grid columnconfigure $buttonbox 0 -weight 1
186	    incr col
187	}
188	grid $w -row 0 -column $col -sticky ew -padx 4
189	return $w
190    }
191
192    method display {} {
193	set lastFocusGrab [focus]
194	set last [grab current $win]
195	lappend lastFocusGrab $last
196	if {[winfo exists $last]} {
197	    lappend lastFocusGrab [grab status $last]
198	}
199
200	$self PlaceWindow $win $options(-place) $options(-parent)
201	if {$options(-modal) ne "none"} {
202	    if {$options(-modal) eq "global"} {
203		catch {grab -global $win}
204	    } else {
205		catch {grab $win}
206	    }
207	}
208	if {[winfo exists $options(-focus)]} {
209	    catch { focus $options(-focus) }
210	}
211	# In order to allow !custom synchronous, we need to allow
212	# custom dialogs to set [myvar result].  They do that through
213	# [$dlg close $reason]
214	if {$options(-synchronous)} {
215	    if {$options(-timeout) > 0} {
216		# set var after specified timeout
217		set timeout_id [after $options(-timeout) \
218				    [list set [myvar result] timeout]]
219	    }
220	    vwait [myvar result]
221	    catch {after cancel $timeout_id}
222	    # A synchronous dialog will always withdraw, even if a -command
223	    # tries to return a break code.
224	    return [$self withdraw $result]
225	}
226    }
227
228    method close {{reason {}}} {
229	set code 0
230	if {$options(-command) ne ""} {
231	    set cmd $options(-command)
232	    lappend cmd $win $reason
233	    set code [catch {uplevel \#0 $cmd} result]
234	} else {
235	    # set result to trigger any possible vwait
236	    set result $reason
237	}
238	if {$code == 3} {
239	    # 'break' return code - don't withdraw
240	    return $result
241	} else {
242	    # Withdraw on anything but 'break' return code
243	    $self withdraw $result
244	}
245	return -code $code $result
246    }
247
248    method withdraw {{reason "withdraw"}} {
249	set result $reason
250	catch {grab release $win}
251	# Let's avoid focus/grab restore if we don't think we were showing
252	if {![winfo ismapped $win]} { return $reason }
253	wm withdraw $win
254	foreach {oldFocus oldGrab oldStatus} $lastFocusGrab { break }
255	# Ensure last focus/grab wasn't a child of this window
256	if {[winfo exists $oldFocus] && ![string match $win* $oldFocus]} {
257	    catch {focus $oldFocus}
258	}
259	if {[winfo exists $oldGrab] && ![string match $win* $oldGrab]} {
260	    if {$oldStatus eq "global"} {
261		catch {grab -global $oldGrab}
262	    } elseif {$oldStatus eq "local"} {
263		catch {grab $oldGrab}
264	    }
265	}
266	return $result
267    }
268
269    # ### ######### ###########################
270    ## Internal. State variable for close-button (X)
271
272    variable lastFocusGrab {};
273    variable isPlaced 0;
274    variable result {};
275    variable setwidget {};
276
277    # ### ######### ###########################
278    ## Internal. Handle changes to the options.
279
280    method C-title {option value} {
281	wm title $win $value
282	wm iconname $win $value
283        set options($option) $value
284    }
285    method C-modal {option value} {
286	set values [list none local global]
287	if {[lsearch -exact $values $value] == -1} {
288	    return -code error "unknown $option option \"$value\":\
289		must be one of [join $values {, }]"
290	}
291        set options($option) $value
292    }
293    method C-separator {option value} {
294	if {$value} {
295	    grid $separator
296	} else {
297	    grid remove $separator
298	}
299        set options($option) $value
300    }
301    method C-parent {option value} {
302	if {$options(-transient) && [winfo exists $value]} {
303	    wm transient $win [winfo toplevel $value]
304	    wm group $win [winfo toplevel $value]
305	} else {
306	    wm transient $win ""
307	    wm group $win ""
308	}
309        set options($option) $value
310    }
311    method C-transient {option value} {
312	if {$value && [winfo exists $options(-parent)]} {
313	    wm transient $win [winfo toplevel $options(-parent)]
314	    wm group $win [winfo toplevel $options(-parent)]
315	} else {
316	    wm transient $win ""
317	    wm group $win ""
318	}
319        set options($option) $value
320    }
321    method C-place {option value} {
322	set values [list none center left right over above below pointer]
323	if {[lsearch -exact $values $value] == -1} {
324	    return -code error "unknown $option option \"$value\":\
325		must be one of [join $values {, }]"
326	}
327	set isPlaced 0
328        set options($option) $value
329    }
330    method C-type {option value} {
331	set types [list ok okcancel okcancelapply custom]
332	# ok
333	# okcancel
334	# okcancelapply
335	# custom
336	# msgcat
337
338	if {$options(-type) eq $value} { return }
339	if {[lsearch -exact $types $value] == -1} {
340	    return -code error "invalid type \"$value\", must be one of:\
341		[join $types {, }]"
342	}
343	if {$options(-type) ne "custom"} {
344	    # Just trash whatever we had
345	    eval [list destroy] [winfo children $buttonbox]
346	}
347
348	set ok     [msgcat::mc "OK"]
349	set cancel [msgcat::mc "Cancel"]
350	set apply  [msgcat::mc "Apply"]
351	set okBtn  [ttk::button $buttonbox.ok -text $ok -default active \
352			-command [mymethod close ok]]
353	set canBtn [ttk::button $buttonbox.cancel -text $cancel \
354			-command [mymethod close cancel]]
355	set appBtn [ttk::button $buttonbox.apply -text $apply \
356			-command [mymethod close apply]]
357
358	# [OK] [Cancel] [Apply]
359	grid x $okBtn $canBtn $appBtn -padx 4
360	grid columnconfigure $buttonbox 0 -weight 1
361	#bind $win <Return> [list $okBtn invoke]
362	#bind $win <Escape> [list $canBtn invoke]
363	if {$value eq "ok"} {
364	    grid remove $canBtn $appBtn
365	} elseif {$value eq "okcancel"} {
366	    grid remove $appBtn
367	}
368        set options($option) $value
369    }
370
371    # ### ######### ###########################
372    ## Internal.
373
374    method PlaceWindow {w place anchor} {
375	# Variation of tk::PlaceWindow
376	if {$isPlaced || $place eq "none"} {
377	    # For most options, we place once and then just deiconify
378	    wm deiconify $w
379	    raise $w
380	    return
381	}
382	set isPlaced 1
383	if {$place eq "pointer"} {
384	    # pointer placement occurs each time, centered
385	    set anchor center
386	    set isPlaced 0
387	} elseif {![winfo exists $anchor]} {
388	    set anchor [winfo toplevel [winfo parent $w]]
389	    if {![winfo ismapped $anchor]} {
390		set place center
391	    }
392	}
393	wm withdraw $w
394	update idletasks
395	set checkBounds 1
396	if {$place eq "center"} {
397	    set x [expr {([winfo screenwidth $w]-[winfo reqwidth $w])/2}]
398	    set y [expr {([winfo screenheight $w]-[winfo reqheight $w])/2}]
399	    set checkBounds 0
400	} elseif {$place eq "pointer"} {
401	    ## place at POINTER (centered)
402	    if {$anchor eq "center"} {
403		set x [expr {[winfo pointerx $w]-[winfo reqwidth $w]/2}]
404		set y [expr {[winfo pointery $w]-[winfo reqheight $w]/2}]
405	    } else {
406		set x [winfo pointerx $w]
407		set y [winfo pointery $w]
408	    }
409	} elseif {![winfo ismapped $anchor]} {
410	    ## All the rest require the anchor to be mapped
411	    ## If the anchor isn't mapped, use center
412	    set x [expr {([winfo screenwidth $w]-[winfo reqwidth $w])/2}]
413	    set y [expr {([winfo screenheight $w]-[winfo reqheight $w])/2}]
414	    set checkBounds 0
415	} elseif {$place eq "over"} {
416	    ## center about WIDGET $anchor
417	    set x [expr {[winfo rootx $anchor] + \
418			     ([winfo width $anchor]-[winfo reqwidth $w])/2}]
419	    set y [expr {[winfo rooty $anchor] + \
420			     ([winfo height $anchor]-[winfo reqheight $w])/2}]
421	} elseif {$place eq "above"} {
422	    ## above (north of) WIDGET $anchor, centered
423	    set x [expr {[winfo rootx $anchor] + \
424			     ([winfo width $anchor]-[winfo reqwidth $w])/2}]
425	    set y [expr {[winfo rooty $anchor] - [winfo reqheight $w]}]
426	} elseif {$place eq "below"} {
427	    ## below WIDGET $anchor, centered
428	    set x [expr {[winfo rootx $anchor] + \
429			     ([winfo width $anchor]-[winfo reqwidth $w])/2}]
430	    set y [expr {[winfo rooty $anchor] + [winfo height $anchor]}]
431	} elseif {$place eq "left"} {
432	    ## left of WIDGET $anchor, top-aligned
433	    set x [expr {[winfo rootx $anchor] - [winfo reqwidth $w]}]
434	    set y [winfo rooty $anchor]
435	} elseif {$place eq "right"} {
436	    ## right of WIDGET $anchor, top-aligned
437	    set x [expr {[winfo rootx $anchor] + [winfo width $anchor]}]
438	    set y [winfo rooty $anchor]
439	} else {
440	    return -code error "unknown place type \"$place\""
441	}
442	if {[tk windowingsystem] eq "win32"} {
443	    # win32 multiple desktops may produce negative geometry - avoid.
444	    set checkBounds -1
445	}
446	if {$checkBounds} {
447	    if {$x < 0 && $checkBounds > 0} {
448		set x 0
449	    } elseif {$x > ([winfo screenwidth $w]-[winfo reqwidth $w])} {
450		set x [expr {[winfo screenwidth $w]-[winfo reqwidth $w]}]
451	    }
452	    if {$y < 0 && $checkBounds > 0} {
453		set y 0
454	    } elseif {$y > ([winfo screenheight $w]-[winfo reqheight $w])} {
455		set y [expr {[winfo screenheight $w]-[winfo reqheight $w]}]
456	    }
457	    if {[tk windowingsystem] eq "aqua"} {
458		# Avoid the native menu bar which sits on top of everything.
459		if {$y < 20} { set y 20 }
460	    }
461	}
462	wm geometry $w +$x+$y
463	wm deiconify $w
464	raise $w
465    }
466
467    # ### ######### ###########################
468}
469
470# ### ######### ###########################
471## Ready for use
472
473package provide widget::dialog 1.3.1
474