#! @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}

  bindrecursive $w.list.dir	<Enter> {+tkFS_setDefault filter}
  bindrecursive $w.filter	<Enter> {+tkFS_setDefault filter}
  bindrecursive $w.file		<Enter> {+tkFS_setDefault ok}
  bindrecursive $w.list.file	<Enter> {+tkFS_setDefault ok}

  # Only return when the user has supplied a value --------------

  bind $w		<Escape> "$tkFS(bbox).cancel invoke; break"
  bind $tkFS(e,filter)	<Return> "tkFS_filterCommand; break"
  bind $tkFS(e,file)	<Return> "$tkFS(bbox).ok invoke; break"

  $tkFS(e,filter) xview end
  $tkFS(e,file) xview end

  tkFS_filterCommand $tkFS(cwd)

  update idletasks
  set width 350
  wm minsize $w [winfo reqwidth $w] [winfo reqheight $w]
  wm geometry $w ${width}x[winfo reqheight $w]+[expr ([winfo screenwidth $w]-$width)/2]+[expr ([winfo screenheight $w]-[winfo reqheight $w])/2]

  wm deiconify $w
  focus $tkFS(e,file)
  if $arg(grab) { grab set $w }
  tkwait window $w

  if [string length $tkFS(filename)] {
    return $tkFS(filename)
  } elseif $arg(cancelexc) {
    return -code 64 "File Selection Cancelled"
  } else {
    return {}
  }
}

###
# Horizontal Paned Window Procs from code by Ken Corey @ Sun.
###
## pane - given two widgets, pane them inside that parent.
## The widgets should have the same parent and be the only two in the frame.
# ARGS:	left	- the left/upper widget in the pane
#	right	- the right/lower widget pane
# OPTS:	-dynamic	Whether to dynamically resize or to resize only
#			when the user lets go of the handle
#	-fraction	Initial fraction of window to give to the left pane
#	-handle		A widget to use for the handle
#	-orient		Orientation of window (horiz or vert tiling)
#	-parent		A widget other to use for the panes
##
proc pane {left right args} {
  ## left == top, right == bottom
  array set opt {orn hor par {} hnd {} dyn 1 frc 0.4}
  for {set i 0;set num [llength $args];set cargs {}} {$i<$num} {incr i} {
    set arg [string tolower [lindex $args $i]]
    set val [lindex $args [incr i]]
    switch -glob -- $arg {
      -d*	{ set opt(dyn) [regexp -nocase {^(1|yes|true|on)$} $val] }
      -f*	{ set opt(frc) $val }
      -h*	{ set opt(hnd) $val }
      -o*	{ set opt(orn) $val }
      -p*	{ set opt(par) $val }
      default	{ return -code error "unknown option \"$str\"" }
    }
  }
  ## NOTE: Abuse of tkPriv variables (although no conflicts)
  global tkPriv
  if [string match {} $opt(par)] { set opt(par) [winfo parent $left] }
  if [string match h* $opt(orn)] {
    set d1 height; set d2 width; set d3 x; set d4 h; set anc ne
  } else {
    set d1 width; set d2 height; set d3 y; set d4 v; set anc sw
  }
  if [string match {} $opt(hnd)] {
    set opt(hnd) [frame $opt(par)._hand -bd 2 -$d2 4 \
		      -relief raised -cursor sb_${d4}_double_arrow]
  }
  place $left -rel$d1 1
  place $right -rel$d1 1 -rel$d3 1 -anchor $anc
  place $opt(hnd) -rel$d1 1

  bind $opt(hnd) <ButtonPress-1> "
    set tkPriv(x) \[winfo root$d3 $opt(par)\]
    set tkPriv(y) \[winfo $d2 $opt(par)\].0
  "
  bind $opt(hnd) <B1-Motion> "pane_motion %[string toup $d3] \
	$opt(orn) $left $right $opt(par) $opt(hnd) $opt(dyn)"
  if !$opt(dyn) {
    bind $opt(hnd) <ButtonRelease-1> "pane_motion %[string toup $d3] \
	$opt(orn) $left $right $opt(par) $opt(hnd) 1"
  }
    
  pane_place $opt(orn) $opt(frc) $left $right $opt(par) $opt(hnd)
}

proc pane_place {o f l r p h} {
  if [string match h* $o] {
    place $l -relwidth $f
    place $h -relx $f
    place $r -relwidth [expr 0.99-$f]
  } else {
    place $l -relheight $f
    place $h -rely $f
    place $r -relheight [expr 0.99-$f]
  }
}

