
# Stuff for file selection.
#
# Copyright (c) 1999 Pacific Marketing and Consulting, Inc.
# 	All rights reserved.
# Author:  Wayne A. Christopher, wayne@icemcfd.com

proc file_selection {args} {
    global file_select use_builtin_file_dialogs app_dir is_win env
    global override_builtin_tk_file_dialogs
    
    array set vals {
	-message "Select a file."
	-default ""
	-title "File selection"
	-get_dir 0
	-new_ok 0
	-ok_func ""
	-not_ok_message ""
	-new_dir_mess_name ""
	-ok_patterns ""
	-prev_file ""
	-extra_widgets ""
	-extra_widgets2 ""
	-visible_func ""
	-pick_func ""
	-multiple 0
	-ok_to_select "ok to select"
	-absolute 0
	-delete_button 0
	-mkdir_button 0
	-no_blocking_button 0
	-no_replay_button 0
	-lower_case 0
	-warn_overwrite 0
	-is_save_dialog 0
	-extra_entries ""
	-special_list_func ""
	-dir_leaf_image ""
	-dir_leaf_label ""
	-open_button_name ""
	-file_types ""
	-default_extension ""
	-initialdir ""
	-keep_deffile 0
    }
    foreach {a v} $args {
	if ![info exists vals($a)] {
	    error "Unknown option to file_select: $a $v"
	}
	set vals($a) $v
    }
    
    if $vals(-no_blocking_button) {
	set vals(-new_ok) -1
    } elseif $vals(-no_replay_button) {
	set vals(-new_ok) -2
    } elseif $vals(-mkdir_button) {
	set vals(-new_ok) 1
    } elseif $vals(-delete_button) {
	set vals(-new_ok) 2
    }
    if {($vals(-ok_func) == "") && ($vals(-ok_patterns) != "")} {
	set vals(-ok_func) [list file_select_ok_patterns $vals(-ok_patterns)]
    }
    if {($vals(-not_ok_message) == "") } {
	set vals(-not_ok_message) "That file does not seem to be a\
			valid selection"
    }
    if { ($vals(-new_dir_mess_name) == "") } {
	set vals(-new_dir_mess_name) "directory"
    }

    if [info exists vals(-sort_type)] {
	set file_select(sort_type) $vals(-sort_type)
    }
    set file_select(extra_entries) $vals(-extra_entries)
    set file_select(special_list_func) $vals(-special_list_func)

    if [info exists use_builtin_file_dialogs] {
	set im ""
	if {$vals(-dir_leaf_image) != ""} {

	    set iname file_select_$vals(-dir_leaf_image)
	    if {[lsearch [image names] $iname] < 0} {
		if [file exists $app_dir/../icons] {
		    set idir $app_dir/../icons/
		} else {
		    set idir $app_dir/../../../icons/
		}
		set ifile $idir/$vals(-dir_leaf_image)
		if [file exists $ifile.gif] {
		    set im [image create photo $iname -file $ifile.gif]
		} elseif {[file exists $ifile.xbm]} {
		    set im [image create bitmap $iname -file $ifile.xbm]
		} else {
		    puts stderr "No image $ifile found"
		}
	    } else {
		set im $iname
	    }
	}
	set allow_non 0
	set get_open tk_getOpenFile
	
	if $vals(-new_ok) {
	    if {$vals(-warn_overwrite) || $vals(-is_save_dialog)} {
		set get_open tk_getSaveFile
	    }
	    set allow_non 1
	}

	if {$vals(-dir_leaf_image) != ""} {

	    # Select a job directory
	    set leaf_check $vals(-ok_func)
	    
	    if {$vals(-get_dir) == 2} {
		# this is used when unpacking jobs for icepak
		set vals(-get_dir) 0
		set ddir [file dirname $vals(-default)]
		set dfile [file tail $vals(-default)]
		set vals(-keep_deffile) 1
	    } elseif {($leaf_check != "") && [eval $leaf_check \"$vals(-default)\"]} {
		set ddir [file dirname $vals(-default)]
		set dfile [file tail $vals(-default)]
	    } else {
		set ddir $vals(-default)
		set dfile ""
	    }
	} else {
	    # Just select a regular file
	    if $vals(-get_dir) {
		set ddir $vals(-default)
		set vals(-initialdir) $ddir
		set dfile ""
	    } elseif {!$allow_non && ![file exists $vals(-default)]} {
		set ddir [file dirname $vals(-default)]
		set dfile ""
	    } elseif {[file isdirectory $vals(-default)] && !$vals(-get_dir)} {
		set ddir $vals(-default)
		set dfile ""
	    } else {
		set ddir [file dirname $vals(-default)]
		set dfile [file tail $vals(-default)]
	    }
	    set leaf_check ""
	}
	if {$dfile == "."} { set dfile "" }
	set extra_w $vals(-extra_widgets)
	set extra_w_flag -extra_widgets_bottom
	set extra_w2 $vals(-extra_widgets)
	set extra_w2_flag -extra_widgets_bottom
	if {[lindex $extra_w 0] == "on_side"} {
	    set extra_w_flag -extra_widgets_side
	    set extra_w [lrange $extra_w 1 end]
	    
	    set extra_w2_flag -extra_widgets_bottom
	    set extra_w2 $vals(-extra_widgets2)
	}

	# -----------------------------
	
	set save_prev_file 0
	set recent ""
	if {$vals(-prev_file) != ""} {
	    if [file readable $vals(-prev_file)] {
		set fp [open $vals(-prev_file) r]
		set num 0
		while {![eof $fp]} {
		    set f [string trim [gets $fp]]
		    if {$f != ""} {
			set prev_choice($num) $f
			lappend recent [list $f xx] ;# not sure what the second is
			if {$num > 16} break
		    }
		    incr num
		}
		close $fp
	    }
	    set save_prev_file 1
	}
	
	# -------------------------------
	set ftypes $vals(-file_types)
	if {$ftypes != ""} {
	    lappend ftypes [list "All files" *]
	}
	
	# -----this allows the user not to have to reselect a directory for hardcopies
	if {$vals(-initialdir) != ""} {
	    set ddir $vals(-initialdir)
	}
	
	# By "builtin" we mean "native to the OS".  This means that icepak uses the
	# standard tkfbox.tcl ones but med doesn't
	if {$is_win && ![info exists override_builtin_tk_file_dialogs]} {
	    # Don't give any of the fancy new options ...
	    if {$vals(-get_dir) && ($vals(-dir_leaf_image) == "")} {
		set res [tk_chooseDirectory -initialdir $ddir \
			     -title $vals(-title)]
	    } else {
		set res [$get_open \
			     -title $vals(-title) -initialdir $ddir \
			     -initialfile $dfile -filetypes $ftypes]
	    }
	    
	} else {
	    if {$vals(-get_dir) && ($vals(-dir_leaf_image) == "")} {
		set me [expr !$vals(-new_ok)]
		set res [tk_chooseDirectory -mustexist $me -initialdir $ddir \
			     -title $vals(-title) -guibase_toplevel 1]
	    } else {
		set res [$get_open -allow_nonexistent $allow_non \
			     -dir_leaf_check $leaf_check -dir_leaf_image $im \
			     -dir_leaf_label $vals(-dir_leaf_label) \
			     -title $vals(-title) -initialdir $ddir \
			     -initialfile $dfile -pick_func $vals(-pick_func) \
			     $extra_w_flag $extra_w $extra_w2_flag $extra_w2 \
			     -guibase_toplevel 1 \
			     -open_button_name $vals(-open_button_name) \
			     -filetypes $ftypes \
			     -defaultextension $vals(-default_extension)]
	    }
	}
	
	# -------------------------------

	if {$save_prev_file && ($vals(-prev_file) != "") && ($res != "")} {
	    if [catch {open $vals(-prev_file) w} fp] {
		tk_dialog .file_select_error "Error" \
		    "Can't write file $vals(-prev_file): $fp" "" -1 OK
	    } else {
		puts $fp $res
		set num 0
		while {[info exists prev_choice($num)]} {
		    if {$prev_choice($num) != $res} {
			puts $fp $prev_choice($num)
		    }
		    incr num
		}
		close $fp
	    }
	}
	
    } else {
	set res [file_select $vals(-message) \
		     $vals(-default) \
		     $vals(-title) \
		     $vals(-get_dir) \
		     $vals(-new_ok) \
		     $vals(-ok_func) \
		     $vals(-prev_file) \
		     $vals(-extra_widgets) \
		     $vals(-visible_func) \
		     $vals(-pick_func) \
		     $vals(-multiple) \
		     $vals(-ok_to_select) \
		     $vals(-absolute) \
		     $vals(-warn_overwrite) \
		     $vals(-extra_widgets2) \
		     $vals(-not_ok_message) \
		     $vals(-new_dir_mess_name) ]
    }
    

    
    if $vals(-lower_case) {
	set lres [string tolower $res]
	if {$res != $lres} {
	    mess "Warning: DDN path names must not contain capital letters. \
		Converting to lower case.\n" red
	    set res $lres
	}
    }
    
    return $res
}

# relative file selection
proc file_select_rel {message {default ""} {title "File selection"} \
		      {get_dir 0} {new_ok 0} {ok_func ""} {prev_file ""} \
		      {extra_widgets ""} {visible_func ""} {pick_func ""} \
		      {multiple 0} {ok_to_select "ok to select"} \
		      {absolute 1} } {
	set stat [ file_select $message $default $title \
		$get_dir $new_ok $ok_func $prev_file \
		$extra_widgets $visible_func  $pick_func \
		$multiple $ok_to_select 0 ]
	return $stat
}

proc file_select {message {default ""} {title "File selection"} \
		      {get_dir 0} {new_ok 0} {ok_func ""} {prev_file ""} \
		      {extra_widgets ""} {visible_func ""} {pick_func ""} \
		      {multiple 0} {ok_to_select "ok to select"} \
		      {absolute 1} {warn_overwrite 0} {extra_widgets2 ""} \
			{ not_ok_message "" }  { new_dir_mess_name "" } } {
    global file_select has_blt is_win mess_win_font options

    if { $not_ok_message == "" } {
	set not_ok_message "That file does not seem to be a valid selection"
    }
    if { $new_dir_mess_name == "" } {
	set new_dir_mess_name "directory"
    }
    set buts {{Accept file_select_finish} cancel}
    if {$new_ok > 0} { lappend buts {New file_select_mkdir} }
    if {$new_ok > 1} { lappend buts {Delete file_select_delete} }
    
# This is supposed to be a generic function without hexa code
# this should be changed.
    if {$new_ok == -1} {
	set new_ok 0
	lappend buts {Delete file_select_delete}
	lappend buts { "New blocking" file_select_no_blocking }
    } elseif {$new_ok == -1} {
# no one know what this code is for .
 	set new_ok 0
 	lappend buts {Delete file_select_delete}
 	lappend buts {"No replay" file_select_no_blocking}
    }
    
    if {$default == "" || $default == "."} { set default [pwd] }
    
    if {$absolute && [file pathtype $default] == "relative"} {
	set default [file join [pwd] $default]
    }
    set default [eval file join [file split $default]]
    
    regsub -all {/\./} $default / default
    if [string match */. $default] {
	set default [string trimright $default .]
	if $get_dir {
	    set default [string trimright $default /]
	}
    }
    
    set file_select(default) $default
    set file_select(current) $default
    if [string match ?:* $default] {
	set file_select(drive) [string range $default 0 1]
    } elseif $is_win {
	set file_select(drive) [string range [pwd] 0 1]
    } else {
        set file_select(drive) ""
    }
    set file_select(picked) ""
    set file_select(show_all_files) 1

    if ![info exists file_select(sort_type)] {
	set file_select(sort_type) time
    }
    set file_select(ok_func) $ok_func
    set file_select(not_ok_message) $not_ok_message
    set file_select(new_dir_mess_name) $new_dir_mess_name
    set file_select(visible_func) $visible_func
    set file_select(pick_func) $pick_func
    set file_select(get_dir) $get_dir
    set file_select(new_ok) $new_ok
    set file_select(multiple) $multiple
    set file_select(warn_overwrite) $warn_overwrite
    set file_select(stars) [expr {($ok_func != "") && \
				      (($visible_func == "") ||
				       ($visible_func != $ok_func))}]
    set file_select(multiple_selections) ""
    
    set file_select(multiblock_style) 0
    if [string match "has_suffix *" $visible_func] {
	set add_whattype [lindex $visible_func 1]
	# This is a very specific thing to handle the selection of
	# multiblock meshes.
	foreach pat [lrange $visible_func 2 end] {
	    if {$pat == {.[0-9]*}} {
		set file_select(multiblock_style) 1
	    }
	}
    } else {
	set add_whattype ""
    }
    
    if $get_dir { set cols 1 } else { set cols 2 }
    
    form_kill .file_select
    set d [form_init .file_select $title "" $buts]
    form_label $d.label $message "0 0 -cols $cols" "" 0
    
    set row 1
    if {$extra_widgets2 != ""} {
	form_frame $d.extra2 flat 0 "$row 0 -cols $cols"
	eval $extra_widgets2 $d.extra2
	incr row
    }
    
    form_entry $d.current file_select(current) string "$row 0 -cols $cols"
    if [info exists mess_win_font] {
	$d.current configure -font $mess_win_font
    }
    incr row
    set save_prev_file 0
    if {[lindex $prev_file 0] == "options_given"} {
	set file_select(has_prev) 0
	form_menubutton $d.prevl [lindex $prev_file 1] $d.prevl.m \
	    "$row 0 -cols $cols" file_select(has_prev)
	set num 0
	menu $d.prevl.m
	foreach opt [eval [lindex $prev_file 2]] {
	    set prev_choice($num) $opt
	    $d.prevl.m add command -label $opt -command \
		[list file_select_prev $opt]
	    set file_select(has_prev) 1
	}
	
    } elseif {$prev_file != ""} {
	set file_select(has_prev) 0
	form_menubutton $d.prevl "Previous selections" $d.prevl.m \
	    "$row 0 -cols $cols" file_select(has_prev)
	if [file readable $prev_file] {
	    menu $d.prevl.m
	    set fp [open $prev_file r]
	    if {[info exists options(prev_selections)] && \
	        $options(prev_selections) != "" && \
	        [string is int $options(prev_selections)]} {
	        set last_num $options(prev_selections)
	    } else {
	        set last_num 8
	    }
	    set num 0
	    while {![eof $fp]} {
		set f [string trim [gets $fp]]
		if {$f != ""} {
		    set prev_choice($num) $f
		    $d.prevl.m add command -label $f -command \
			[list file_select_prev $f]
		    set file_select(has_prev) 1
		    incr num
		    if {$num >= $last_num} break
		}
	    }
	    close $fp
	}
	set save_prev_file 1
    }
    incr row
    set dgeo "$row 0 -rows [expr 6 - $row] -fill both"
    if 1 {
	if $is_win {
	    set drivelist [win_drives]
	    form_frame $d.drive flat 0 {4 0 -anchor w}
	    form_label $d.drive.l Drive: {0 0}
	    form_optionmenu $d.drive.s file_select(drive) $drivelist {0 1} \
		"" file_select_change_drive
	    set dgeo {5 0 -rows 2 -fill both}
	} else {
	    set file_select(drive) ""
	}
    }
    for {set i $row} {$i < 6} {incr i} {
	grid rowconfigure $d $i -weight 1000
    }
    form_listbox $d.directs "Directories" [file_select_list 1] \
	"file_select_one 0 1 0" "file_select_one 1 1 0" 16x8 $dgeo
    
    bind $d.directs.list <Shift-Double-Button-1> \
	"form_listbox_action $d.directs 0 %y \
		\{file_select_one 1 1 1\} 0; break"
    
    set ok_string "* = $ok_to_select; shift-double-click\n        to enter without selecting"
    if !$get_dir {
	form_listbox $d.files "Files" [file_select_list 0] \
	    "file_select_one 0 0 0" "file_select_one 1 0 0" 16x8 \
	    {4 1 -rows 2 -fill both} "" 0 0 $multiple
	if $file_select(stars) {
	    form_label $d.starl "* = $ok_to_select" {6 1}
	}
	set file_select(file_list) $d.files
    } else {
	if $file_select(stars) {
	    form_label $d.starl $ok_string {7 0}
	}
    }
    
    if {$extra_widgets != ""} {
	if {[lindex $extra_widgets 0] == "on_side"} {
	    form_frame $d.extra ridge 2 "0 2 -rows 10"
	    set extra_widgets [lrange $extra_widgets 1 end]
	} else {
	    if $has_blt {
		form_frame $d.extra ridge 2 "10 0 -cols $cols -fill x"
	    } else {
		form_frame $d.extra ridge 2 "10 0 -cols $cols -sticky w"
	    }
	}
	eval $extra_widgets $d.extra
    }
    
    if {![info exists file_select(no_sort_buttons)] || 
	($add_whattype != "")} {
	form_frame $d.opts flat 0 {8 0 -fill none -anchor w -cols 2}
    }
    
    if ![info exists file_select(no_sort_buttons)] {
	form_label $d.opts.l "Sort by:" {0 0} 
	form_radiobutton $d.opts.name "Name" file_select(sort_type) name {0 1}
	$d.opts.name configure -command file_select_update
	form_radiobutton $d.opts.time "Time" file_select(sort_type) time {0 2}
	$d.opts.time configure -command file_select_update
    }
    if {$add_whattype != ""} {
	form_label $d.opts.shl "Show files:" {1 0} 
	form_radiobutton $d.opts.some $add_whattype \
	    file_select(show_all_files) 0 {1 1}
	$d.opts.some configure -command file_select_update
	form_radiobutton $d.opts.all "All files" \
	    file_select(show_all_files) 1 {1 2}
	$d.opts.all configure -command file_select_update
    }
    
    bind $d.current <Key-slash> "$d.current insert insert /; file_select_update; break"
    bind $d.current <Key-backslash> "$d.current insert insert /; file_select_update; break"
    bind $d.current <Key-space>  "file_select_complete; break"
    bind $d.current <Key-Return> file_select_finish
    bind $d.current <Key> "file_select_clear_lists $d"
    bind $d.directs.list <Shift-Double-1> {
	set choice [%W nearest %y]
	file_select_one 1 1 1 [%W get $choice]
	break
    }
    
    # Just scale the listboxes by the current size.  Don't do it all the time
    # because that would be distracting.
    form_listbox_scale $d.directs 16
    if [winfo exists $d.files] {
	form_listbox_scale $d.files 16
    }
    
    form_finish middle 1 1
    $d.current xview end
    $d.current icursor end
    
    update
    raise .file_select
    focus .file_select
    
    if [form_wait .file_select] {
	if {$save_prev_file && ($prev_file != "") && \
		($file_select(current) != "")} {
	    if [catch {open $prev_file w} fp] {
		tk_dialog .file_select_error "Error" \
		    "Can't write file $prev_file: $fp" "" -1 OK
	    } else {
		puts $fp $file_select(current)
		set num 0
		while {[info exists prev_choice($num)]} {		    
		    if {[string trimright $prev_choice($num) /] != \
		        [string trimright $file_select(current) /]} {
			if {[string index $prev_choice($num) end] != "/"} {
			    puts $fp $prev_choice($num)/
			} else {
			    puts $fp $prev_choice($num)
			}
		    }
		    incr num
		}
		close $fp
	    }
	}
	if {$multiple && ($file_select(multiple_selections) != "")} {
	    set dir [file dirname $file_select(current)]
	    set files ""
	    foreach s $file_select(multiple_selections) {
		set base [string range [form_listbox_get $d.files $s] 2 end]
		lappend files $dir/$base
	    }
	    return $files
		
	} else {
	    return $file_select(current)
	}
    } else {	
	return ""
    }
}

proc file_select_clear_lists {d} {
    $d.directs.list selection clear 0 end
    if [winfo exists $d.files] {
	$d.files.list selection clear 0 end
    }
}

# This is something special just for hexa.

proc file_select_no_blocking { { dim 0 } } {
    global file_select
    if { $dim == 2 } {
    	set file_select(current) "-init_2d"
    } else {
    	set file_select(current) "__no_blocking__"
    }
    file_select_done
}

proc file_is_blocking {f} {
# this is being taken out and the has_suffix this 
# is being added to select_blocking file
#    if { ! [ string match "*.blk" $f ] } { return 0 } 
    if {![file readable $f] || [file isdirectory $f]} { return 0 }
    set fp [open $f r]
    set line [gets $fp]
    close $fp
    if  [ string match "*MATERIALS*" $line ] {
	return 1
    }
    if [ string match "*#*blocking*" $line ] {
	return 1
    }
    return 0
}

proc file_select_lc { text default {title "File selection"} \
                      {get_dir 0} {new_ok 0} } {
    set ok_func ""
    set prev_file ""
    set extra_widgets ""
    set visible_func ""
    set pick_func ""
    set multiple 0
    set ok_to_select "ok to select"
    set absolute 0
    
    set res [file_select $text $default $title $get_dir $new_ok \
			$ok_func $prev_file $extra_widgets \
			$visible_func $pick_func $multiple $ok_to_select \
			$absolute ]
    if {[regexp \[A-Z\] $res] == 1} {
        infomsg "DDN path names must not contain capital letters!  Converting to lower case."
        set res [string tolower $res]
    }
    return $res
}
proc file_select_multiple {message default {title "File selection"} \
			       {ok_func ""} {extra_widgets ""} \
			       {visible_func ""}} {
    return [file_select $message $default $title 0 0 $ok_func "" \
		$extra_widgets $visible_func "" 1]
}

proc file_select_prev {f} {
    global file_select
    
    set file_select(current) ""
    file_select_one 1 [file isdirectory $f] 1 "  $f"
}

proc file_select_one {double dir no_sel box_name} {
    global file_select
    
    set name [string range $box_name 2 end]
    set path [file split $file_select(current)]
    set npath [llength $path]
    
    if {!$double && $dir} {
	if { $npath == 1 &&  $name == ".." } {
		if { [ file tail $path ] == ".." } {
			set new "$path/.."
		} elseif { $path == "." } {
			set new "$name"
		} else {
			set new "."
		}
	} else {
		set new [eval file join $path $name]
	}
	if {$file_select(pick_func) != ""} {
	    eval [concat $file_select(pick_func) [list $new]]
	}
	set file_select(picked) $new
	return
    }
    
    if ![file isdirectory $file_select(current)] {
	set path [lrange $path 0 [expr $npath - 2]]
	incr npath -1
    }
    if ![string compare $name ..] {
	switch $npath {
	    1 {
		if [string match ?:/ $path] {
		    set new $path
		} elseif { [ file tail $path ] == ".." } {
		    set new "$path/.."
		} elseif { $path == "." } {
		    set new ".."
		} else {
		    set new "."
		}
	    }
	    0 {
		set new [eval file join [lrange [file split [pwd]] 0 end-1]]
	    }
	    default {
		set new [eval file join [lrange $path 0 [expr $npath - 2]]]
	    }
	}
	set file_select(picked) ""
	set finish_ok 0
    } else {
	if { $path == "." } {
		set new $name
	} else {
		set new [eval file join $path [list $name]]
	}
	set file_select(picked) $new
	set finish_ok 1
    }
    if {[file isdirectory $new] && ![string match */ $new]} { append new / }
    
    if !$double {
	if {$file_select(pick_func) != ""} {
	    eval [concat $file_select(pick_func) [list $new]]
	}
	set file_select(current) $new
	.file_select.main.current xview end
	.file_select.main.current icursor end
	return
    }

    if {$finish_ok && [file isdirectory $new] && $file_select(get_dir) && \
	    ($file_select(ok_func) != "") && !$no_sel && \
	    [eval $file_select(ok_func) \{$new\}]} {
	set file_select(current) $new
	file_select_done
	puts c1
    } elseif {$finish_ok && ([file isfile $new] || ([file tail $new] == "Multiblock")) && !$file_select(get_dir)} {
	if {($file_select(ok_func) == "") || \
		[eval $file_select(ok_func) \{$new\}]} {
	    set file_select(current) $new
	    form_listbox_select $file_select(file_list) $box_name
	    file_select_done
	    #puts x2
	} else {
	    tk_dialog .file_select_error "Error" \
		$file_select(not_ok_message) "" -1 OK
	    return
	}
    }
    set file_select(current) $new
    set file_select(picked) ""
    file_select_update
    
    if {$file_select(pick_func) != ""} {
	eval [concat $file_select(pick_func) [list $new]]
    }
}

proc file_select_complete {} {
    global file_select tcl_platform
    
    set file_select(picked) ""
    
    set do_case [string compare $tcl_platform(platform) windows]
    if [catch {glob $file_select(current)*} opts] {
	bell; return
    }
    if {[llength $opts] == 1} {
	set file_select(current) [lindex $opts 0]
	if [file isdirectory $file_select(current)] {
	    append file_select(current) /
	    file_select_update
	}
	.file_select.main.current xview end
	.file_select.main.current icursor end
	return
    }
    set len1 [string length $file_select(current)]
    set len2 1
    set matches 1
    while {$matches} {
	set ch [string index [lindex $opts 0] [expr $len1 + $len2 - 1]]
	foreach opt $opts {
	    set och [string index $opt [expr $len1 + $len2 - 1]]
	    if {$och != $ch} { set matches 0; break }
	}
	if {$matches && ($ch == "")} { error "can't happen" }
	if $matches { incr len2 }
    }
    if {$len2 == 1} {
	catch {destroy .file_select.menu} ;# just in case
	menu .file_select.menu -tearoff 0
	foreach o [lsort $opts] {
	    .file_select.menu add command -label [file tail $o] -command \
		    [list file_select_complete_pick $o]
	}
	.file_select.menu add command -label " - cancel - " -command \
		[list set file_select(picked) ""]
	top_geometry .file_select.menu +[winfo pointerx .]+[winfo pointery .]
	raise .file_select.menu
	tkwait variable file_select(picked)
	destroy .file_select.menu
	if {$file_select(picked) != ""} {
	    set file_select(current) $file_select(picked)
	}
    } else {
	set file_select(current) [string range [lindex $opts 0] \
				      0 [expr $len1 + $len2 - 2]]
	update
	.file_select.main.current xview end
	.file_select.main.current icursor end
    }
}

proc file_select_complete_pick {opt} {
    global file_select
    set file_select(picked) $opt
    update
    .file_select.main.current xview end
    .file_select.main.current icursor end
}

proc file_select_finish {} {
    global file_select
    
    set file $file_select(current)
    
    # First see if the user has clicked on something in the window
    set w .file_select.main
    if $file_select(get_dir) {
	set cc [$w.directs.list curselection]
	if {$cc != ""} {
	    set fname [string range [$w.directs.list get $cc] 2 end]
	    set file [string trimright $file /]/$fname
	    set file_select(current) $file
	}
	
    } else {
        set cc [$w.files.list curselection]
	if {($cc != "") && (($file == "") || [file isdirectory $file])} {
	    set fname [string range [$w.files.list get $cc] 2 end]
	    if {$file == ""} {
		if [file isfile $fname] {
		    set file $fname
		}
	    } else {
		set nf [string trimright $file /]/$fname
		if [file isfile $nf] {
		    set file $nf
		}
	    }
	    set file_select(current) $file
	}
    }
    
    if { $file_select(warn_overwrite) && [file exists $file] &&
	( $file_select(warn_overwrite) == 2 || 
		$file != $file_select(default) ) }  {
	top_withdraw .file_select
	if $file_select(get_dir) {
	    set is_file directory
	} else {
	    set is_file file
	}
	if [tk_dialog .file_select_error "File exists" \
		"The $is_file $file already exists -- overwrite?" \
		"" -1 Yes No] {
	    top_deiconify .file_select
	    return
	}
    }
    if {!$file_select(get_dir) && [file exists $file] && \
	    ![file isfile $file]} {
	top_withdraw .file_select
	tk_dialog .file_select_error "Error" \
		"That is not a file - please select one." "" -1 OK
	top_deiconify .file_select
	return
    }
    if {!$file_select(new_ok) && ![file exists $file] && \
	    ![string match Multiblock* [file tail $file]]} {
	top_withdraw .file_select
	tk_dialog .file_select_error "Error" \
	    "No such file - please select an existing one." "" -1 OK
	top_deiconify .file_select
	return
    }
    if {$file_select(get_dir) && [file exists $file] && \
	    ![file isdirectory $file]} {
	top_withdraw .file_select
	tk_dialog .file_select_error "Error" \
		"That is not a directory - please select one." "" -1 OK
	top_deiconify .file_select
	return
    }
    if {[file exists $file] && ($file_select(ok_func) != "") && \
	    ![eval $file_select(ok_func) \{$file\}]} {
	top_withdraw .file_select
	if ![tk_dialog .file_select_error "Error" \
		 $file_select(not_ok_message) "" -1 \
		 "Don't select" "Select anyway"] {
		     top_deiconify .file_select
		     if [file isdirectory $file] {
			 set file_select(current) [file dirname $file]
		     }
		     return
		 }
    }
    
    file_select_done
}

proc file_select_done {} {
    global form_done_flag file_select
    
    set w .file_select
    if [winfo exists $w.main.files] {
	set file_select(multiple_selections) \
	    [form_listbox_get_select_index $w.main.files]
    }
    form_done $w
    set form_done_flag($w) 1
}

proc file_select_update {} {
    global file_select
    
    if ![winfo exists .file_select.main.current] return
    
    if [string match ~* $file_select(current)] {
	set np [glob $file_select(current)]
	if [string match */ $file_select(current)] { append np / }
	set file_select(current) $np
    }
    
    set cur [file tail $file_select(current)]
    
    set w .file_select
    $w.main.current xview end
    $w.main.current icursor end
    form_listbox_set $w.main.directs [file_select_list 1]
    if [winfo exists $w.main.files] {
	form_listbox_set $w.main.files [file_select_list 0]
	form_listbox_select $w.main.files "? $cur" 1
    } else {
	form_listbox_select $w.main.directs "? $cur" 1
    }
}

proc file_select_change_drive {} {
    global file_select
    
    set curd [string range $file_select(current) 0 1]
    if {($file_select(drive) != "") && ($file_select(drive) != $curd)} {
	set file_select(current) $file_select(drive)/
	# [string range $file_select(current) 2 end]
	file_select_update
	update ; raise .file_select
    }
}

proc fcompare { a b } {
    set t1 [ lindex $a 0 ]
    set t2 [ lindex $b 0 ]
    return [ expr $t1 < $t2 ]
}

proc file_select_sort_by_time {files cur_dir } {
    set tlist ""
    foreach i $files {
	if [catch {file mtime $i} time] { 
	    set j $cur_dir/$i
	    if [catch {file mtime $j} time] {
		#mess "can't get time for file $i or $j\n"
		set time 0 
	    }
	}
	lappend tlist [list $time $i]
    }
    
    set tlist [lsort -integer -command fcompare $tlist]
    set files ""
    foreach i $tlist {
	lappend files [lindex $i 1]
    }
    return $files
}

proc file_select_list {dir } {
    global file_select
    
    busy 1
    
    if [file isdirectory $file_select(current)] {
	set cur_d $file_select(current)
    } else {
	set cur_d [file dirname $file_select(current)]
    }
    set stype $file_select(sort_type)
    if {!$file_select(get_dir) && $dir} {
	# If we're getting a file then always sort the directories by name
	set stype name
    }
    
    if {[info exists file_select(special_list_func)] && 
	($file_select(special_list_func) != "")} {
	set opts [eval $file_select(special_list_func) \"$cur_d\" $dir \
		      $file_select(get_dir) $stype]
	if {$opts != "__local__"} { return $opts }
    }
    set extras ""
    if [info exists file_select(extra_entries)] {
	set extras $file_select(extra_entries)
    }
    return [file_select_do_list $cur_d $dir $file_select(get_dir) $stype \
		$file_select(visible_func) $file_select(stars) \
		$file_select(ok_func) $file_select(multiblock_style) \
	        $extras ]
}

proc sort_files { files stype cur_d } {
    switch $stype {
	time {
	    set tlist [file_select_sort_by_time $files $cur_d ]
	    set files ""
	    foreach i $tlist {
		lappend files $i
	    }
	}
	default -
	name {
	    set files [lsort $files]
	}
    }
    return $files
}
proc add_stars { files } {
	set r ""
	foreach f $files {
		lappend r "* $f"
	}
	return $r
}
proc add_spaces { files } {
	set r ""
	foreach f $files {
		lappend r "  $f"
	}
	return $r
}

# This subroutine is also called by the server code

proc file_select_do_list {cur_d dir get_dir stype vf stars ok_func
		      multiblock_style extra_entries } {
    global file_select

    set opts [glob -nocomplain $cur_d/*]
    
    
    set dotdot ""
    set okdirs ""
    set nokdirs ""
    set xtradirs ""
    if $dir {
	foreach d $opts {
	    if {$get_dir && ![file_select_visible_func $vf $d]} continue
	    
	    if [file isdirectory $d] {
		if {$stars && [eval $ok_func [list $d]]} {
		    lappend okdirs [file tail $d]
		} else {
		    lappend nokdirs [file tail $d]
		}
	    }
	}
#	if {[llength [file split $cur_d]] > 1} {  }
	set dotdot [list "  .."]
    } else {
	set got_dom 0
	foreach d $opts {
	    if ![file_select_visible_func $vf $d] continue
	    if ![file isfile $d] continue
	    
	    if {$stars && [eval $ok_func [list $d]]} {
		lappend okdirs [file tail $d]
	    } else {
		lappend nokdirs [file tail $d]
	    }
	    if [string match {*.[0-9]*} $d] {
		set got_dom 1
	    }
	}
	if {$multiblock_style && $got_dom} {
	    lappend xtradirs domain.*
	}
	if {$extra_entries != ""} {
	    foreach d [$extra_entries $cur_d] {
		lappend xtradirs $d
	    }
	}
    }

    set xtradirs [ sort_files $xtradirs $stype $cur_d ]
    set okdirs [ sort_files $okdirs $stype $cur_d ]
    set nokdirs [ sort_files $nokdirs $stype $cur_d ]
    set nokdirs [ add_spaces $nokdirs ]
    
    if $file_select(show_all_files) {
	set okdirs [ add_stars $okdirs ]
	set xtradirs [ add_stars $xtradirs ]
    } else {
	set okdirs [ add_spaces $okdirs ]
	set xtradirs [ add_spaces $xtradirs ]
    }
    
    busy 0
    return [concat $xtradirs $dotdot $okdirs $nokdirs]
}

proc file_select_visible_func {vf d} {
    global file_select
    
    if {$vf == ""} { return 1 }
    if [string match "has_suffix *" $vf] {
	if $file_select(show_all_files) { return 1 }
	set ok 0
	foreach pat [lrange $vf 2 end] {
	    if [string match *$pat $d] { set ok 1; break }
	}
	return $ok
	
    } else {
	return [eval $vf [list $d]]
    }
}

proc file_select_mkdir {} {
    global file_select
    set dir [question_box .file_select_mkdir "Make directory" \
		 "New $file_select(new_dir_mess_name) name?" ""]
    if {$dir == ""} return
    if { [ string match "* *" $dir ] } {
	user_error "$file_select(new_dir_mess_name) may not have spaces"
	return
    }
    set par $file_select(current)
    if ![file isdirectory $par] { set par [file dirname $par] }
    cmd_mkdir $par/$dir
    file_select_one 1 1 0 "  $dir"
}

proc file_select_delete {} {
    global file_select
    set file $file_select(picked)
    if {$file == ""} { user_error "No file selected."; return }
    if ![file exists $file] { user_error "File \"$file\" doesn't exist."; return }
    if {[file tail $file] == ".."} { user_error "Can't delete parent directory."; return }
    if [file isdirectory $file] {
	if !$file_select(get_dir) {
	    tk_dialog .file_select_error "Error" \
		"Can't delete a directory - select a file instead." "" -1 OK
	    return
	}
	set what directory
    } else {
	set what file
    }
    
    if ![tk_dialog .del_file "Delete $what" "Delete $what $file?" "" 0 Yes No] {
	mess "Deleting $what $file ... "
	cmd_rm_r $file
# also delete any ppm file associated with it.
	if [ file exists $file.ppm ] {
		cmd_rm_r $file.ppm
		mess "and file $file.ppm ... "
	}
	if {$what == "file"} {
	    file_select_one 1 1 1 ""
	} else {
	    file_select_one 1 1 1 "  [file dirname $file]"
	}
	mess "done.\n"
    }
}

if 0 {
    
    proc busy args {}
    set is_win 1
    set small_screen_hack 0
    source forms.tcl
    source settings.tcl
    proc check_it1 {name} { return [string match *.c $name] }
    proc check_it {name} {
	return [expr [file exists $name/mesh] && [file exists $name/domains]]
    }
    
    puts [file_select "This is a test" [pwd] "have a nice day" 1 0 check_it ""]
}

# This argument list is really getting out of hand

proc file_select_entry {w var get_dir new_ok msg tabgeo {act ""} {ok_func ""} \
			    {prev_file ""} {extra_widgets ""} \
			    {visible_func ""} {pick_func ""} \
			    {after_select_func ""} {just_tail 1} \
			    {leaf_image ""} {leaf_label ""} {file_types ""}} {
    global subtitle_font input_background form_entry_datatype file_select
    global drop_down_arrow

    if [info exists drop_down_arrow] {
	form_frame $w flat 0 "$tabgeo -fill both"
	form_entry $w.e $var [expr {$just_tail ? "path_tail" : "string"}] \
	    "0 0 -padx 0 -pady 0" $act 8 1
	$w.e configure -justify right
	$w.e xview end
	$w.e icursor end
	
	set cmd [list file_select_entry_get $w.m $w.e $var $msg \
		     $get_dir $new_ok $ok_func $prev_file $extra_widgets \
		     $visible_func $pick_func $after_select_func $leaf_image \
		     $leaf_label $file_types]
	
	form_button $w.m "Browse" $cmd "0 1 -padx 2 -pady 0" $act
	grid columnconfigure $w 2 -weight 1000
	return $w.e
    } else {
	set r [lindex $tabgeo 0]; set c [lindex $tabgeo 1]
	set cols 1; set anch w; set rows 1
	for {set i 2} {$i < [llength $tabgeo]} {incr i} {
	    case [lindex $tabgeo $i] in {
		-cols   { set cols [lindex $tabgeo [expr {$i + 1}]] }
		-rows   { set rows [lindex $tabgeo [expr {$i + 1}]] }
		-anchor { set anch [lindex $tabgeo [expr {$i + 1}]] }
	    }
	}
	
	form_entry $w $var path_tail $tabgeo $act
	$w configure -justify right
	$w xview end
	$w icursor end
	incr c $cols
	
	form_menubutton ${w}_menu "    " "" "$r $c -fill none" $act
	futil_drop_down_button ${w}_menu #ffc0c0 #ffa0a0
	
	set cmd [list file_select_entry_get ${w}_menu $w $var $msg \
		     $get_dir $new_ok $ok_func $prev_file $extra_widgets \
		     $visible_func $pick_func $after_select_func $leaf_image \
		     $leaf_label $file_types]
	bind ${w}_menu <ButtonPress-1> $cmd
	bind ${w}_menu <ButtonRelease-1> break
	
# this should work with the path_tail stiff now.
	pathentry on $w
	
	return 1
    }
}

proc file_select_entry_get {but ent var msg get_dir new_ok ok_func \
				prev_file extra_widgets visible_func \
				pick_func after_select_func \
				leaf_image leaf_label file_types} {

    if {[$but cget -state] == "disabled"} return
    
    set def [uplevel \#0 set $var]

    set file [file_selection -message $msg -default $def \
		  -title $msg \
		  -get_dir $get_dir -new_ok $new_ok \
		  -ok_func $ok_func -prev_file $prev_file \
		  -extra_widgets $extra_widgets -file_types $file_types \
		  -visible_func $visible_func -pick_func $pick_func \
		  -dir_leaf_image $leaf_image -dir_leaf_label $leaf_label]
    if {$file == ""} return
    
    uplevel \#0 set \"$var\" \"$file\"
    file_select_entry_adjust $ent 
    
    if {$after_select_func != ""} { eval $after_select_func $file }
}

proc file_select_entry_adjust {ent} {
    $ent xview end
    $ent icursor end
}

proc file_select_ok_patterns {pats file} {
    foreach p $pats {
	if [string match $p [file tail $file]] { return 1 }
    }
    return 0
}

