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