# FileSelection, a file selection widget class for wafe
# 
# This widget classes are defined in terms of the Athena
# TransientShell, Form, Label, Command, Viewport and List widget 
# classes. The following resources can be additionally set 
# FileSelection (in addition to TransientShell resources):
#
#   resource        class     default value
# ===================================================================
#   boldFont        BoldFont  -adobe-times-bold-r-*-*-14-*-*-*-*-*-*-*
#   cancelCallback  Callback  "popdown $ShellName"
#   cancelLabel     Label     "Cancel"
#   directory       Directroy ./
#   filter          Filter    *
#   filterLabel     String    "Filter:"
#   lines           Lines     10
#   listFont        PlainFont -adobe-times-medium-r-*-*-12-*-*-*-*-*-*-*
#   okCallback      Callback  "popdown $ShellName"
#   okLabel         Label     "Ok"
#   plainFont       PlainFont -adobe-times-medium-r-*-*-14-*-*-*-*-*-*-*
#
# The following sample script illustrates the usage of this
# widget class.
#
#---------
#   Command PressMe topLevel callback {popup fs none}
#   FileSelection fs c filter *.tcl \
#      okCallback {puts stderr {Hi man, it's working <%s>!}}
#   realize
#---------
#
# Gustaf Neumann,           Mohegan Lake, Jan 30, 1993


proc FileSelection {name parent args} {
  global _wafeWidget
  set resList {}

  if [_managedWidget args] { 
    set S [TransientShell $name $parent destroyCallback {_destroyCallback %W}]
  } else { 
    set S [TransientShell $name $parent unmanaged destroyCallback {_destroyCallback %W}]
  }
  callback $S popupCallback positionCursor 0

  set wClass [lindex [info level 0] 0]
  set _wafeWidget($S) $wClass

  _defaultValue $S boldFont BoldFont \
    -adobe-times-bold-r-*-*-14-*-*-*-*-*-*-*
  _defaultValue $S cancelCallback Callback "popdown $S"
  _defaultValue $S cancelLabel String Cancel
  _defaultValue $S directory Directroy ./
  _defaultValue $S filter Filter *
  _defaultValue $S filterLabel String Filter:
  _defaultValue $S lines Lines 10
  _defaultValue $S listFont PlainFont \
    -adobe-times-medium-r-*-*-12-*-*-*-*-*-*-*
  _defaultValue $S okCallback Callback {puts "<%s> was selected"}
  _defaultValue $S okLabel String Ok
  _defaultValue $S plainFont PlainFont \
    -adobe-times-medium-r-*-*-14-*-*-*-*-*-*-*

  for {set i 0;set nargs [llength $args]} {$i<$nargs} {incr i} {
    set arg [lindex $args $i] 
    if {[lsearch -exact $resources $arg] != -1} {
      set $arg [lindex $args [incr i]]
    } else {
      lappend resList [lindex $args $i]
      lappend resList [lindex $args [incr i]]
    } 
  }

  mergeResources topLevel \
    *$name-F*Label.borderWidth 0 \
    *$name-F*Command.font $boldFont \
    *$name-F*Text*editType edit \
    *$name-F*left chainLeft \
    *$name-F*Command.right chainLeft

  set F [Form $name-F $S]

  set DL [MenuButton directoryLabel $F \
    label {Change Directory}  menuName dirs  font $boldFont \
    right chainLeft  translations {#override
      <Btn1Down>: XawPositionSimpleMenu(dirs) XtMenuPopup(dirs)
    }]

  set FL [Label filterLabel $F \
    label $filterLabel font $boldFont justify right \
    fromHoriz $DL right chainLeft]
  set FT [Text filter $F \
    type string  string $filter  font $plainFont \
    fromHoriz $FL right chainRight translations {#override
      <Key>Return: no-op()
    }]
  
  set maxWidth [expr [gV $DL width]+[gV $FL width]+[gV $FT width]]

  set DT [Label directory $F \
    justify left  font $plainFont  label $directory \
    fromVert $DL right chainRight]

  set V [Viewport view $F \
    height $lines  width $maxWidth  allowVert true \
    fromVert $DT  right chainRight]
  set L [List files $V \
    defaultColumns 1  font $listFont  callback "_fsCallback $S %i %s"]

  sV $V height [expr [gV $L internalHeight]+\
		$lines*([fontHeight $L font]+[gV $L rowSpacing])]

  set C [Command cancel $F \
    label $cancelLabel  callback $cancelCallback \
    fromVert $V ]
  Command ok $F \
    label $okLabel  callback "_fsOkCallback $S $L" \
    fromVert $V  fromHoriz $C

  sV $FT callback "_fsSetDirectory $S \[gV $DT label\]" 
  _fsSetDirectory $S $directory
  foreach res $resources {
    trace variable $res w _${wClass}_change
  }
  return $S
}

