# This program is part of Geoduck, a set of graphical user
# interfaces for UNIX programs.
# Copyright (C) 2002 Allen B. Downey
#
# This program is free software; you can redistribute it and/or
# modify it under the terms of the GNU General Public License
# as published by the Free Software Foundation; either version 2
# of the License, or (at your option) any later version.
#
# This program is distributed in the hope that it will be useful,
# but WITHOUT ANY WARRANTY; without even the implied warranty of
# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
# GNU General Public License for more details.
#
# For a copy of the GNU General Public License, go to
# www.gnu.org/copyleft/gpl.html
# or write to the Free Software Foundation, Inc.
# 59 Temple Place - Suite 330, Boston, MA  02111-1307, USA.
#
# Contact the author: me@allendowney.com

# Note on callbacks...
# Use brackets when there is nothing to evaluate now
#     rb "Output to file:" rb_output file {getEntry en_output " -o "}
#
# Use quotes if there is something to evaluate now, and none
# of the elements contain spaces
#
# Use [list] if there is something to evaluate now and an element
# might contain spaces (example from kv)
#
#    en 0 $name$key [list getKV $name $flag $delim]
#    bu "help" bu_help$topic [list execFillText text $cmd] -side right
    

# GLOBAL ARRAYS ----------------------------------------------------
#
# widget   : for each widget nickname, contains the widget's path
#            the nickname for a checkbutton is the same as its variable name
#            the nickname for a radiobutton is varname-optname
# st       : contains the variables associated with the widgets
# opt: for each variable or value, contains the corresponding flag
# def: the default value for the named widget


# GENERIC PROCS (many apps override these) ---------------------------

proc frConfig {name} {
#   config $name -bd 1 -relief solid
}

proc showCommand {} {
    fillEntry en_command [getCommand]
    if {[cbValue autotest]} { test }
}

proc test {} {
    cursorWatch
    set cmd [enValue en_command]
    fillText text [execCatch $cmd]
    cursorNormal
}

proc execute {} {
    cursorWatch
    set cmd [enValue en_command]
    puts $cmd
    puts [execCatch $cmd]
    cursorNormal
}

# OPTIONS -------------------------------------------------------

proc getOption {name} {
    global opt

    if {[info exists opt($name)]} { return $opt($name) }
}

proc setOption {name flag} {
    global widget opt

    if {[info exists opt($name)] && $flag != $opt($name)} {
	error "The option $name is already defined as $opt($name)."
	return
    }
    set opt($name) [preSpace $flag]

    # for short-format flags, create a key binding:
    # this turns out to be hard to implement for menubuttons,
    # and possibly not all that useful
    #if {[string length $flag] == 2} {
    #	set letter [string index $flag 1]
    #	bind . <$letter> "$widget($name) invoke"
    #}
}

proc preSpace {flag} {
    if {$flag != ""} {
	return " $flag"
    }
}

proc mypack {w args} {
    if {[gridding]} {
	eval {gridit $w -sticky ew} $args
    } else {
	eval {pack $w -fill x -expand 1} $args
    }
}

proc frpack {w args} {
    if {![gridding]} {
	eval {pack $w} $args
    }
}

proc grpack {w args} {
    if {[gridding]} {
	eval {grid $w} $args
    }
}

proc gridding {} {
    global widget
    
    set frame [file extension $widget(frame)]
    return [regexp ^.gr $frame]
}

# BUTTON
proc bu {text name command args} {
    global widget
    set w $widget(frame).$name
    set widget($name) $w

    button $w -text $text -command $command
    eval {mypack $w} $args
    frpack $w -expand 0
    evalCatch "buConfig $name"
}

proc buSmall {name} {
    global widget
    config $name -padx 1 -pady 1
}

# LABEL
set la 0
proc la {{text ""} {name ""} args} {
    global la widget

    if {[isOption $name]} {
	set args "$name $args"
	set name ""
    }
    if {$name == ""} {
	set name la$la
	incr la
    }
    set w $widget(frame).$name
    set widget($name) $w

    label $w -text $text -anchor w
    eval {mypack $w} $args
    frpack $w -expand 0
    evalCatch "laConfig $name"
}

