#! @TCL@ -f# file: dec_filesel.tcl## These procedures used with direct permission from the author, J. Hobbs##### filesel.tcl## Tk File Selection Dialog#### updates Copyright 1995,1996 Jeffrey Hobbs.#### jhobbs@cs.uoregon.edu, http://www.cs.uoregon.edu/~jhobbs/#### source standard_disclaimer.tcl####----------------------------------------------------------------------------## PROCEDURE##   tk_filesel VERSION 0.995#### DESCRIPTION##   Implements a directory browser, _without_ using cd.#### ARGUMENTS##	tk_filesel <window pathname> <options>#### OPTIONS## -defaultfile	The default file to return.##		Defaults to {}## -directory	The directory which to start in.##		Defaults to [pwd]## -filemask	A glob to indicate which files to display.##		Defaults to *##		(all (non .*) directories are also shown)## -filetest	A procedure test to indicate whether the filename##		should be included in the list.  Must return 0/1.##		Defaults to all files (1)## -grab	Takes a Tcl boolean on whether the dialog should do a grab.##		Defaults to 1.## -message	A message to the user to be displayed at the top of the browser##		Defaults to {}## -childsite	A procedure to eval to place extra widgets in a childsite##		in the dialog.## -showhidden	A flag to indicate whether dot files should be included in##		the search. No value associated with it (present == yes)## -okbutton	Text to use for accept button.  Defaults to "OK".## -title	Title of the browser, default to "Select File".## -cancelexception	A flag to indicate whether Cancel causes an exception##			(present == yes)## RETURN VALUE##   selected_filename	if a file was selected##   {}			if `Cancel' was chosen (and -cancelexc wasn't present)#### ERRORS##   none#### REQUIRES##   bindrecursive	 for performing a binding on a whole widget subtree#### GLOBAL VARIABLES (in global array tkFS)##   filter		Actual current file filter##   filename		Actual current filename##   filetest		Test for acceptable files##   hiddenfiles	Include .* files?##   hiddendirs		Include .* directories?##   bbox		Window path of buttons##   e,filter		Window path of filter entry field##   e,file		Window path of file entry field##   l,dir		Window path of directory listbox##   l,file		Window path of file listbox##proc tk_filesel {w args} {  global tkFS tcl_platform  set count 0  set unix  [string match unix $tcl_platform(platform)]  array set arg {    cancelexc	0	childsite	{}    defaultfile	{}	directory	.    filemask	*	filetest	{set noop 1}    message	{}	okbutton	OK    showhidden	0	title		"Select File"    grab	1  }  set truth {^(1|yes|true|on)$}  for {set i 0;set num [llength $args]} {$i<$num} {incr i} {    set key [string tolower [lindex $args $i]]    set val [lindex $args [incr i]]    switch -glob -- $key {      -ca*	{set arg(cancelexc)	1; set i [incr i -1] }      -ch*	{set arg(childsite)	$val }      -de*	{set arg(defaultfile)	$val }      -di*	{set arg(directory)	$val }      -filem*	{set arg(filemask)	$val }      -filet*	{set arg(filetest)	$val }      -g*	{set arg(grab)		[regexp -nocase $truth $val] }      -m*	{set arg(message)	$val }      -o*	{set arg(okbutton)	$val }      -s*	{set arg(showhidden)	1; set i [incr i -1] }      -t*	{set arg(title)		$val }      default	{}    }  }  if ![regexp -nocase {^([A-Z]+:)?/.*} $arg(directory)] {    if [string match ~* $arg(directory)] {      if [catch {glob $arg(directory)} dir] {	set arg(directory) [pwd]	puts $dir      } else {set arg(directory) $dir}    } else {      set arg(directory) [file join [pwd] $arg(directory)]    }    regsub -all {/\./} $arg(directory) / arg(directory)    regsub {/\.?$} $arg(directory) {} arg(directory)  }  array set tkFS [list cwd $arg(directory) \		      filetest    $arg(filetest) \		      hiddenfiles $arg(showhidden) \		      hiddendirs  $arg(showhidden) \		      filter      [file join $arg(directory) $arg(filemask)] \		      sep	  [string trim [file join . .] .] \		      filename    $arg(defaultfile) \		     ]  toplevel $w -class TkFileSelect  wm withdraw $w  wm title $w $arg(title)  set parentwindow [winfo toplevel [winfo parent $w]]  wm transient $w $parentwindow  wm group $w $parentwindow  ## Check for message  if [string length $arg(message)] {    message $w.message -justify center -relief raised \	-bd 1 -text $arg(message) -width 350 \	-font *Helvetica-Medium-R*18*    pack $w.message -fill x -anchor w  }  pack [frame $w.filter	-relief raised -bd 1] -fill x  pack [frame $w.list	-relief raised -bd 1 -height 250] -fill both -expand 1  if [string comp $arg(childsite) {}] {    pack [frame $w.child  -relief raised -bd 1] -fill both    uplevel "set childsite $w.child; $arg(childsite)"  }  pack [frame $w.file	-relief raised -bd 1] -fill x  pack [frame $w.bbox	-relief raised -bd 1] -fill x  ## BUTTON BOX  ##  set tkFS(bbox) $w.bbox  button $tkFS(bbox).ok -text $arg(okbutton) -width 6 -padx 8 -pady 2 \      -command "destroy $w"  button $tkFS(bbox).cancel -text Cancel -width 6 -padx 8 -pady 2 \      -command "set tkFS(filename) {}; destroy $w"  button $tkFS(bbox).filter -text Filter -width 6 -padx 8 -pady 2 \      -command tkFS_filterCommand  frame $tkFS(bbox).default -relief sunken -bd 1  frame $tkFS(bbox).filtbrd -relief flat -bd 1  raise $tkFS(bbox).ok  raise $tkFS(bbox).filter  pack $tkFS(bbox).default -side left -expand 1 -padx 4 -pady 4  pack $tkFS(bbox).ok -in $tkFS(bbox).default -side left \      -padx 2 -pady 2 -ipadx 2 -ipady 2  pack $tkFS(bbox).filter -in $tkFS(bbox).filtbrd -side left \      -padx 2 -pady 2 -ipadx 2 -ipady 2  pack $tkFS(bbox).filtbrd -side left -expand 1 -padx 4 -pady 4  pack $tkFS(bbox).cancel -side left -exp 1 -padx 2 -pady 2 -ipadx 2 -ipady 2  ## FILTER ENTRY  ##  set f $w.filter  set tkFS(e,filter) $f.body.text  label $f.label -text Filter: -width 8 -anchor w  frame $f.body -relief groove -bd 1  entry $f.body.text -textvar tkFS(filter)  pack $f.label -side left  pack $f.body -side right -padx 2 -pady 2 -fill x -expand 1  pack $f.body.text -fill x -expand 1  ## FILENAME ENTRY  ##  set f $w.file  set tkFS(e,file) $f.body.text  label $f.label -text Filename: -width 8 -anchor w  frame $f.body -relief groove -bd 1  entry $tkFS(e,file) -textvar tkFS(filename)    pack $f.label -side left  pack $f.body -side right -padx 2 -pady 2 -fill x -expand 1  pack $tkFS(e,file) -fill x -expand 1  ## INTERNAL DIRECTORY / FILE PANED WINDOW  ##  pane [frame $w.list.dir] [frame $w.list.file]  ## DIRECTORY LIST  ##  set f $w.list.dir  set tkFS(l,dir)  $f.list  set tkFS(s,dir)  $f.sy  label     $f.label -text Directories -anchor c  scrollbar $f.sx -command "$tkFS(l,dir) xview" -orient h -bd 1 -highlightt 1  listbox   $tkFS(l,dir) -relief raised -bd 1 -highlightt 1 -exportsel no \      -yscrollcommand "$f.sy set" -xscrollcommand "$f.sx set"  scrollbar $tkFS(s,dir) -command "$tkFS(l,dir) yview" -bd 1 -highlightt 1  if $unix {    checkbutton $f.hidden -text "Show Hidden" -highlightt 0 -pady 0 \	-var tkFS(hiddendirs) -command tkFS_filterCommand  }  grid $f.label -sticky ew  grid $tkFS(l,dir) $tkFS(s,dir) -sticky news  grid $f.sx -sticky ew  if $unix { grid $f.hidden -sticky ew }  grid columnconfig $f 0 -weight 1  grid rowconfig $f 1 -weight 1  bind $tkFS(l,dir) <Double-Button-1> {    tkFS_filterCommand [%W get [%W nearest %y]]  }  ## FILE LIST  ##  set f $w.list.file  set tkFS(l,file) $f.list  set tkFS(s,file)  $f.sy  label     $f.label -text "Files"  -anchor c  scrollbar $f.sx -command "$tkFS(l,file) xview" -orient h -bd 1 -highlightt 1  listbox   $tkFS(l,file) -relief raised -bd 1 -highlightt 1 -exportsel no \      -yscrollcommand "$f.sy set" -xscrollcommand "$f.sx set"  scrollbar $tkFS(s,file) -command "$tkFS(l,file) yview" -bd 1 -highlightt 1  if $unix {    checkbutton $f.hidden -text "Show Hidden" -highlightt 0 -pady 0 \	-var tkFS(hiddenfiles) -command tkFS_filterCommand  }  grid $f.label - -sticky ew  grid $tkFS(l,file) $tkFS(s,file) -sticky news  grid $f.sx -sticky ew  if $unix { grid $f.hidden - -sticky ew }  grid columnconfig $f 0 -weight 1  grid rowconfig $f 1 -weight 1  bind $tkFS(l,file) <ButtonRelease-1> {    set tkFS(filename) [file join $tkFS(cwd) [%W get [%W nearest %y]]]    $tkFS(e,file) xview end  }  bind $tkFS(l,file) <Double-Button-1> { $tkFS(bbox).ok invoke; break }  bind $tkFS(bbox).filter	<Enter> {+tkFS_setDefault filter}  bind $tkFS(bbox).ok		<Enter> {+tkFS_setDefault ok}  bind $tkFS(bbox).cancel	<Enter> {+tkFS_setDefault ok}