# fselect.tcl
# 
# Copyright (c) 1994 R"udiger Franke
# All Rights Reserved.
# 
# Redistribution and use in any form, with or without modification, 
# is permitted, provided that the following conditions are met:
# 1. Redistributions of source code must retain the above copyright
#    notice, this list of conditions and the following disclaimer.
# 2. Redistributions in other form must reproduce the above copyright
#    notice, this list of conditions and the following disclaimer in the
#    documentation and/or other materials provided with the distribution.
# 3. All advertising materials mentioning features or use of this software
#    must display the following acknowledgement:
#       This product includes software developed by R"udiger Franke.
# 4. The name of the author may not be used to endorse or promote products
#    derived from this software without specific prior written permission.
# 
# THIS SOFTWARE IS PROVIDED BY THE AUTHOR ``AS IS'' AND ANY EXPRESS OR
# IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES
# OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED.
# IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR ANY DIRECT, INDIRECT,
# INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT
# NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,
# DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
# THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
# (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF
# THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.

#
# constructor for "fselect"
#
proc fselect {w cmd {filter *} {purpose {Open File: }} args} {
  upvar #0 $w this

  # user initializations

  set this(cur,cmd) $cmd
  set this(cur,path) [pwd]
  set this(cur,filter) $filter
  set this(cur,file) {}
  # data initializations

  set this(fselect) $w
  set this(purpose) $w.purpose
  set this(frame0) $w.frame0
  set this(frame1) $w.frame0.frame1
  set this(listbox) $w.frame0.frame1.listbox
  set this(yscroll) $w.frame0.frame1.yscroll
  set this(file) $w.frame0.frame1.file
  set this(frame2) $w.frame0.frame2
  set this(frame3) $w.frame0.frame2.frame3
  set this(ok) $w.frame0.frame2.ok
  set this(cancel) $w.frame0.frame2.cancel
  set this(label0) $w.frame0.frame2.label0
  set this(filter) $w.frame0.frame2.filter
  set this(label1) $w.frame0.frame2.label1
  set this(scan) $w.frame0.frame2.scan
  set this(label2) $w.frame0.frame2.label2
  set this(path) $w.path
  
  # widget creations

  toplevel $this(fselect) -class Fselect \
    -borderwidth "2m"
  label $this(purpose)  \
    -anchor "w" \
    -text "$purpose"
  frame $this(frame0) 
  frame $this(frame1) 
  listbox $this(listbox)  \
    -geometry "25x12" \
    -relief "sunken" \
    -yscrollcommand "$this(yscroll) set"
  scrollbar $this(yscroll)  \
    -command "$this(listbox) yview" \
    -relief "sunken"
  entry $this(file)  \
    -relief "sunken" \
    -textvariable "$w\(cur,file)"
  frame $this(frame2) 
  frame $this(frame3)  \
    -borderwidth "1" \
    -relief "sunken"
  button $this(ok)  \
    -command "$w ok" \
    -text "OK"
  button $this(cancel)  \
    -command "destroy $w" \
    -text "Cancel"
  label $this(label0)  \
    -anchor "w" \
    -text "Filter: "
  entry $this(filter)  \
    -relief "sunken" \
    -textvariable "$w\(cur,filter)" \
    -width "10"
  label $this(label1) 
  button $this(scan)  \
    -command "$w scan" \
    -text "Filter"
  label $this(label2) 
  entry $this(path)  \
    -relief "sunken" \
    -textvariable "$w\(cur,path)"
  
  # widget layouting

  pack $this(file) -side top -fill x
  pack $this(listbox) -side left -fill both -expand true -pady 2m
  pack $this(yscroll) -side right -fill y -pady 2m
  pack $this(label1)
  pack $this(frame3) -fill x -pady 2m -padx 2m
  pack $this(ok) -in $this(frame3) -padx 1m -pady 1m -fill x
  pack $this(cancel) -padx 2m -fill x
  pack $this(label2) -side top -pady 2m
  pack $this(scan) -side top -fill x -padx 2m
  pack $this(filter) -fill x -padx 2m -pady 2m -side top
  pack $this(frame1) -side left -fill both -expand true
  pack $this(frame2) -side right -fill y -padx 2m
  pack $this(purpose) -fill x
  pack $this(frame0) -fill both -expand true
  pack $this(path) -fill x
  
  useCreateComponent fselect $w $args

  # user additions

  wm title $w "Select File"
  wm minsize $w 10 10
  
  grab $w
  
  bind $w <Return> "$this(ok) flash; $this(ok) invoke"
  bind $this(file) <Return> "$this(ok) flash; $this(ok) invoke"
  bind $this(filter) <Return> "$this(scan) flash; $this(scan) invoke"
  
  tk_listboxSingleSelect $this(listbox)
  
  bind $this(listbox) <ButtonRelease-1> "
    %W select from \[%W nearest %y\]
    %W select to \[%W nearest %y\]
    set $w\(cur,file) \[%W get \[%W nearest %y\]\]
  "
  
  bind $this(listbox) <Button-1> "
    %W select from \[%W nearest %y\]
    %W select to \[%W nearest %y\]
    set $w\(cur,file) \[%W get \[%W nearest %y\]\]
  "
  
  bind $this(listbox) <Key> "
    %W select from \[%W nearest %y\]
    %W select to \[%W nearest %y\]
    set $w\(cur,file) \[%W get \[%W nearest %y\]\]
  "
  
  bind $this(listbox) <Double-ButtonPress-1> "
    $this(ok) invoke
  "
  
  bind $this(listbox) <Return> "
    %W select from \[%W nearest %y\]
    %W select to \[%W nearest %y\]
    set $w\(cur,file) \[%W get \[%W nearest %y\]\]
    $this(ok) invoke
  "
  
  bind $this(path) <Return> "
    set $w\(cur,file) \[set $w\(cur,path)\]
    $w ok
  "
  
  # fill up listbox
  $w scan

  return $w
}

#
# method "ok"
#
proc fselect::ok {w } {
  upvar #0 $w this

  if {[file isdirectory $this(cur,file)] != 0} {
    cd $this(cur,file)
    set this(cur,path) [pwd]
    set this(cur,file) {}
    $w scan
  } else {
    after 1 [list eval $this(cur,cmd) \"$this(cur,file)\"]
    destroy $w
  }
}

#
# method "scan"
#
proc fselect::scan {w } {
  upvar #0 $w this

  $this(listbox) delete 0 end
  
  if {$this(cur,filter) == {}} {
    set this(cur,filter) *
  }
  
  foreach file [exec ls -a $this(cur,path)] {
    if {[string compare $file "."] != 0} {
      if {[file isdirectory $file]
          || [string match $this(cur,filter) $file]} {
        $this(listbox) insert end $file
      }
    }
  }
  
}