proc laEntry {text entry args} {
    fr
    la $text -side left
    eval {en 0 $entry} $args
    endfr
}

proc isOption {name} {
    return [regexp ^- $name]
}


# CHECKBUTTON
proc cb {text name {flag ""} args} {
    global widget
    set w $widget(frame).$name
    set widget($name) $w

    setOption $name $flag
    checkbutton $w -text $text -variable st($name) -anchor w \
	-command showCommand
    eval {mypack $w} $args
    evalCatch "cbConfig $name"
}

proc cr {text name {flag ""} args} {
    eval {cb $text $name $flag} $args
    cbValue $name 1
}

proc invoke {name args} {
    global widget

    eval {$widget($name) invoke} $args
}

proc entryinvoke {name index args} {
    global widget

    eval {$widget($name).m invoke $index} $args
}

# RADIOBUTTON
proc rb {text var val {flag ""} args} {
    global st widget
    set name $var-$val
    set w $widget(frame).$name
    set widget($name) $w

    # if this is the first value for this variable, make it the default
    if {![info exists st($var)]} {
	set st($var) $val
    }
    setOption $name $flag
    radiobutton $w -text $text -var st($var) -val $val -anchor w \
	-command showCommand
    eval {mypack $w} $args
    evalCatch "rbConfig $name"
}

# ENTRY
proc en {width name {flag ""} {default ""} args} {
    global st widget def

    if {$default != ""} {
	en_def $width $name $flag $default
	return
    }
    set fr $widget(frame)
    set w $fr.$name
    set widget($name) $w

    entry $w -width $width
    eval {mypack $w} $args

    set st($name) ""

    setOption $name $flag
    bind $w <KeyRelease> "+showCommand"
    evalCatch "enConfig $name"
}

proc en_def {width name flag default} {
    global st widget def

    fr
    set fr $widget(frame)
    set w $fr.$name
    set widget($name) $w
    set def($name) $default

    en $width $name $flag "" -side left

    if {$default == "browse"} {
	bu "browse" bu_def-$name "browseCommand $name"
	set st($name-dir) [pwd]
    } else {
	fillEntry $name $default    
	bu "def" bu_def-$name "fillEntry $name \{$default\}; showCommand"
    }

    config bu_def-$name -padx 1 -pady 1
    endfr
}

set states(0) disabled
set states(1) normal

proc configState {w bool} {
    global states
    $w config -state $states($bool)
}

# MENUBUTTON
proc mb {text name val {flag ""} args} {
    global opt st widget

    # if the menubutton already exists, just add a new item
    if {[info exists widget($name)]} {
	mi $text $name $val $flag
	if {$args != ""} {
	    eval repack $name $args
	}
	return
    }
    
    # otherwise create the new menubutton
    set w $widget(frame).$name
    set widget($name) $w
    set widget($name-m) $w.m
    set st($name) $val

    menubutton $w -text $text -menu $w.m -relief sunken -padx 5 -pady 1
    menu $w.m -relief sunken -tearoff 0
    eval mypack $w -padx 2 $args
    evalCatch "mbConfig $name"

    # add the first menu item
    mi $text $name $val $flag
}

# MENU ITEM
proc mi {text name val flag {index last}} {
    global widget

    setOption $name-$val $flag

    $widget($name).m insert $index command -label $text \
	-command [list miCommand $text $name $val]
}

proc entryconf {name index args} {
    global widget
    eval {$widget($name).m entryconf $index} $args
}

proc miCommand {text name val} {
    global widget st

    config $name -text $text
    set st($name) $val
    showCommand
}

# TE
proc te {name {height 25}} {
    global widget

    set font *-courier-medium-r-normal--*-140-*
    set w $widget(frame).$name
    set s $widget(frame).$name-scroll
    set widget($name) $w

    text $w -width 80 -height $height -font $font -yscrollcommand "$s set"
    scrollbar $s -command "$w yview"
    pack $w -side left -fill both -expand 1
    pack $s -side left -fill y

    evalCatch "teConfig $name"
}

