Tkgetfile - An enhanced FileOpen browser replacement for tk_getOpenFile
#
# tkgetfile.tcl -- Enhanced file selector using tablelist widget (to provide
# detail view and easy access to sorting and column sizing).
# Intended as a replacement for tk_getOpenFile.
#
# Features a detailed view of directories with Name, Size, and Date Modified.
# The user can click on any column heading to sort that column in ascending or
# descending order.
# Input a file name with wildcards (e.g. *.c) to see all files that match.
# You can use the Tab keys, up-down arrows (depending on focus), Return, etc.
#
# Author: Walter B. Wulczak <wulczak@earthlink.net>
# Date: Oct 10 2005
#
# Requires the package "tablelist" ( http://www.nemethi.de )
# Tested with Tcl/Tk 8.1 and 8.4 under Unix.
#
# Usage:
# set filename [tkgetfile ?-option value? ]
# if {$filename != ""} {
# # Open the file and do other stuff ...
# }
#
# Options are:
# [-initialdir dir] Specifies that the files in dir should be
# displayed when the dialog pops up. Defaults
# to the current working directory.
# [-parent window] Display tkgetfile over parent window.
# [-title string] Make string the label of dialog window.
#
# Layout:
#
# Open File:
# +------------------+ +-----+
# | | +UpDir+
# +------------------+ +-----+
#
# Name Size Date Modified
# +------------------------------------+
# | file1 25 2005-01-24 19:11:55 |S
# | file2 |c
# | file3 |r
# | |b
# | |a
# | filen |r
# +------------------------------------+
# Directory Name: currrent-dir
#
# +------+ +--------+
# | OK | | cancel |
# +------+ +--------+
#
###############################################################
#
# Thanks to:
# Csaba Nemethi, author of tablelist, for helpful suggestions.
#
# 10-04-05 wbw: Replaced listbox with tablelist. Dir folder image added.
# Corrected key and button binding definitions.
# 10-05-05 wbw: Recoded 3 sections doing the same thing into tkgetfileshowdir.
# Updir button added.
# 10-06-05 wbw: Work around glob quirk. The following returns no files:
# set selected "*.c *.tcl"
# set globlist [glob $selected]
# or
# set globlist [glob [list $selected]]
# This works (returns files matching either pattern):
# set selected "*.c *.tcl"
# set globlist [eval glob $selected]
# 10-06-05 wbw: Every time tkgetfileshowdir is called, sort the list per the
# last known sorting order.
# 10-07-05 wbw: File names with spaces now handled (removed "glob" call).
# Catch exceptions when user clicks beyond the table.
# 10-08-05 wbw: Added support for "-initialdir" and "-title".
# 10-09-05 wbw: Switched from "ls -a" to "glob". Bindings corrected.
# 10-10-05 wbw: Cleanup and comment out "puts" debugging statements.
#
#
#
#
#
# Copyright 2005 Walter B. Wulczak
# Permission to use, copy, modify, and distribute this
# software and its documentation for any purpose and without
# fee is hereby granted, provided that this copyright
# notice appears in all copies. Walter B. Wulczak
# makes no representations about the suitability of this
# software for any purpose. It is provided "as is" without
# express or implied warranty.
#
# Based in part on fileselect.tcl by:
# Mario Jorge Silva msi...@cs.Berkeley.EDU
# University of California Berkeley
#
# Parts Copyright 1993 Regents of the University of California
# Permission to use, copy, modify, and distribute this
# software and its documentation for any purpose and without
# fee is hereby granted, provided that this copyright
# notice appears in all copies. The University of California
# makes no representations about the suitability of this
# software for any purpose. It is provided "as is" without
# express or implied warranty.
#
package require tablelist
proc tkgetfile {args} {
global tkgetfile_selected
set tkgetfile_selected "-Cancelled-"
global tkgetfilemsg
set tkgetfilemsg(title) "Select File"
set tkgetfilemsg(parent) ""
#
# arguments
#
set index 0
set max [llength $args]
while { $index < $max } {
switch -exact -- [lindex $args $index] {
"-initialdir" {
incr index
cd [lindex $args $index]
incr index
}
"-parent" {
incr index
set tkgetfilemsg(parent) [lindex $args $index]
incr index
}
"-title" {
incr index
set tkgetfilemsg(title) [lindex $args $index]
incr index
}
default {
puts stderr "Unsupported option [lindex $args $index]"
}
}
}
proc setfilename {f} {
global tkgetfile_selected
set tkgetfile_selected $f
# puts stderr "tkgetfile.tcl result is: $f"
}
tkgetfileINT setfilename "Open File" .openFile
# pick one of these 2 lines; you only need the one you like most here.
# tkwait variable tkgetfile_selected
tkwait window .openFile
if { [string compare $tkgetfile_selected "-Cancelled-"] == 0 } then {
# puts stderr "Selection cancelled"
return ""
}
# Return full path name
if {[regexp "/" $tkgetfile_selected] != 0} { return $tkgetfile_selected}
return [pwd]/$tkgetfile_selected
}
# Names starting with "tkgetfile" are reserved by this module
# this is the default proc called when "OK" is pressed
# to indicate yours, give it as the first arg to "tkgetfileINT"
proc tkgetfile.default.cmd {f} {
puts stderr "Selected file $f"
}
image create photo b_up -data {
R0lGODlhFgATAMIAAHt7e9/fX////gAAAK6uSv///////////yH+Dk1hZGUgd2l0aCBHSU1QACH5
BAEAAAcALAAAAAAWABMAAANVeArcoDBKEKoNT2p6b9ZLJzrkAQhoqq4qMJxi3LnwRcjeK9jDjWM6
C2FA9Mlou8CQWMQhO4Nf5XmJSqkW6w9bYXqZFq40HBzPymYyac1uDA7fuJyZAAA7
}
image create photo b_dir -data {
R0lGODlhEAAQAMIAAHB/cN/fX////gAAAP///////////////yH+Dk1hZGUgd2l0aCBHSU1QACH5
BAEAAAQALAAAAAAQABAAAAM2SLrc/jA2QKkEIWcAsdZVpQBCaZ4lMBDk525r+34qK8x0fOOwzfcy
Xi2IG4aOoRVhwGw6nYQEADs=
}
# this is the proc that creates the file selector box
proc tkgetfileINT {
{cmd tkgetfile.default.cmd}
{purpose "Open file:"}
{w .tkgetfileWindow} } {
global tkgetfilemsg
catch {destroy $w}
toplevel $w
grab $w
# wm title $w "Select File"
wm title $w $tkgetfilemsg(title)
if {$tkgetfilemsg(parent) != ""} {
set par $tkgetfilemsg(parent)
set xOrgWin [expr [winfo rootx $par] + [winfo width $par] / 2 -200]
set yOrgWin [expr [winfo rooty $par] + [winfo height $par] / 2 -200]
wm geometry $w +$xOrgWin+$yOrgWin
wm transient $w $tkgetfilemsg(parent)
}
# path independent names for the widgets
global tkgetfile
set tkgetfile(entry) $w.file.eframe.entry
set tkgetfile(list) $w.file.sframe.list
set tkgetfile(scroll) $w.file.sframe.scroll
set tkgetfile(ok) $w.bframe.okframe.ok
set tkgetfile(cancel) $w.bframe.cancel
set tkgetfile(dirlabel) $w.file.dirlabel
# widgets
frame $w.file -bd 5
frame $w.bframe -bd 2
pack append $w \
$w.file {top expand filly} \
$w.bframe {top frame n}
# $w.bframe {left expand frame n}
frame $w.file.eframe
frame $w.file.sframe
# label $w.file.dirlabel -anchor w -width 40 -text "Directory Name: [pwd]"
label $w.file.dirlabel -anchor w -text "Directory Name: [pwd]"
pack append $w.file \
$w.file.eframe {top frame w} \
$w.file.sframe {top expand fillx filly} \
$w.file.dirlabel {top frame w}
label $w.file.eframe.label -anchor w -width 40 -text $purpose
entry $w.file.eframe.entry -relief sunken -background white
button $w.file.eframe.up -image b_up -command "tkgetfileshowdir .."
pack append $w.file.eframe \
$w.file.eframe.label {top expand frame w} \
$w.file.eframe.up {right frame e} \
$w.file.eframe.entry {top fillx frame w}
scrollbar $w.file.sframe.yscroll -relief sunken \
-command "$w.file.sframe.list yview"
# listbox $w.file.sframe.list -relief sunken \
# -yscroll "$w.file.sframe.yscroll set" -selectmode single -width 40 \
# -background white
tablelist::tablelist $w.file.sframe.list -columns {0 "Name" 0 "Size" right 0 "Date Modified" } \
-stretch all -background white -width 0 \
-yscrollcommand [list $w.file.sframe.yscroll set] \
-stripebackground #f0f0f0 \
-labelcommand tablelist::sortByColumn \
-font "-*-helvetica-medium-r-normal-*-12-*-*-*-p-*-iso8859-1" \
-activestyle frame
$w.file.sframe.list columnconfigure 1 -name fileSize -sortmode integer
$w.file.sframe.list columnconfigure 0 -editable 0
$w.file.sframe.list columnconfigure 1 -editable 0
$w.file.sframe.list columnconfigure 2 -editable 0
pack append $w.file.sframe \
$w.file.sframe.yscroll {right filly} \
$w.file.sframe.list {left expand fill}
# buttons
# frame $w.bframe.okframe -borderwidth 2 -relief sunken
frame $w.bframe.okframe -borderwidth 2 -relief flat
button $w.bframe.okframe.ok -text OK -relief raised -padx 20 \
-command "tkgetfile.ok.cmd $w $cmd"
button $w.bframe.cancel -text cancel -relief raised -padx 10 \
-command "tkgetfile.cancel.cmd $w"
pack append $w.bframe.okframe $w.bframe.okframe.ok {padx 1 pady 1}
pack append $w.bframe $w.bframe.okframe {left expand padx 2 pady 2}\
$w.bframe.cancel {left}
# Fill the listbox with a list of the files in the directory
tkgetfileshowdir [pwd]
#---------------------------------------
# Set up bindings for the browser.
bind $tkgetfile(entry) <Return> {eval $tkgetfile(ok) invoke}
bind $tkgetfile(ok) <Return> {eval $tkgetfile(ok) invoke}
bind $tkgetfile(entry) <Control-c> {eval $tkgetfile(cancel) invoke}
bind $w <Control-c> {eval $tkgetfile(cancel) invoke}
# 10-05-05 wbw: Don't see a good reason for the next line as it causes
# a doubling up of the <Return> invokation above.
# bind $w <Return> {eval $tkgetfile(ok) invoke}
# tk_listboxSingleSelect $tkgetfile(list)
set bodyTag [$tkgetfile(list) bodytag]
bind $bodyTag <Button-1> {
# puts stderr "button 1 release"
foreach {tablelist::W tablelist::x tablelist::y} \
[tablelist::convEventFields %W %x %y] {}
set clickcell [$tkgetfile(list) nearest $tablelist::y]
# puts stderr "Nearest clicked on cell $clickcell"
# A button click in an invalid area could exceed the tablelist
if { [$tkgetfile(list) index end] > $clickcell } {
$tkgetfile(entry) delete 0 end
# Get the cell at 0,y (beginning cell of the selected line)
$tkgetfile(entry) insert 0 [$tkgetfile(list) getcells [$tkgetfile(list) nearest $tablelist::y],0]
}
focus $tkgetfile(list)
}
# 10-05-05 wbw: Binding must be KeyRelease as tablelist widget first does
# selection setup via its own Key binding.
bind $bodyTag <KeyRelease> {
foreach {tablelist::W tablelist::x tablelist::y} \
[tablelist::convEventFields %W %x %y] {}
$tkgetfile(entry) delete 0 end
set currow [$tkgetfile(list) curselection]
# puts stderr "currow $currow [$tkgetfile(list) getcells active]"
$tkgetfile(entry) insert 0 [$tkgetfile(list) getcells active]
}
bind $bodyTag <Double-ButtonPress-1> {
# puts stderr "double button 1"
foreach {tablelist::W tablelist::x tablelist::y} \
[tablelist::convEventFields %W %x %y] {}
# set clickcell [$tkgetfile(list) getscells [$tkgetfile(list) containingcell 0 $tablelist::y]]
set clickcell [$tkgetfile(list) nearest $tablelist::y]
# puts stderr "Converted double click on cell $clickcell"
if { [$tkgetfile(list) index end] > $clickcell } {
$tkgetfile(entry) delete 0 end
# Get the cell at 0,y (beginning cell of the selected line)
$tkgetfile(entry) insert 0 [$tkgetfile(list) getcells [$tkgetfile(list) nearest $tablelist::y],0]
$tkgetfile(ok) invoke
}
}
# This binding creates a conflict with tablelist::condEditActiveCell due
# to the window being destroyed before condEditActiveCell is called!
if 0 {
bind $bodyTag <Return> {
$tkgetfile(entry) delete 0 end
$tkgetfile(entry) insert 0 [$tkgetfile(list) getcells active]
$tkgetfile(ok) invoke
}
}
# set kbd focus to list widget, not entry widget
focus $tkgetfile(entry)
# focus $tkgetfile(list)
}
# auxiliary button procedures
proc tkgetfile.cancel.cmd {w} {
# puts stderr "Cancel"
destroy $w
}
proc tkgetfile.ok.cmd {w cmd} {
global tkgetfile
set selected [$tkgetfile(entry) get]
# puts stderr "The tkgetfile.ok.cmd selection is: $selected"
if [file isfile "$selected"] {
# after 5 destroy $w
destroy $w
$cmd $selected
return
}
if { [string compare $selected "" ] == 0} {
# puts stderr "tkgetfile.ok.cmd received blank selection"
return
}
# selection may be a directory. Expand it.
if {[file isdirectory "$selected"] != 0} {
tkgetfileshowdir $selected
return
}
# some nasty file names may cause "file isdirectory" to return an error
set sts [catch {
file isdirectory $selected
} errorMessage ]
if { $sts != 0 } then {
tk_dialog .oops "STS directory error" "Filename directory test return error: $errorMessage" error 0 OK
return
}
# perform globbing on the selection.
# If globing returns an error, return (leaving the file listbox empty)
# If resulting list length > 1, put the list on the file listbox and return
# If globing expands to a list of filenames in multiple directories,
# the indicated regexp is invalid and the error handler is called instead.
set sts [catch {
set globlist [eval glob $selected]
# puts stderr "globlist: $globlist"
} errorMessage ]
if { $sts != 0 } then {
tk_dialog .oops "STS error" "Error: $errorMessage" error 0 OK
return
}
# handle wildcard filenames (e.g. *.txt, *.c, etc.)
# if {[llength $globlist] > 1}
if {$globlist != $selected} {
if {[regexp "/" $globlist] != 0} {
tk_dialog .oops "regexp error" "Invalid regular expression (don't mix '/' with wildcards): $selected" error 0 OK
return
}
tkgetfileshowdir $selected
return
}
if [file isfile "$selected"] {
destroy $w
$cmd $selected
} else {
tk_dialog .oops "Invalid File Name" "You didn't choose anything" error 0 OK
return
}
}
proc tkgetfileshowdir {dirpath} {
# Fill tablelist with a list of the files in the directory (with glob).
global tkgetfile
# puts stderr "tkgetfileshowdir $dirpath"
if {[file isdirectory $dirpath] != 0} {
cd $dirpath
set dirpath [pwd]
$tkgetfile(dirlabel) configure -text "Directory Name: $dirpath"
# puts stderr "Expanding directory $dirpath"
set dirpath ".* *"
}
# Clean the text entry and prepare the list
$tkgetfile(entry) delete 0 end
$tkgetfile(list) delete 0 end
# set globlist [lsort [eval glob $dirpath]]
# if {[llength $globlist] <= 1}
# if {$globlist == $dirpath} {
# set globlist [ exec /bin/ls -a $dirpath]
# }
# set globlist [ exec sh -c "/bin/ls -a $dirpath"]
# puts stderr $globlist
# foreach i [exec /bin/ls -a $dirpath]
# foreach i [split $globlist \n]
# foreach i [lsort [eval glob [file join $dirpath *]]]
foreach i [lsort [eval glob -nocomplain $dirpath]] {
if {[string compare $i "."] != 0 && \
[string compare $i ".."] != 0 } {
set fileSize [file size $i]
set dttm [clock format [file mtime $i] -format "%Y-%m-%d %H:%M:%S" ]
$tkgetfile(list) insert end [list $i $fileSize $dttm]
if {[file isdirectory $i] != 0} {
$tkgetfile(list) cellconfigure end,0 -image b_dir
}
}
}
# Sort the list per the last user-specified sorting order.
set sortcol [$tkgetfile(list) sortcolumn]
if {$sortcol != -1 } {
$tkgetfile(list) sortbycolumn $sortcol -[$tkgetfile(list) sortorder ]
}
}
