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