1#!/bin/sh
2# the next line restarts using wish \
3exec wish "$0" ${1+"$@"}
4
5#==============================================================================
6# Demonstrates how to use a tablelist widget for displaying the contents of a
7# directory.
8#
9# Copyright (c) 2010  Csaba Nemethi (E-mail: csaba.nemethi@t-online.de)
10#==============================================================================
11
12package require tablelist_tile 5.1
13
14#
15# Add some entries to the Tk option database
16#
17set dir [file dirname [info script]]
18source [file join $dir option_tile.tcl]
19
20#
21# Create three images
22#
23set clsdFolderImg [image create photo -file [file join $dir clsdFolder.gif]]
24set openFolderImg [image create photo -file [file join $dir openFolder.gif]]
25set fileImg       [image create photo -file [file join $dir file.gif]]
26
27#
28# Work around the improper appearance of the tile scrollbars in the aqua theme
29#
30if {[tablelist::getCurrentTheme] eq "aqua"} {
31    interp alias {} ttk::scrollbar {} ::scrollbar
32}
33
34#------------------------------------------------------------------------------
35# displayContents
36#
37# Displays the contents of the directory dir in a tablelist widget.
38#------------------------------------------------------------------------------
39proc displayContents dir {
40    #
41    # Create a vertically scrolled tablelist widget with 3
42    # dynamic-width columns and interactive sort capability
43    #
44    set tf .tf
45    ttk::frame $tf
46    set tbl $tf.tbl
47    set vsb $tf.vsb
48    tablelist::tablelist $tbl \
49	-columns {0 "Name"	    left
50		  0 "Size"	    right
51		  0 "Date Modified" left} \
52	-expandcommand expandCmd -collapsecommand collapseCmd \
53	-yscrollcommand [list $vsb set] -movablecolumns no -setgrid no \
54	-showseparators yes -height 20 -width 80
55    if {[$tbl cget -selectborderwidth] == 0} {
56	$tbl configure -spacing 1
57    }
58    $tbl columnconfigure 0 -formatcommand formatString -sortmode dictionary
59    $tbl columnconfigure 1 -formatcommand formatSize -sortmode integer
60    $tbl columnconfigure 2 -formatcommand formatString
61    ttk::scrollbar $vsb -orient vertical -command [list $tbl yview]
62
63    #
64    # Create a pop-up menu with one command entry; bind the script
65    # associated with its entry to the <Double-1> event, too
66    #
67    set menu .menu
68    menu $menu -tearoff no
69    $menu add command -label "Display Contents" \
70		      -command [list putContentsOfSelFolder $tbl]
71    set bodyTag [$tbl bodytag]
72    bind $bodyTag <<Button3>>  [bind TablelistBody <Button-1>]
73    bind $bodyTag <<Button3>> +[bind TablelistBody <ButtonRelease-1>]
74    bind $bodyTag <<Button3>> +[list postPopupMenu %X %Y]
75    bind $bodyTag <Double-1>   [list putContentsOfSelFolder $tbl]
76
77    #
78    # Create three buttons within a frame child of the main widget
79    #
80    set bf .bf
81    ttk::frame $bf
82    set b1 $bf.b1
83    set b2 $bf.b2
84    set b3 $bf.b3
85    ttk::button $b1 -width 10 -text "Refresh"
86    ttk::button $b2 -width 10 -text "Parent"
87    ttk::button $b3 -width 10 -text "Close" -command exit
88
89    #
90    # Manage the widgets
91    #
92    grid $tbl -row 0 -column 0 -sticky news
93    grid $vsb -row 0 -column 1 -sticky ns
94    grid rowconfigure    $tf 0 -weight 1
95    grid columnconfigure $tf 0 -weight 1
96    pack $b1 $b2 $b3 -side left -expand yes -pady 10
97    pack $bf -side bottom -fill x
98    pack $tf -side top -expand yes -fill both
99
100    #
101    # Populate the tablelist with the contents of the given directory
102    #
103    $tbl sortbycolumn 0
104    putContents $dir $tbl root
105}
106
107#------------------------------------------------------------------------------
108# putContents
109#
110# Outputs the contents of the directory dir into the tablelist widget tbl, as
111# child items of the one identified by nodeIdx.
112#------------------------------------------------------------------------------
113proc putContents {dir tbl nodeIdx} {
114    #
115    # The following check is necessary because this procedure
116    # is also invoked by the "Refresh" and "Parent" buttons
117    #
118    if {[string compare $dir ""] != 0 &&
119	(![file isdirectory $dir] || ![file readable $dir])} {
120	bell
121	if {[string compare $nodeIdx "root"] == 0} {
122	    set choice [tk_messageBox -title "Error" -icon warning -message \
123			"Cannot read directory \"[file nativename $dir]\"\
124			-- replacing it with nearest existent ancestor" \
125			-type okcancel -default ok]
126	    if {[string compare $choice "ok"] == 0} {
127		while {![file isdirectory $dir] || ![file readable $dir]} {
128		    set dir [file dirname $dir]
129		}
130	    } else {
131		return ""
132	    }
133	} else {
134	    return ""
135	}
136    }
137
138    if {[string compare $nodeIdx "root"] == 0} {
139	if {[string compare $dir ""] == 0} {
140	    wm title . "Contents of the Workspace"
141	} else {
142	    wm title . "Contents of the Directory \"[file nativename $dir]\""
143	}
144
145	$tbl delete 0 end
146	set row 0
147    } else {
148	set row [expr {$nodeIdx + 1}]
149    }
150
151    #
152    # Build a list from the data of the subdirectories and
153    # files of the directory dir.  Prepend a "D" or "F" to
154    # each entry's name and modification date & time, for
155    # sorting purposes (it will be removed by formatString).
156    #
157    set itemList {}
158    if {[string compare $dir ""] == 0} {
159	foreach volume [file volumes] {
160	    lappend itemList [list D[file nativename $volume] -1 D $volume]
161	}
162    } else {
163	foreach entry [glob -nocomplain -types {d f} -directory $dir *] {
164	    if {[catch {file mtime $entry} modTime] != 0} {
165		continue
166	    }
167
168	    if {[file isdirectory $entry]} {
169		lappend itemList [list D[file tail $entry] -1 \
170		    D[clock format $modTime -format "%Y-%m-%d %H:%M"] $entry]
171	    } else {
172		lappend itemList [list F[file tail $entry] [file size $entry] \
173		    F[clock format $modTime -format "%Y-%m-%d %H:%M"] ""]
174	    }
175	}
176    }
177
178    #
179    # Sort the above list and insert it into the tablelist widget
180    # tbl as list of children of the row identified by nodeIdx
181    #
182    set itemList [$tbl applysorting $itemList]
183    $tbl insertchildlist $nodeIdx end $itemList
184
185    #
186    # Insert an image into the first cell of each newly inserted row
187    #
188    global clsdFolderImg fileImg
189    foreach item $itemList {
190	set name [lindex $item end]
191	if {[string compare $name ""] == 0} {			;# file
192	    $tbl cellconfigure $row,0 -image $fileImg
193	} else {						;# subdirectory
194	    $tbl cellconfigure $row,0 -image $clsdFolderImg
195	    $tbl rowattrib $row pathName $name
196
197	    #
198	    # Mark the row as collapsed if the subdirectory is non-empty
199	    #
200	    if {[file readable $name] && [llength \
201		[glob -nocomplain -types {d f} -directory $name *]] != 0} {
202		$tbl collapse $row
203	    }
204	}
205
206	incr row
207    }
208
209    if {[string compare $nodeIdx "root"] == 0} {
210	#
211	# Configure the "Refresh" and "Parent" buttons
212	#
213	.bf.b1 configure -command [list refreshView $dir $tbl]
214	set b2 .bf.b2
215	if {[string compare $dir ""] == 0} {
216	    $b2 configure -state disabled
217	} else {
218	    $b2 configure -state normal
219	    set p [file dirname $dir]
220	    if {[string compare $p $dir] == 0} {
221		$b2 configure -command [list putContents "" $tbl root]
222	    } else {
223		$b2 configure -command [list putContents $p $tbl root]
224	    }
225	}
226    }
227}
228
229#------------------------------------------------------------------------------
230# formatString
231#
232# Returns the substring obtained from the specified value by removing its first
233# character.
234#------------------------------------------------------------------------------
235proc formatString val {
236    return [string range $val 1 end]
237}
238
239#------------------------------------------------------------------------------
240# formatSize
241#
242# Returns an empty string if the specified value is negative and the value
243# itself in user-friendly format otherwise.
244#------------------------------------------------------------------------------
245proc formatSize val {
246    if {$val < 0} {
247	return ""
248    } elseif {$val < 1024} {
249	return "$val bytes"
250    } elseif {$val < 1048576} {
251	return [format "%.1f KB" [expr {$val / 1024.0}]]
252    } elseif {$val < 1073741824} {
253	return [format "%.1f MB" [expr {$val / 1048576.0}]]
254    } else {
255	return [format "%.1f GB" [expr {$val / 1073741824.0}]]
256    }
257}
258
259#------------------------------------------------------------------------------
260# expandCmd
261#
262# Outputs the contents of the directory whose leaf name is displayed in the
263# first cell of the specified row of the tablelist widget tbl, as child items
264# of the one identified by row, and updates the image displayed in that cell.
265#------------------------------------------------------------------------------
266proc expandCmd {tbl row} {
267    if {[$tbl childcount $row] == 0} {
268	set dir [$tbl rowattrib $row pathName]
269	putContents $dir $tbl $row
270    }
271
272    if {[$tbl childcount $row] != 0} {
273	global openFolderImg
274	$tbl cellconfigure $row,0 -image $openFolderImg
275    }
276}
277
278#------------------------------------------------------------------------------
279# collapseCmd
280#
281# Updates the image displayed in the first cell of the specified row of the
282# tablelist widget tbl.
283#------------------------------------------------------------------------------
284proc collapseCmd {tbl row} {
285    global clsdFolderImg
286    $tbl cellconfigure $row,0 -image $clsdFolderImg
287}
288
289#------------------------------------------------------------------------------
290# putContentsOfSelFolder
291#
292# Outputs the contents of the selected folder into the tablelist widget tbl.
293#------------------------------------------------------------------------------
294proc putContentsOfSelFolder tbl {
295    set row [$tbl curselection]
296    if {[$tbl hasrowattrib $row pathName]} {		;# subdirectory item
297	set dir [$tbl rowattrib $row pathName]
298	if {[file isdirectory $dir] && [file readable $dir]} {
299	    if {[llength [glob -nocomplain -types {d f} -directory $dir *]]
300		== 0} {
301		bell
302	    } else {
303		putContents $dir $tbl root
304	    }
305	} else {
306	    bell
307	    tk_messageBox -title "Error" -icon error -message \
308		"Cannot read directory \"[file nativename $dir]\""
309	    return ""
310	}
311    } else {						;# file item
312	bell
313    }
314}
315
316#------------------------------------------------------------------------------
317# postPopupMenu
318#
319# Posts the pop-up menu .menu at the given screen position.  Before posting
320# the menu, the procedure enables/disables its only entry, depending upon
321# whether the selected item represents a readable directory or not.
322#------------------------------------------------------------------------------
323proc postPopupMenu {rootX rootY} {
324    set tbl .tf.tbl
325    set row [$tbl curselection]
326    set menu .menu
327    if {[$tbl hasrowattrib $row pathName]} {		;# subdirectory item
328	set dir [$tbl rowattrib $row pathName]
329	if {[file isdirectory $dir] && [file readable $dir]} {
330	    if {[llength [glob -nocomplain -types {d f} -directory $dir *]]
331		== 0} {
332		$menu entryconfigure 0 -state disabled
333	    } else {
334		$menu entryconfigure 0 -state normal
335	    }
336	} else {
337	    bell
338	    tk_messageBox -title "Error" -icon error -message \
339		"Cannot read directory \"[file nativename $dir]\""
340	    return ""
341	}
342    } else {						;# file item
343	$menu entryconfigure 0 -state disabled
344    }
345
346    tk_popup $menu $rootX $rootY
347}
348
349#------------------------------------------------------------------------------
350# refreshView
351#
352# Redisplays the contents of the directory dir in the tablelist widget tbl and
353# restores the expanded states of the folders as well as the vertical view.
354#------------------------------------------------------------------------------
355proc refreshView {dir tbl} {
356    #
357    # Save the vertical view and get the path names
358    # of the folders displayed in the expanded rows
359    #
360    set yView [$tbl yview]
361    foreach key [$tbl expandedkeys] {
362	set pathName [$tbl rowattrib $key pathName]
363	set expandedFolders($pathName) 1
364    }
365
366    #
367    # Redisplay the directory's (possibly changed) contents and restore
368    # the expanded states of the folders, along with the vertical view
369    #
370    putContents $dir $tbl root
371    restoreExpandedStates $tbl root expandedFolders
372    $tbl yview moveto [lindex $yView 0]
373}
374
375#------------------------------------------------------------------------------
376# restoreExpandedStates
377#
378# Expands those children of the parent identified by nodeIdx that display
379# folders whose path names are the names of the elements of the array specified
380# by the last argument.
381#------------------------------------------------------------------------------
382proc restoreExpandedStates {tbl nodeIdx expandedFoldersName} {
383    upvar $expandedFoldersName expandedFolders
384
385    foreach key [$tbl childkeys $nodeIdx] {
386	set pathName [$tbl rowattrib $key pathName]
387	if {[string compare $pathName ""] != 0 &&
388	    [info exists expandedFolders($pathName)]} {
389	    $tbl expand $key -partly
390	    restoreExpandedStates $tbl $key expandedFolders
391	}
392    }
393}
394
395displayContents ""
396