# LI
# parent frame gets the name $widget($name)
# children are  $widget($name).lis and $widget($name).sc
# listboxes are $widget($name).lis.li0 and so on
proc li {name {n 1} args} {
    global st widget

    eval fr fr_$name -pady 10 $args
    set widget($name) $widget(frame)
    set st($name) $n

    fr lis -side left
    config frame -bd 3 -relief sunken
    set w $widget(frame)

    for {set i 0} {$i < $n} {incr i} {
	listbox $w.li$i -yscrollcommand "$widget($name).sc set" -relief flat
	pack $w.li$i -side left -fill both
    }
    endfr

    scrollbar $widget($name).sc -command "li_scroll $name"
    pack $widget($name).sc -side left -fill both

    endfr

    evalCatch "liConfig $name"
}

proc li_scroll {name args} {
    global st widget
    
    for {set i 0} {$i < $st($name)} {incr i} {
	eval {$widget($name).lis.li$i yview} $args
    }
}

# FRAME

set fr 0
proc fr {{name ""} args} {
    global fr widget

    if {[isOption $name]} {
	set args "$name $args"
	set name ""
    }
    if {$name == ""} {
	set name fr[incr fr]
    }
    set w $widget(frame).$name
    set widget($name) $w

    frame $w
    eval {mypack $w} $args
    frpack $w -anchor n
    evalCatch "frConfig $name"
    set widget(frame) $w
}

proc endfr {args} {
    global widget

    if {[llength $args] == 1} {
	set frame [tail $widget(frame)]
	if {$frame != $args} {
	    error "\nArgument to endfr ($args) doesn't match current frame ($widget(frame))."
	}
    }

    set widget(frame) [parent $widget(frame)]
}

proc pushfr {name} {
    global widget

    append widget(frame_stack) $widget(frame)
    set widget(frame) $widget($name)
}

proc popfr {} {
    global widget

    if {[llength $widget(frame_stack)] == 0} {
	return
    }
    set widget(frame) [lindex $widget(frame_stack) end]
    set widget(frame_stack) [lrange $widget(frame_stack) 0 end-1]
}

proc tail {w} {
    return [lindex [split $w .] end]
}

set grid(gr) 0
proc gr {cols {weights {1}} args} {
    global grid widget

    set name gr[incr grid(gr)]
    eval {fr $name} $args
    set f $widget(frame)
    set grid(cols$f) $cols
    set grid(i$f) 0
    set grid(j$f) 0

    gridweights $weights
}

proc gridweights {weights} {
    set i 0
    foreach weight $weights {
	gridconf column $i -weight $weight
	incr i
    }
}

proc gridconf {rc n args} {
    global widget
    set conf conf

    eval {grid $rc$conf $widget(frame) $n} $args
}

proc gridit {w args} {
    global grid widget
    set f $widget(frame)

    set i $grid(i$f)
    set j $grid(j$f)

    eval {grid $w -row $i -col $j} $args

    incr grid(j$f) [colincr $args]
    if {$grid(j$f) == $grid(cols$f)} {
	set grid(j$f) 0
	incr grid(i$f)
    }
}

proc colincr {options} {
    set i [lsearch $options -columnspan]
    if {$i == -1} { return 1 }
    return [lindex $options [expr 1+$i]]
}

proc endgr {args} {
    global grid
    set grid(active) 0
    endfr
}

proc parent {w} {
    file root $w
}

proc frSpace {args} {
    eval {fr -expand 0} $args
    endfr
}

proc spacer {} {
    fr -side left -fill y -padx 10
    config frame -bg black -bd 2 -relief solid
    endfr
}




# TOPLEVEL

proc tl {title name x y} {
    global widget

    set w .$name
    set widget($name) $w
    pushfr $name

    toplevel $w

    wm title $w $title
    set x [expr $x + [winfo rootx .]]
    set y [expr $y + [winfo rooty .]]
    wm geom $w +$x+$y
}

