1#==============================================================================
2# Demonstrates how to use a tablelist widget for displaying information about
3# children of an arbitrary widget.
4#
5# Copyright (c) 2000-2010  Csaba Nemethi (E-mail: csaba.nemethi@t-online.de)
6#==============================================================================
7
8package require tablelist_tile 5.1
9
10namespace eval demo {
11    variable dir [file dirname [info script]]
12
13    #
14    # Create two images, needed in the procedure putChildren
15    #
16    variable leafImg [image create bitmap -file [file join $dir leaf.xbm] \
17		      -background coral -foreground gray50]
18    variable compImg [image create bitmap -file [file join $dir comp.xbm] \
19		      -background yellow -foreground gray50]
20}
21
22source [file join $demo::dir config_tile.tcl]
23
24#
25# Work around the improper appearance of the tile scrollbars in the aqua theme
26#
27if {[tablelist::getCurrentTheme] eq "aqua"} {
28    interp alias {} ttk::scrollbar {} ::scrollbar
29}
30
31#------------------------------------------------------------------------------
32# demo::displayChildren
33#
34# Displays information on the children of the widget w in a tablelist widget
35# contained in a newly created top-level widget.  Returns the name of the
36# tablelist widget.
37#------------------------------------------------------------------------------
38proc demo::displayChildren w {
39    if {![winfo exists $w]} {
40	bell
41	tk_messageBox -title "Error" -icon error -message \
42	    "Bad window path name \"$w\""
43	return ""
44    }
45
46    #
47    # Create a top-level widget of the class DemoTop
48    #
49    set top .browseTop
50    for {set n 2} {[winfo exists $top]} {incr n} {
51	set top .browseTop$n
52    }
53    toplevel $top -class DemoTop
54
55    #
56    # Create a vertically scrolled tablelist widget with 9 dynamic-width
57    # columns and interactive sort capability within the top-level
58    #
59    set tf $top.tf
60    ttk::frame $tf
61    set tbl $tf.tbl
62    set vsb $tf.vsb
63    tablelist::tablelist $tbl \
64	-columns {0 "Path Name"	left
65		  0 "Class"	left
66		  0 "X"		right
67		  0 "Y"		right
68		  0 "Width"	right
69		  0 "Height"	right
70		  0 "Mapped"	center
71		  0 "Viewable"	center
72		  0 "Manager"	left} \
73	-labelcommand demo::labelCmd -yscrollcommand [list $vsb set] -width 0
74    if {[$tbl cget -selectborderwidth] == 0} {
75	$tbl configure -spacing 1
76    }
77    foreach col {2 3 4 5} {
78	$tbl columnconfigure $col -sortmode integer
79    }
80    foreach col {6 7} {
81	$tbl columnconfigure $col -formatcommand demo::formatBoolean
82    }
83    ttk::scrollbar $vsb -orient vertical -command [list $tbl yview]
84
85    #
86    # When displaying the information about the children of any
87    # ancestor of the label widgets, the widths of some of the
88    # labels and thus also the widths and x coordinates of some
89    # children may change.  For this reason, make sure the items
90    # will be updated after any change in the sizes of the labels
91    #
92    foreach l [$tbl labels] {
93	bind $l <Configure> [list demo::updateItemsDelayed $tbl]
94    }
95    bind $tbl <Configure> [list demo::updateItemsDelayed $tbl]
96
97    #
98    # Create a pop-up menu with two command entries; bind the script
99    # associated with its first entry to the <Double-1> event, too
100    #
101    set menu $top.menu
102    menu $menu -tearoff no
103    $menu add command -label "Display Children" \
104		      -command [list demo::putChildrenOfSelWidget $tbl]
105    $menu add command -label "Display Config" \
106		      -command [list demo::dispConfigOfSelWidget $tbl]
107    set bodyTag [$tbl bodytag]
108    bind $bodyTag <Double-1>   [list demo::putChildrenOfSelWidget $tbl]
109    bind $bodyTag <<Button3>>  [bind TablelistBody <Button-1>]
110    bind $bodyTag <<Button3>> +[bind TablelistBody <ButtonRelease-1>]
111    bind $bodyTag <<Button3>> +[list demo::postPopupMenu $top %X %Y]
112
113    #
114    # Create three buttons within a tile frame child of the top-level widget
115    #
116    set bf $top.bf
117    ttk::frame $bf
118    set b1 $bf.b1
119    set b2 $bf.b2
120    set b3 $bf.b3
121    ttk::button $b1 -text "Refresh"
122    ttk::button $b2 -text "Parent"
123    ttk::button $b3 -text "Close" -command [list destroy $top]
124
125    #
126    # Manage the widgets
127    #
128    grid $tbl -row 0 -column 0 -sticky news
129    grid $vsb -row 0 -column 1 -sticky ns
130    grid rowconfigure    $tf 0 -weight 1
131    grid columnconfigure $tf 0 -weight 1
132    pack $b1 $b2 $b3 -side left -expand yes -pady 10
133    pack $bf -side bottom -fill x
134    pack $tf -side top -expand yes -fill both
135
136    #
137    # Populate the tablelist with the data of the given widget's children
138    #
139    putChildren $w $tbl
140    return $tbl
141}
142
143#------------------------------------------------------------------------------
144# demo::putChildren
145#
146# Outputs the data of the children of the widget w into the tablelist widget
147# tbl.
148#------------------------------------------------------------------------------
149proc demo::putChildren {w tbl} {
150    #
151    # The following check is necessary because this procedure
152    # is also invoked by the "Refresh" and "Parent" buttons
153    #
154    if {![winfo exists $w]} {
155	bell
156	set choice [tk_messageBox -title "Error" -icon warning \
157		    -message "Bad window path name \"$w\" -- replacing\
158			      it with nearest existent ancestor" \
159		    -type okcancel -default ok -parent [winfo toplevel $tbl]]
160	if {[string compare $choice "ok"] == 0} {
161	    while {![winfo exists $w]} {
162		set last [string last "." $w]
163		if {$last != 0} {
164		    incr last -1
165		}
166		set w [string range $w 0 $last]
167	    }
168	} else {
169	    return ""
170	}
171    }
172
173    set top [winfo toplevel $tbl]
174    wm title $top "Children of the [winfo class $w] Widget \"$w\""
175
176    $tbl resetsortinfo
177    $tbl delete 0 end
178
179    #
180    # Display the data of the children of the
181    # widget w in the tablelist widget tbl
182    #
183    variable leafImg
184    variable compImg
185    foreach c [winfo children $w] {
186	#
187	# Insert the data of the current child into the tablelist widget
188	#
189	set item {}
190	lappend item $c [winfo class $c] [winfo x $c] [winfo y $c] \
191		     [winfo width $c] [winfo height $c] [winfo ismapped $c] \
192		     [winfo viewable $c] [winfo manager $c]
193	$tbl insert end $item
194
195	#
196	# Insert an image into the first cell of the row
197	#
198	if {[llength [winfo children $c]] == 0} {
199	    $tbl cellconfigure end,0 -image $leafImg
200	} else {
201	    $tbl cellconfigure end,0 -image $compImg
202	}
203    }
204
205    #
206    # Configure the "Refresh" and "Parent" buttons
207    #
208    $top.bf.b1 configure -command [list demo::putChildren $w $tbl]
209    set b2 $top.bf.b2
210    set p [winfo parent $w]
211    if {[string compare $p ""] == 0} {
212	$b2 configure -state disabled
213    } else {
214	$b2 configure -state normal -command [list demo::putChildren $p $tbl]
215    }
216}
217
218#------------------------------------------------------------------------------
219# demo::formatBoolean
220#
221# Returns "yes" or "no", according to the specified boolean value.
222#------------------------------------------------------------------------------
223proc demo::formatBoolean val {
224    return [expr {$val ? "yes" : "no"}]
225}
226
227#------------------------------------------------------------------------------
228# demo::labelCmd
229#
230# Sorts the contents of the tablelist widget tbl by its col'th column and makes
231# sure the items will be updated 500 ms later (because one of the items might
232# refer to a canvas containing the arrow that displays the sort order).
233#------------------------------------------------------------------------------
234proc demo::labelCmd {tbl col} {
235    tablelist::sortByColumn $tbl $col
236    updateItemsDelayed $tbl
237}
238
239#------------------------------------------------------------------------------
240# demo::updateItemsDelayed
241#
242# Arranges for the items of the tablelist widget tbl to be updated 500 ms later.
243#------------------------------------------------------------------------------
244proc demo::updateItemsDelayed tbl {
245    #
246    # Schedule the demo::updateItems command for execution
247    # 500 ms later, but only if it is not yet pending
248    #
249    if {[string compare [$tbl attrib afterId] ""] == 0} {
250	$tbl attrib afterId [after 500 [list demo::updateItems $tbl]]
251    }
252}
253
254#------------------------------------------------------------------------------
255# demo::updateItems
256#
257# Updates the items of the tablelist widget tbl.
258#------------------------------------------------------------------------------
259proc demo::updateItems tbl {
260    #
261    # Reset the tablelist's "afterId" attribute
262    #
263    $tbl attrib afterId ""
264
265    #
266    # Update the items
267    #
268    set rowCount [$tbl size]
269    for {set row 0} {$row < $rowCount} {incr row} {
270	set c [$tbl cellcget $row,0 -text]
271	if {![winfo exists $c]} {
272	    continue
273	}
274
275	set item {}
276	lappend item $c [winfo class $c] [winfo x $c] [winfo y $c] \
277		     [winfo width $c] [winfo height $c] [winfo ismapped $c] \
278		     [winfo viewable $c] [winfo manager $c]
279	$tbl rowconfigure $row -text $item
280    }
281
282    #
283    # Repeat the last sort operation (if any)
284    #
285    $tbl refreshsorting
286}
287
288#------------------------------------------------------------------------------
289# demo::putChildrenOfSelWidget
290#
291# Outputs the data of the children of the selected widget into the tablelist
292# widget tbl.
293#------------------------------------------------------------------------------
294proc demo::putChildrenOfSelWidget tbl {
295    set w [$tbl cellcget [$tbl curselection],0 -text]
296    if {![winfo exists $w]} {
297	bell
298	tk_messageBox -title "Error" -icon error -message \
299	    "Bad window path name \"$w\"" -parent [winfo toplevel $tbl]
300	return ""
301    }
302
303    if {[llength [winfo children $w]] == 0} {
304	bell
305    } else {
306	putChildren $w $tbl
307    }
308}
309
310#------------------------------------------------------------------------------
311# demo::dispConfigOfSelWidget
312#
313# Displays the configuration options of the selected widget within the
314# tablelist tbl in a tablelist widget contained in a newly created top-level
315# widget.
316#------------------------------------------------------------------------------
317proc demo::dispConfigOfSelWidget tbl {
318    demo::displayConfig [$tbl cellcget [$tbl curselection],0 -text]
319}
320
321#------------------------------------------------------------------------------
322# demo::postPopupMenu
323#
324# Posts the pop-up menu $top.menu at the given screen position.  Before posting
325# the menu, the procedure enables/disables its first entry, depending upon
326# whether the selected widget has children or not.
327#------------------------------------------------------------------------------
328proc demo::postPopupMenu {top rootX rootY} {
329    set tbl $top.tf.tbl
330    set w [$tbl cellcget [$tbl curselection],0 -text]
331    if {![winfo exists $w]} {
332	bell
333	tk_messageBox -title "Error" -icon error -message \
334	    "Bad window path name \"$w\"" -parent $top
335	return ""
336    }
337
338    set menu $top.menu
339    if {[llength [winfo children $w]] == 0} {
340	$menu entryconfigure 0 -state disabled
341    } else {
342	$menu entryconfigure 0 -state normal
343    }
344
345    tk_popup $menu $rootX $rootY
346}
347
348#------------------------------------------------------------------------------
349
350if {$tcl_interactive} {
351    return "\nTo display information about the children of an arbitrary\
352	    widget, enter\n\n\tdemo::displayChildren <widgetName>\n"
353} else {
354    wm withdraw .
355    tk_messageBox -title $argv0 -icon warning -message \
356	"Please source this script into\nan interactive wish session"
357    exit 1
358}
359