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