proc ca {name {width 0} {height 0}} {
    global widget

    set w $widget(frame).$name
    set widget($name) $w
    canvas $w -width $width -height $height
    pack $w
}

# DE: delete the state associated with the given name
proc de {name} {
    global widget st

    if {[info exists widget($name)]} {
	puts $widget($name)
	destroy $widget($name)
	unset widget($name)
    }
    if {[info exists st($name)]} {
	unset st($name)
    }
}

proc kvs {n prefix flag {delim :}} {
    gr 2 {1 1}
    for {set i 1} {$i <= $n} {incr i} {
	kv $prefix$i $flag $delim
    }
    endgr
}

proc kv {name flag {delim :}} {
    set key key
    set val val
    en 0 $name$key [list getKV $name $flag $delim]
    en 0 $name$val
}

proc getKV {name flag delim} {
    set key key
    set val val
    set flag [getEntry $name$key $flag]
    if {$flag != ""} {
	append flag [getEntry $name$val $delim]
    }
    return $flag
}



proc clearText {name} {
    global widget
    
    set w $widget($name)
    $w delete 1.0 end
}

proc addText {name text} {
    global widget
    
    set w $widget($name)
    set lines [split $text \n]
    foreach line $lines {
	$w insert end $line\n
    }
}

proc fillText {name text} {
    clearText $name
    addText $name $text
}

proc errorText {text} {
    global widget

    if {![info exists widget(error)]} {
	te error
	config error -height 10
    }
    fillText error $text
}

proc destroyError {} {
    global widget

    if {[info exists widget(error)]} {
	destroy $widget(error)
	destroy $widget(error)-scroll
	unset widget(error)
    }
}

proc topFrame {} {
    global st widget

    set widget(frame) ""
    fr -pady 5

    fr -side left -padx 5
      en 0 en_command ""
      set font *-helvetica-bold-r-normal--*-160-*
      config en_command -font $font -background white -relief flat
      configState $widget(en_command) 0

      fr -pady 10
        bu  Save      bu_save      save     -side left
        config bu_save -padx 1 -pady 1
        set entry en_save
        en 10 $entry "" browse
        # decided the following binding was error-prone
        # bind $widget($entry) <Return> "$widget(bu_save) invoke"
      endfr

      fr
      la "Additonal flags:" left
      en 0 en_add ""
      endfr
    endfr

    set dir ~/bin
    if {[file exists $dir]} {
	set st($entry-dir) $dir
	fillEntry $entry $dir
    }

    fr fr_buttons
    fr -side left -padx 5 -fill both
    bu  Test      bu_test      test  -fill both
    config bu_test -borderwidth 5 -relief raised
    bind . <Return> "+test"
    cb  Autotest? autotest 
    endfr

    fr -side left -padx 5 -fill both
    bu  Execute   bu_execute   execute  
    bu  Quit      bu_quit      exit     
    endfr
    endfr fr_buttons 

    fr fr_later -padx 5
    endfr

    endfr
}

proc bottomFrame {} {
    global widget

    fr fr_bottom -pady 10
    te text
    endfr
}

proc colorMenu {} {
    fr
    la  "Color:" left 
    mb  "never"         mb_color     never      ""
    mb  "always"        mb_color     always     --color=always
    mb  "auto"          mb_color     auto       --color=auto 
    endfr
}

proc save {} {
    global env

    set file [enValue en_save]
    set file [removeMessage $file]
    if {![filePermission $file]} { return }
    if {![fileOverwrite $file]} { return }

    set cmd [enValue en_command]
    set fp [open $file w]
    puts $fp "\#!$env(SHELL)"
    puts $fp ""
    puts $fp "$cmd"
    close $fp
    exec chmod u+x [glob $file]
    puts "This command has been saved in $file:"
    puts $cmd
}

proc removeMessage {file} {
    set list [split $file " : "]
    return [lindex $list 0]
}

# GETFLAGS ------------------------------------------------------

proc l {flag} { return "\" $flag\"" }
proc r {flag} { return "\"$flag \"" }
proc b {flag} { return "\" $flag \"" }

