#
# $Id: filechsr.tcl,v 1.7 1995/02/02 09:44:10 sls Exp $
#
# filechooser implements a simple file chooser.
# 
# This software is copyright (C) 1994 by the Lawrence Berkeley Laboratory.
# 
# Redistribution and use in source and binary forms, with or without
# modification, are permitted provided that: (1) source code distributions
# retain the above copyright notice and this paragraph in its entirety, (2)
# distributions including binary code include the above copyright notice and
# this paragraph in its entirety in the documentation or other materials
# provided with the distribution, and (3) all advertising materials mentioning
# features or use of this software display the following acknowledgement:
# ``This product includes software developed by the University of California,
# Lawrence Berkeley Laboratory and its contributors.'' Neither the name of
# the University nor the names of its contributors may be used to endorse
# or promote products derived from this software without specific prior
# written permission.
# 
# THIS SOFTWARE IS PROVIDED ``AS IS'' AND WITHOUT ANY EXPRESS OR IMPLIED
# WARRANTIES, INCLUDING, WITHOUT LIMITATION, THE IMPLIED WARRANTIES OF
# MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE.
#
set filechooser_shortTypes(file) "   "
set filechooser_shortTypes(directory) DIR
set filechooser_shortTypes(characterSpecial) CHR
set filechooser_shortTypes(blockSpecial) BLK
set filechooser_shortTypes(fifo) PIP
set filechooser_shortTypes(link) LNK
set filechooser_shortTypes(socket) SOK
set filechooser_modeMap(0) x
set filechooser_modeMap(1) w
set filechooser_modeMap(2) r

option add *Filechooser*Listbox*font \
    -adobe-courier-bold-r-*-*-*-120-*-*-*-*-iso8859-*
option add *Filechooser*status1*font \
    -adobe-courier-bold-r-*-*-*-120-*-*-*-*-iso8859-*
option add *Filechooser*status2*font \
    -adobe-courier-bold-r-*-*-*-120-*-*-*-*-iso8859-*
option add *Filechooser*Listbox*geometry 45x20
    
dialog filechooser {
    param title {}
    param filter *
    param dirok 0       ;# set to 1 if open should accept directories
    param newfile 0     ;# set to 1 if new files are ok
    method create {} {
	set w $self
	wm minsize $w 100 100
	frame $w.list
	pack $w.list -in $w -side top -fill both -expand yes
	scrollbar $w.list.sb -command "$w.list.l yview"
	listbox $w.list.l -yscroll "$w.list.sb set" -relief raised -bd 2 \
	    -exportselection false -selectmode single
	pack $w.list.sb -in $w.list -side right -fill y
	pack $w.list.l -in $w.list -side left -fill both -expand 1
	set slot(list) $w.list.l
	bind $w.list.l <Double-1> "$self open 1"
	bind $w.list.l <Button-1> [bind Listbox <Button-1>]
	foreach ev {<Button-1> <Shift-B1-Motion> <Shift-Button-1> <B1-Motion>} {
	    bind $w.list.l $ev "+$self update_selection"
	}
	set b [frame $w.bottom -bd 3 -relief ridge]
	pack $b -side top -fill both -pady 3 -padx 3
	label $b.status1 -anchor w
	label $b.status2 -anchor w
	pack $b.status1 $b.status2 -side top -fill x -padx 2
	simpleentry $b.filter -width 30 -label "Filter:"
	$b.filter bind <Return> "$self filter \[$b.filter entry get\]"
	$b.filter entry config -textvariable [object_slotname filter]
	pack $b.filter -side top -fill x -padx 5
	simpleentry $b.file -width 30 -label "File:"
	$b.file bind <Return> "$self open 1 \[$b.file entry get\]"
	pack $b.file -side top -fill x -pady 3 -padx 5
	button $b.up -command "cd ..; $self fill" -text "Up"
	button $b.open -command "$self open 0" -text "Open"
	button $b.cancel -command "object_delete $w" -text "Cancel"
	pack $b.open $b.up -in $b -side left -ipadx 5 -ipady 5 -padx 5 -pady 5
	pack $b.cancel -in $b -side right -ipadx 5 -ipady 5 -padx 5 -pady 5
    }
    method run {} {
	tkwait visibility $self
	$self fill
	set slot(result) ""
	set old_dir [pwd]
	while [catch {grab set $self}] {}
	tkwait variable [object_slotname result]
	grab release $self
	if ![info exists slot(result)] {
	    cd $old_dir
	    return ""
	}
	cd $old_dir
	after 0 [list object_delete $self]
	return $slot(result)
    }
    method reconfig {} {
	wm title $self $slot(title)
	wm iconname $self $slot(title)
    }
    method fill {} {
	global filechooser_shortTypes
	set list $slot(list)
	$list delete 0 end
	foreach f [lsort [glob -nocomplain $slot(filter)]] {
	    if [catch {file size $f} size] {
		set size 0
	    }
	    $list insert end \
	       [format "%s %6.1fk %s" $filechooser_shortTypes([file type $f]) \
		 [expr $size / 1024.0] [file tail $f]]
	}
	$self update_selection
    }
    method filter {filter} {
	set slot(filter) $filter
	$self fill
    }
    method get_selection {} {
	set l $slot(list)
	set sel [$l curselection]
	if {$sel == {}} return
	set file [$l get $sel]
	if {[llength $file] == 2} {
	    set file [lindex $file 1]
	} else {
	    set file [lindex $file 2]
	}
	return $file
    }
    method update_selection {} {
	$self.bottom.file entry delete 0 end
	set f [$self get_selection]
	$self.bottom.file entry insert 0 [pwd]/$f
	if [string length $f] {
	    global filechooser_shortTypes filechooser_modeMap
	    file lstat $f stat
	    for {set bit 8} {$bit >= 0} {incr bit -1} {
		if {$stat(mode) & (1 << $bit)} {
		    append mode $filechooser_modeMap([expr $bit % 3])
		} else {
		    append mode -
		}
	    }
	    set msg1 \
		[format "%s %6.1fk %s %5d %5d" \
		 $filechooser_shortTypes($stat(type)) \
		 [expr $stat(size) / 1024.0] $mode $stat(gid) $stat(uid)]
	    set msg2 [file tail $f]
	    if {$stat(type) == "link"} {
		append msg2 " -> [file readlink $f]"
	    }
	} else {
	    set msg1 ""
	    set msg2 ""
	}
	$self.bottom.status1 config -text $msg1
	$self.bottom.status2 config -text $msg2
    }
    method open {is_click {file ""}} {
	if ![string length $file] {
	    set file [$self get_selection]
	}
	if {$slot(newfile) && ![file exists $file]} {
	    set slot(result) $file
	    return
	}
	if {($is_click || !$slot(dirok)) && [file isdirectory $file]} {
	    cd $file
	    $self fill
	    return
	}
	set slot(result) $file
    }
}