proc pane_motion {x o l r p h {dyn 0}} {
  global tkPriv
  set f [expr ($x-$tkPriv(x))/$tkPriv(y)]
  puts [list ($x-$tkPriv(x))/$tkPriv(y) == $f]
  if {$f>0.1 && $f<0.9} {
    if $dyn {
      pane_place $o $f $l $r $p $h
    } elseif [string match h* $o] {
      place $h -relx $f
    } else {
      place $h -rely $f
    }
  }
}

# --- BEGINNING OF PRIVATE PROCEDURES ------------

proc tkFS_setDefault b {
  global tkFS

  if [string match $b ok] {
    $tkFS(bbox).filtbrd configure -relief flat
    $tkFS(bbox).default configure -relief sunken
    focus $tkFS(e,file)
  } else {
    $tkFS(bbox).default configure -relief flat
    $tkFS(bbox).filtbrd configure -relief sunken
    focus $tkFS(e,filter)
  }
}

proc tkFS_filterCommand {{dir {}}} {
  global tkFS

  if {[string match $dir {<< PARENT >>}]} {
    tkFS_chdir ..
  } elseif {[string comp $dir {}] && [string comp $dir .]} {
    tkFS_chdir $dir
  } else {
    tkFS_chdir [file dir $tkFS(filter)]
  }

  set filemask  [file tail $tkFS(filter)]
  
  set tkFS(filter)	[file join $tkFS(cwd) $filemask]
  if [file isdir $tkFS(filename)] {
    set tkFS(filename)	$tkFS(cwd)
  } else {
    set tkFS(filename)	[file join $tkFS(cwd) [file tail $tkFS(filename)]]
  }

  $tkFS(l,dir) delete 0 end
  if {![regexp {^(.:)?/$} $tkFS(cwd)] && \
      [string comp [file dir $tkFS(cwd)] $tkFS(cwd)]} {
    $tkFS(l,dir) insert end "<< PARENT >>"
  }
  foreach d [lsort [tkFS_dirlist $tkFS(cwd)]] {
    set d [file tail $d]
    if {[string comp $d .] && [string comp $d ..]} {
      $tkFS(l,dir) insert end $d
    }
  }

  $tkFS(l,file) delete 0 end
  foreach f [lsort [tkFS_filelist $tkFS(cwd) $filemask]] {
    if {![file isdir $f] && [eval $tkFS(filetest)]} {
      $tkFS(l,file) insert end [file tail $f]
    }
  }
  $tkFS(e,filter) xview end
  $tkFS(e,file) xview end
}

proc tkFS_dirlist d {
  global tkFS
  set dirs [glob -nocomplain $d*$tkFS(sep)]
  if $tkFS(hiddendirs) {
    set dirs [concat $dirs [glob -nocomplain $d.*$tkFS(sep)]]
  }
  return $dirs
}

proc tkFS_filelist {d f} {
  global tkFS
  set files [glob -nocomplain $d$f]
  if $tkFS(hiddenfiles) {
    set files [concat $files [glob -nocomplain $d.$f]]
  }
  return $files
}


proc tkFS_chdir d {
  global tkFS tcl_platform

  # tkFS(cwd) is the current directory, with a trailing slash
  switch $d {
    .  {}
    .. {
      set tkFS(cwd) \
	  [string trimr [file dir $tkFS(cwd)] /]/
    }
    default {
      switch $tcl_platform(platform) {
	windows {
	  if [string match ?:* $d] {
	    set tkFS(cwd) $d/
	  } elseif {[string match /* $d]} {
	    set tkFS(cwd) [string index $tkFS(cwd) 0]:$d/
	  } else {
	    append tkFS(cwd) $d/
	  }
	}
	default {
	  if [string match /* $d] {
	    set tkFS(cwd) [string trimr $d /]/
	  } else {
	    append tkFS(cwd) $d/
	  }
	}
      }
    }
  }
  regsub -all {/\./} $tkFS(cwd) {/} tkFS(cwd)
}


# PROCEDURE
#   bindrecursive
#
# DESCRIPTION
#   Binds all widgets beneath a given widget that satisfy a given predicate
#
# ARGUMENTS
#	widget	window to start at
#	event	Pretty obvious,  like <Return>
#	action	Ditto,           like {.foo activate}
#
# RETURN VALUE
#   none
#

proc bindrecursive {w event cmd {self 1}} {
  if $self {bind $w $event $cmd}
  foreach win [winfo children $w] {
    bind $win $event $cmd
    bindrecursive $win $event $cmd
  }
}


# end of file
#
