1#
2# $Id: dialog.tcl,v 1.6 2007/07/10 21:53:26 jenglish Exp $
3#
4# Copyright (c) 2005, Joe English.  Freely redistributable.
5#
6# Tile widget set: dialog boxes.
7#
8# TODO: option to keep dialog onscreen ("persistent" / "transient")
9# TODO: accelerator keys.
10# TODO: use message catalogs for button labels
11# TODO: routines to selectively enable/disable individual command buttons
12# TODO: use megawidgetoid API [$dlg dismiss] vs. [ttk::dialog::dismiss $dlg]
13# TODO: MAYBE: option for app-modal dialogs
14# TODO: MAYBE: [wm withdraw] dialog on dismiss instead of self-destructing
15#
16
17package provide ttk::dialog 0.8
18package require msgcat
19package require keynav
20
21namespace eval ttk::dialog {
22
23    variable Config
24    #
25    # Spacing parameters:
26    # (taken from GNOME HIG 2.0, may need adjustment for other platforms)
27    # (textwidth just a guess)
28    #
29    set Config(margin)		12	;# space between icon and text
30    set Config(interspace)	6	;# horizontal space between buttons
31    set Config(sepspace) 	24	;# vertical space above buttons
32    set Config(textwidth) 	400	;# width of dialog box text (pixels)
33
34    variable DialogTypes	;# map -type => list of dialog options
35    variable ButtonOptions	;# map button name => list of button options
36
37    # stockButton -- define new built-in button
38    #
39    proc stockButton {button args} {
40	variable ButtonOptions
41	set ButtonOptions($button) $args
42    }
43
44    # Built-in button types:
45    #
46    foreach button {OK Cancel Yes No Retry} {
47        set text [namespace eval ::tk "msgcat::mc &$button"]
48        set index [string first & $text]
49        regsub {&} $text {} text
50        stockButton [string tolower $button] -underline $index \
51            -text $text
52     }
53
54    # stockDialog -- define new dialog type.
55    #
56    proc stockDialog {type args} {
57	variable DialogTypes
58	set DialogTypes($type) $args
59    }
60
61    # Built-in dialog types:
62    #
63    stockDialog ok \
64	-icon info -buttons {ok} -default ok
65    stockDialog okcancel \
66	-icon info -buttons {ok cancel} -default ok -cancel cancel
67    stockDialog retrycancel \
68	-icon question -buttons {retry cancel} -cancel cancel
69    stockDialog yesno \
70	-icon question -buttons {yes no}
71    stockDialog yesnocancel \
72	-icon question -buttons {yes no cancel} -cancel cancel
73}
74
75## ttk::dialog::nop --
76#	Do nothing (used as a default callback command).
77#
78proc ttk::dialog::nop {args} { }
79
80## ttk::dialog -- dialog box constructor.
81#
82interp alias {} ttk::dialog {} ttk::dialog::Constructor
83
84proc ttk::dialog::Constructor {dlg args} {
85    upvar #0 $dlg D
86    variable Config
87    variable ButtonOptions
88    variable DialogTypes
89
90    #
91    # Option processing:
92    #
93    array set defaults {
94	-title 		""
95    	-message	""
96	-detail		""
97	-command	ttk::dialog::nop
98	-icon 		""
99	-buttons 	{}
100	-labels 	{}
101	-default 	{}
102	-cancel		{}
103	-parent		#AUTO
104    }
105
106    array set options [array get defaults]
107
108    foreach {option value} $args {
109	if {$option eq "-type"} {
110	    array set options $DialogTypes($value)
111	} elseif {![info exists options($option)]} {
112	    set validOptions [join [lsort [array names options]] ", "]
113	    return -code error \
114	    	"Illegal option $option: must be one of $validOptions"
115	}
116    }
117    array set options $args
118
119    # ...
120    #
121    array set buttonOptions [array get ::ttk::dialog::ButtonOptions]
122    foreach {button label} $options(-labels) {
123	lappend buttonOptions($button) -text $label
124    }
125
126    #
127    # Initialize dialog private data:
128    #
129    foreach option {-command -message -detail} {
130	set D($option) $options($option)
131    }
132
133    toplevel $dlg -class Dialog; wm withdraw $dlg
134
135    #
136    # Determine default transient parent.
137    #
138    # NB: menus (including menubars) are considered toplevels,
139    # so skip over those.
140    #
141    if {$options(-parent) eq "#AUTO"} {
142	set parent [winfo toplevel [winfo parent $dlg]]
143	while {[winfo class $parent] eq "Menu" && $parent ne "."} {
144	    set parent [winfo toplevel [winfo parent $parent]]
145	}
146	set options(-parent) $parent
147    }
148
149    #
150    # Build dialog:
151    #
152    if {$options(-parent) ne ""} {
153    	wm transient $dlg $options(-parent)
154    }
155    wm title $dlg $options(-title)
156    wm protocol $dlg WM_DELETE_WINDOW { }
157
158    set f [ttk::frame $dlg.f]
159
160    ttk::label $f.icon
161    if {$options(-icon) ne ""} {
162	$f.icon configure -image [ttk::stockIcon dialog/$options(-icon)]
163    }
164    ttk::label $f.message -textvariable ${dlg}(-message) \
165    	-font TkCaptionFont -wraplength $Config(textwidth)\
166	-anchor w -justify left
167    ttk::label $f.detail -textvariable ${dlg}(-detail) \
168    	-font TkTextFont -wraplength $Config(textwidth) \
169	-anchor w -justify left
170
171    #
172    # Command buttons:
173    #
174    set cmd [ttk::frame $f.cmd]
175    set column 0
176    grid columnconfigure $f.cmd 0 -weight 1
177
178    foreach button $options(-buttons) {
179	incr column
180	eval [linsert $buttonOptions($button) 0 ttk::button $cmd.$button]
181        $cmd.$button configure -command [list ttk::dialog::Done $dlg $button]
182    	grid $cmd.$button -row 0 -column $column \
183	    -padx [list $Config(interspace) 0] -sticky ew
184	grid columnconfigure $cmd $column -uniform buttons
185    }
186
187    if {$options(-default) ne ""} {
188    	keynav::defaultButton $cmd.$options(-default)
189	focus $cmd.$options(-default)
190    }
191    if {$options(-cancel) ne ""} {
192	bind $dlg <KeyPress-Escape> \
193	    [list event generate $cmd.$options(-cancel) <<Invoke>>]
194	wm protocol $dlg WM_DELETE_WINDOW \
195	    [list event generate $cmd.$options(-cancel) <<Invoke>>]
196    }
197
198    #
199    # Assemble dialog.
200    #
201    pack $f.cmd -side bottom -expand false -fill x \
202    	-pady [list $Config(sepspace) $Config(margin)] -padx $Config(margin)
203
204    if {0} {
205	# GNOME and Apple HIGs say not to use separators.
206	# But in case we want them anyway:
207	#
208	pack [ttk::separator $f.sep -orient horizontal] \
209	    -side bottom -expand false -fill x \
210	    -pady [list $Config(sepspace) 0] \
211	    -padx $Config(margin)
212    }
213
214    if {$options(-icon) ne ""} {
215	pack $f.icon -side left -anchor n -expand false \
216	    -pady $Config(margin) -padx $Config(margin)
217    }
218
219    pack $f.message -side top -expand false -fill x \
220    	-padx $Config(margin) -pady $Config(margin)
221    if {$options(-detail) != ""} {
222	pack $f.detail -side top -expand false -fill x \
223	    -padx $Config(margin)
224    }
225
226    # Client area goes here.
227
228    pack $f -expand true -fill both
229    keynav::enableMnemonics $dlg
230    wm deiconify $dlg
231}
232
233## ttk::dialog::clientframe --
234#	Returns the widget path of the dialog client frame,
235#	creating and managing it if necessary.
236#
237proc ttk::dialog::clientframe {dlg} {
238    variable Config
239    set client $dlg.f.client
240    if {![winfo exists $client]} {
241	pack [ttk::frame $client] -side top -expand true -fill both \
242		-pady $Config(margin) -padx $Config(margin)
243	lower $client	;# so it's first in keyboard traversal order
244    }
245    return $client
246}
247
248## ttk::dialog::Done --
249#	-command callback for dialog command buttons (internal)
250#
251proc ttk::dialog::Done {dlg button} {
252    upvar #0 $dlg D
253    set rc [catch [linsert $D(-command) end $button] result]
254    if {$rc == 1} {
255    	return -code $rc -errorinfo $::errorInfo -errorcode $::errorCode $result
256    } elseif {$rc == 3 || $rc == 4} {
257	# break or continue -- don't dismiss dialog
258	return
259    }
260    dismiss $dlg
261}
262
263## ttk::dialog::activate $dlg $button --
264#	Simulate a button press.
265#
266proc ttk::dialog::activate {dlg button} {
267    event generate $dlg.f.cmd.$button <<Invoke>>
268}
269
270## dismiss --
271#	Dismiss the dialog (without invoking any actions).
272#
273proc ttk::dialog::dismiss {dlg} {
274    uplevel #0 [list unset $dlg]
275    destroy $dlg
276}
277
278#*EOF*
279