proc getFlags {{names ""}} {
    global st

    if {$names == ""} {
	set names [array names st]
    }

    set flags ""
    foreach name $names {
	append flags [handle $name]
    }
    append flags [getEntry en_add " "]
    return $flags
}

proc handle {name} {
    set suffix Handle
    if {[string index $name 2] == "_"} {
	set prefix [string range $name 0 1]
    } else {
	set prefix ""
    }
    set ret [catch {eval $prefix$suffix $name} text]
    if {$ret == 0} {
	return $text
    }
}

proc Handle {name} {
    set flag [getOption $name]
    evalFlag $flag
}

proc cbHandle {name {invert 0}} {
    global st

    if {$st($name) ^ $invert} {
	set flag [getOption $name]
	evalFlag $flag
    }
}

proc crHandle {name} {
    cbHandle $name 1
}

proc rbHandle {name} {
    global st
    set flag [getOption $name-$st($name)]
    evalFlag $flag
}

proc evalFlag {flag} {
    set ret [catch {eval $flag} text]
    if {$ret == 0} {
	return $text
    } else {
#	puts $text
	return $flag
    }
}

proc mbHandle {name} {
    rbHandle $name
}    

proc enHandle {name} {
    set flag [getOption $name]
    set flag [evalFlag $flag]
    if {$flag != ""} {
	getEntry $name $flag
    }
}

proc getValue {name} {
    set suffix Value
    set prefix [lindex [split $name _] 0]
    set names [info procs $prefix$suffix]
    if {[llength $names] > 0} {
	return [$prefix$suffix $name]
    }
}

proc enValue {name} {
    global widget
    return [$widget($name) get]
}

proc cbValue {name args} {
    global st
    if {$args == ""} {
#	if {[info exists st($name)]} { 
	    return $st($name)
#	} else {
#	    return ""
#	}
    } else {
	set st($name) $args
    }
}

proc rbValue {name args} {
    eval {cbValue $name} $args
}

proc mbValue {name args} {
    eval {cbValue $name} $args
}


# EXEC ------------------------------------------------------

proc evalCatch {cmd} {
    set ret [catch {eval $cmd} text]
    return $text
}

proc execCatch {cmd} {
    global env
    set ret [catch {exec $env(SHELL) -c $cmd} text]
    return $text
}

proc execFillText {text cmd} {
    fillText $text [execCatch $cmd]
}

proc execPipe {cmd} {
    global env widget

    set fp [open "| $env(SHELL) -c $cmd" r]
    set text [read $fp]
    close $fp
    return $text
}

# CONFIG ------------------------------------------------------

proc config {name args} {
    global widget
    eval "$widget($name) config $args"
}

proc widgetfo {cmd name args} {
    global widget
    eval "winfo $cmd $widget($name) $args"
}

proc repack {name args} {
    global widget
    eval "pack $widget($name) $args"
}

proc unpack {name args} {
    global widget
    eval "pack forget $widget($name) $args"
}

proc show {name args} {
    global widget
    set info $widget(info-$name)
    if {![winfo ismapped $widget($name)]} {
	eval {repack $name} $info $args
    }
}

proc hide {name} {
    global widget
    update
    set widget(info-$name) [pack info $widget($name)]
    if {[winfo ismapped $widget($name)]} {
	unpack $name
    }
}

proc showing {name} {
    global widget
    update
    return [winfo ismapped $widget($name)]
}

# ENTRY PROCEDURES --------------------------------------------------

proc fillEntry {name text} {
    global widget
    set w $widget($name)

    set state [$w cget -state]
    if {$state == "disabled"} { configState $w 1 }
    $w delete 0 end
    $w insert 0 $text
    if {$state == "disabled"} { configState $w 0 }
}

# getEntry: get the contents of the named entry
# if a flag is provided, it is prepended onto any non-empty entry
proc getEntry {name {before ""} {after ""}} {
    global def

    set arg [enValue $name]

    if {$arg == ""}  {return ""}

    if {[info exists def($name)] && $arg == $def($name)} {return ""}

    return $before$arg$after
}

proc coval {val {before ""} {after ""}} {
    if {$val != ""} {
	return $before$val$after
    }
}