proc _FileSelection_change {n1 n2 op} {
  global $n1
  regexp {^(.*),(.*)$} $n2 all id res
  set newValue [set ${n1}($n2)]
  #  puts "name <$id> <$n2> <$res>" 
  switch -exact $res {
    filter {
      sV $id*filter string [set ${n1}($n2)]
      _fsSetDirectory $id [gV $id*directory label]
    }
    directory {
      _setValues $id*directory string $newValue
      _fsSetDirectory $id $newValue
    }
    boldFont {
      _setValues $id*directoryLabel font $newValue
      _setValues $id*filterLabel font $newValue
      _setValues $id*cancel font $newValue
      _setValues $id*ok font $newValue
    }
    okLabel {
      _setValues $id*ok label $newValue
    }
    cancelLabel {
      _setValues $id*cancel label $newValue
    }
    cancelCallback {
      _setValues $id*cancel callback $newValue
    }
    filterLabel {
      _setValues $id*filterLabel label $newValue
    }
    plainFont {
      _setValues $id*filter font $newValue
      _setValues $id*directory font $newValue
    }
    listFont {
      _setValues $id*files font $newValue
      _fsSetDirectory $id [gV $id*directory label]      
      foreach w [gV $id*dirs children] {
	_setValues $w font $newValue
      }
    }
    lines {
      set L $id*files
      _setValues $L height [expr [gV $L internalHeight]+\
	$newValue*([fontHeight $L font]+[gV $L rowSpacing])]
    }
  }
}

proc _fsSetDirectory {id directory} {
  global fsCache
  if {[info exists fsCache($id)] && 
      [string match $fsCache($id) $directory]} {
  } else {
    set oldMenu $id*dirs
    if [isWidget $oldMenu] { destroyWidget $oldMenu }
    
    set oldDir [pwd]
    if [string match /* $directory] {
      cd $directory
    } else {
      cd [gV $id*directory label]/$directory
    }
    sV $id*directory label [set fsCache($id) [pwd]]

    if [file isdirectory ../] {set files ../}
    set dirs {}
    foreach f [glob *] {
      if [file isdirectory $f] {
	lappend files $f/
	lappend dirs $f
      } else  {
	lappend files $f
      }
    }
    set fsCache($id,files) [lsort $files]
    cd $oldDir

    set M [SimpleMenu dirs $id*directoryLabel]
    set cnt 0
    set path /
    set font [gV $id listFont]
    foreach dir [split $fsCache($id) /] {
      append path $dir/
      set E [SmeBSB d[incr cnt] $M \
	label $dir/ callback "_fsSetDirectory $id $path" \
	font $font]
    }
    set popupon $E
    foreach dir $dirs {
      SmeBSB d[incr cnt] $M \
	label ./$dir callback "_fsSetDirectory $id $path/$dir" \
	font $font
    }
    sV $M popupOnEntry $E
  }
  set filter [gV $id*filter string]
  foreach f $fsCache($id,files) {
    if {[string match */ $f] || [string match $filter $f]} {
      lappend sfiles $f
    }
  }
  XawListChange $id*files 0 0 1 List $sfiles
  _setValues $id*ok sensitive false
}


proc _fsOkCallback {id listId} {
  set result [XawListShowCurrent $listId]
  _fsCallback $id [set ${result}(list_index)] [set ${result}(string)]
}

proc _fsCallback {id item selection} {
  if [string match */ $selection] {
    _fsSetDirectory $id $selection
  } else {
    global _FileSelection
    _setValues $id*ok sensitive true
    set cmd $_FileSelection($id,okCallback)
    regsub -all %s $cmd $selection cmd
    regsub -all %i $cmd $item cmd
    eval $cmd
  }
}
