Tkgetfile - An enhanced FileOpen browser replacement for tk_getOpenFile

http://www.octamatic.com/tkgetfile.gif

#  	
# 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 ]
    }
}