proc copend {name val {before ""} {after ""}} {
    upvar $name var
    append var [coval $val $before $after]
}

proc getStatus {name {before ""} {after ""}} {
    global st

    if {![info exists st($name)]} { return "" }

    set arg $st($name)
    return $before$arg$after
}
    

proc checkQuote {arg} {
    if {[badChars $arg]} {
	return \"$arg\"
    }
}

proc badChars {arg} {
    if {$arg == ""} {
	return 0
    }
    return 1
}

# cbEntry: like getEntry, except that it only returns non-empty
# string if the named checkbutton is selected
proc cbEntry {cb entry flag} {
    global st

    if {$st($cb)} {
	getEntry $entry $flag
    }
}

proc cbOptional {cb entry flag sep} {
    global st

    if {$st($cb)} {
	optEntry $flag $entry $sep
    }
}

# optEntry: return a flag with an optional parameter
proc optEntry {entry flag {sep ""}} {
    return $flag[getEntry $entry $sep]
}

proc cbRadio {cb rb flag} {
    global st

    if {[cbValue $cb]} {
	return $flag[rbValue $rb]
    }
}

proc enRadio {en rb flag} {
    global st

    set val [enValue $en]
    if {$val != ""} {
	return $flag$val[rbValue $rb]
    }
}


# rbEntry: like getEntry, except that it only returns non-empty
# string if the named radiobutton has the given value
proc rbEntry {rb val entry flag} {
    global st

    if {$st($rb) == $val} {
	getEntry $entry $flag
    }
}

proc mbEntry {rb val entry flag} {
    rbEntry $rb $val $entry $flag
}

# CURSOR -----------------------------------------------------------

proc cursorWatch {} {
    . config -cursor watch
    update
}

proc cursorNormal {} {
    update
    . config -cursor ""
}

proc contains {s c} {
    return [expr 1+[string first $c $s]]
}



# BROWSE ------------------------------------------------------------

proc browseCommand {entry} {
    global st

    # see where we left off browsing
    if {[info exists st($entry-dir)]} {
	set dir [glob $st($entry-dir)]
    } else {
        set dir ""
    }

    # go browse
#    set file [tk_getOpenFile -initialdir $dir -mustexist false]
    set file [browse $dir]
    if {$file == ""} { return }

    # save the browsed directory as the starting place for next time
    if {[file isfile $file]} {
	set dir [file dirname $file]
    } else {
	set dir $file
    }
    set st($entry-dir) $dir

    # show the result
    set file [reduce $file [pwd]]
    set file [reduce $file [glob ~] ~/]
    fillEntry $entry $file
    showCommand

}

proc reduce {file dir {prefix ""}} {
    set pattern [file join ^($dir) ?(.*)]
    if {[regexp $pattern $file junk match rest]} {
	return $prefix$rest
    }
    return $file
}

proc filePermission {file} {
    global widget

    # check whether we can overwrite an existing file,
    # or create a new file in the given directory
    if {[file exists $file]} {
	set check $file
    } else {
	set check [file dirname $file]
    }

    if {[file writable $check]} { return 1 }

    fillEntry en_save "$file : permission denied"
    return 0
}

proc fileOverwrite {file} {
    global br widget

    if {![file exists $file]} { return 1 }

    if {![file isfile $file]} {
	fillEntry en_save "$file is a [file type $file]"
	return 0
    }

    set br(overwrite) 1

    tl "Warning" check 0 0
    set w $widget(frame)

    message $w.mess -width 400 \
	-text "Do you want to overwrite the existing file $file?"
    pack $w.mess

    fr -side left -pady 5 -fill none
    bu "Yes (y or return)"     fe_ok     "destroy $w"   -side left
    bu "No  (n or space)"      fe_cancel "set br(overwrite) 0; destroy $w"
    endfr

    bind $w <Return> "$widget(fe_ok) invoke"
    bind $w <Key-y> "$widget(fe_ok) invoke"

    bind $w <Key-space> "$widget(fe_cancel) invoke"
    bind $w <Key-n> "$widget(fe_cancel) invoke"

    # wait for result
    update
    grab $w
    tkwait window $w
    return $br(overwrite)
}

set br(i) 0
proc browse { {dir ""} } {
    global br widget

    if {$dir == ""} {
	set dir [pwd]
    }

    # create unique names using br counter
    set i $br(i)
    incr br(i)

    set name  browse$i
    set menu  $name-menu
    set entry $name-entry
    set list  $name-list

    tl "Browse" $name 0 60
    set w $widget(frame)

    set br($w-dir) $dir
    set br($w-file) ""

    fr
    fr -side left -padx 5
      mb $dir $menu $dir
      config $menu -direction above
      repack $menu -pady 5
      fr
      la "File name:" -side left
      en 15 $entry "" "" -side left
      bu up bu_up "invoke $menu-m last"
      config bu_up -padx 1 -pady 1
      endfr
    endfr

    fr -padx 5 -fill both
      bu OK      bu_ok      "browseOK $w $menu"
      bu cancel  bu_cancel  "browseCancel $w"     -side bottom
      config bu_ok -borderwidth 5 -relief raised
    endfr
    endfr

    fillBrowse $w $dir

    bind $w <Return> "$widget(bu_ok) invoke"
    bind $w <Control-c> "$widget(bu_cancel) invoke"

    focus $widget($entry)
    tkwait window $w

    popfr

    set file [file join $br($w-dir) $br($w-file)]
    return $file
}

proc reduce {file dir {prefix ""}} {
    set pattern [file join ^($dir) ?(.*)]
    if {[regexp $pattern $file junk match rest]} {
	return $prefix$rest
    }
    return $file
}

proc fillBrowse {w dir} {
    global br st widget

    set name  [string range $w 1 end]
    set menu  $name-menu
    set entry $name-entry
    set list  $name-list

    set br($w-dir) $dir
    set st($menu) $dir
    fillMenu $w $dir

    fillEntry $entry ""

    # get rid of the old listboxes
    if {[info exists widget($list)]} {
	destroy $widget($list)
	set widget(frame) $w
    }

    set files [split [execCatch "ls -x $dir"] \n]
    set n [llength [lindex $files 0]]
    if {$n < 4} { set n 4 }
    li $list $n -padx 5

    set w $widget($list).lis
    foreach line $files {
	for {set i 0} {$i < $n} {incr i} {
	    $w.li$i insert end [lindex $line $i]
	}
    }
    for {set i 0} {$i < $n} {incr i} {
	set cmd "fillEntry $entry "
	append cmd {[%W get [%W nearest %y]]}
	bind $w.li$i <Button> $cmd
	bind $w.li$i <Double-Button> "$widget(bu_ok) invoke"

	shrink $w.li$i
    }
}

proc fillMenu {w dir} {
    global widget

    set name  [string range $w 1 end]
    set menu  $name-menu
    config $menu -text $dir

    # fill the menu with entries for each parent directory
    $widget($menu).m delete 0 last
    while {1} {
	set par [file dirname $dir]
	if {$par == $dir} {break}
        set dir $par
	mi $dir $menu $dir "" 0
	$widget($menu).m entryconfig 0 -command "fillBrowse $w $dir"
    }
}

proc shrink {w} {
    set maxl 0
    foreach word [$w get 0 end] {
        set len [string length $word]
	if {$len > $maxl} { set maxl $len }
    }
    incr maxl
#    if {$maxl < 4} { set maxl 4 }
    $w config -width $maxl
}

proc browseOK {w menu} {
    global st br

    set name  [string range $w 1 end]
    set entry $name-entry
    set menu $name-menu
    set dir $st($menu)
    set file [getEntry $entry]
    set file [file join $dir $file]

    if {[file isdirectory $file]} {
	set br($w-dir) $file
	set br($w-file) ""
        fillBrowse $w $file
    } else {
        set br($w-file) $file
	destroy $w
    }
}

proc browseCancel {w} {
    global br

    set br($w-dir) ""
    set br($w-file) ""
    destroy $w
}