# Dialog chapter

proc fileselectResources {} {
    # path is used to enter the file name
    option add *Fileselect*path.relief		sunken	startup
    option add *Fileselect*path.background	white	startup
    option add *Fileselect*path.foreground	black	startup
    # Text for the label on pathname entry
    option add *Fileselect*l.text		File:	startup
    # Text for the OK and Cancel buttons
    option add *Fileselect*ok*text		OK	startup
    option add *Fileselect*ok*underline		0	startup
    option add *Fileselect*cancel.text		Cancel	startup
    option add *Fileselect*cancel.underline 	0	startup
    # Size of the listbox
    option add *Fileselect*list.width		20	startup
    option add *Fileselect*list.height		10	startup
}

# fileselect returns the selected pathname, or {}
# exists can be:
# ""	- ok to open a new file
# file	- must open existing file
# dir	- ok to return directory pathname

proc fileselect {{why "File Selection"} {default {}} {exists ""} } {
	global fileselect

	regsub -nocase ^http: $default {} default
	if {[info commands tk_getOpenFile] == "tk_getOpenFile"} {
	    set args [list -title $why]
	    if {[string length $default]} {
		if [file isdirectory $default] {
		    lappend args -initialdir $default
		} else {
		    set parent [file dirname $default]
		    if [file isdirectory $parent] {
			lappend args -initialdir [file dirname $default]
		    }
		    lappend args -initialfile [file tail $default]
		}
	    }
	    switch -- $exists {
		"dir" {
		    # Fall through to old implementation.
		}
		"file" {
		    return [eval tk_getOpenFile $args]
		}
		"" {
		    return [eval tk_getSaveFile $args]
		}
	    }
	}
	if [winfo exists .fileselect] {
	    raise .fileselect
	    set t .fileselect
	} else {
	    set t [toplevel .fileselect -bd 4 -class Fileselect]
	    fileselectResources
    
	    message $t.msg -aspect 1000 -text $why
	    pack $t.msg -side top -fill x
	
	    # Create a read-only entry for the durrent directory
	    set fileselect(dirEnt) [entry $t.dir -width 15 \
		    -relief flat -state disabled]
	    pack $t.dir -side top -fill x
	
	    # Create an entry for the pathname
	    # The value is kept in fileselect(path)
	    frame $t.top
	    label $t.top.l -padx 0
	    set e [entry $t.top.path \
		    -textvariable fileselect(path)]
	    pack $t.top -side top -fill x
	    pack $t.top.l -side left
	    pack $t.top.path -side right -fill x -expand true
    
	
	    # Create a listbox to hold the directory contents
	    set lb [listbox $t.list \
		    -yscrollcommand [list $t.scroll set]]
	    scrollbar $t.scroll -command [list $lb yview]
	    set fileselect(list) $lb
    
	    # Create the OK and Cancel buttons
	    # The OK button has a rim to indicate it is the default
	    frame $t.buttons -bd 10
	    frame $t.buttons.ok -bd 2 -relief sunken
	    set ok [button $t.buttons.ok.b \
		    -command "fileselectOK 1"]
	    set can [button $t.buttons.cancel \
		    -command fileselectCancel]
	    if [string match dir $exists] {
		set list [button $t.buttons.dir -text "List Dir" \
		    -command fileselectOK]
	    }
    
	    # Pack the list, scrollbar, and button box
	    # in a horizontal stack below the upper widgets
	    pack $t.list -side left -fill both -expand true
	    pack $t.scroll -side left -fill y
	    pack $t.buttons -side left -fill both
	    pack $t.buttons.ok \
		    -side top -padx 10 -pady 5
	    catch {
		pack $t.buttons.dir \
		    -side top -padx 10 -pady 5
	    }
	    pack $t.buttons.cancel \
		    -side top -padx 10 -pady 5
	    pack $t.buttons.ok.b -padx 4 -pady 4
    
	    fileselectBindings $t $e $lb $ok $can
	}
	# Initialize variables and list the directory
	if ![info exists fileselect(dir)] {
	    set fileselect(dir) [pwd]
	}
	if {[string length $default] == 0} {
		set fileselect(path) {}
		set dir $fileselect(dir)
	} elseif {[file isdirectory $default]} {
		set fileselect(path) {}
		set dir $default
	} else {
		set fileselect(path) [file tail $default]
		set dir [file dirname $default]
	}
	set fileselect(done) 0
	set fileselect(exist) $exists

	# Wait for the listbox to be visible so
	# we can provide feedback during the listing 
	Platform_WaitVisibility $fileselect(list)
	fileselectList $dir

	tkwait variable fileselect(done)
	catch {destroy $t}
	return $fileselect(path)
}
#
# For a file selector embedded in the URL chooser dialog
#
proc fileselectEmbedded {t {default {}}} {
	global fileselect
	# Create a read-only entry for the durrent directory
	set fileselect(dirEnt) [entry $t.dir -width 15 \
		-relief flat -state disabled]
	pack $t.dir -side top -fill x

	# Create a listbox to hold the directory contents
	frame $t.h
	set lb [listbox $t.h.list -height 5\
		-yscrollcommand [list $t.h.scroll set]]
	scrollbar $t.h.scroll -command [list $lb yview]
	set fileselect(list) $lb

	# Pack the list, scrollbar, and button box
	# in a horizontal stack below the upper widgets
	pack $t.h.list -side left -fill both -expand true
	pack $t.h.scroll -side left -fill y 
	pack $t.h -side top -fill x

	# The caller sets up his own bindings on the listbox

	# Initialize variables and list the directory
	if {[string length $default] == 0} {
		set fileselect(path) {}
		set dir [pwd]
	} elseif {[file isdirectory $default]} {
		set fileselect(path) {}
		set dir $default
	} else {
		set fileselect(path) [file tail $default]
		set dir [file dirname $default]
	}
	set fileselect(dir) {}
	set fileselect(done) 0
	set fileselect(exist) file

	# Wait for the listbox to be visible so
	# we can provide feedback during the listing 
	Platform_WaitVisibility $lb
	fileselectList $dir
	return $lb
}
proc fileselectTrace { args } {
    global fileselect
    upvar #0 $fileselect(othervar) other
    set fileselect(path) $other
}
proc fileselectBindings { t e lb {ok {}} {can {}} } {
	# t - toplevel
	# e - name entry
	# lb - listbox
	# ok - OK button
	# can - Cancel button

	# Elimate the all binding tag because we
	# do our own focus management
	foreach w [list $e $lb] {
	    bindtags $w [list $t [winfo class $w] $w]
	}
	# Dialog-global cancel binding
	bind $t <Control-c> fileselectCancel

	# Entry bindings
	bind $e <Return> fileselectOK 
	bind $e <space> fileselectComplete

	# A single click, or <space>, puts the name in the entry
	# A double-click, or <Return>, selects the name
	bind $lb <space> "fileselectTake $%W ; focus $e"
	bind $lb <Button-1> \
		"fileselectClick %W %y ; focus $e"
	bind $lb <Return> "fileselectTake %W ; fileselectOK"
	bind $lb <Double-Button-1> \
		"fileselectClick %W %y ; fileselectOK"

	# Focus management.  	# <Return> or <space> selects the name.
	bind $e <Tab> "focus $lb ; $lb select set 0"
	bind $lb <Tab> "focus $e"

	if {$ok != {}} {
		# Button focus.  Extract the underlined letter
		# from the button label to use as the focus key.
		foreach but [list $ok $can] {
			bindtags $w [list $t [winfo class $w] $w]
			set char [string tolower [string index  \
				[$but cget -text] [$but cget -underline]]]
			bind $t <Alt-$char> "focus $but ; break"
		}
		bind $ok <Tab> "focus $can"
		bind $can <Tab> "focus $ok"
	}

	# Set up for type in
	focus $e
}

proc fileselectList { dir {files {}} } {
	global fileselect
	global tcl_platform
	# Update the directory display
	set dir [lindex [glob -nocomplain $dir] 0]
	set e $fileselect(dirEnt)
	$e config -state normal
	$e delete 0 end
	$e insert 0 $dir
	$e config -state disabled
	# scroll to view the tail end
	$e xview moveto 1

	$fileselect(list) delete 0 end
	set fileselect(dir) $dir
	if ![file isdirectory $dir] {
	    $fileselect(list) insert 0 "Bad Directory"
	    return
	}
	$fileselect(list) insert 0 Listing...
	update idletasks
	$fileselect(list) delete 0
	if {[string length $files] == 0} {
		# List the directory and add an
		# entry for the parent directory
		if [catch {
		    set pat [file join $fileselect(dir) *]
		}] {
		    if [string match / $fileselect(dir)] {
			set pat /*
		    } else {
			set pat $fileselect(dir)/*
		    }
		}
		set files [glob -nocomplain $pat]
		$fileselect(list) insert end [fileselectParent]
	}
	# Sort the directories to the front
	set dirs {}
	set others {}
	foreach f [lsort $files] {
		if [file isdirectory $f] {
			lappend dirs [fileselectShowDir [file tail $f]]
		} else {
			lappend others [file tail $f]
		}
	}
	if [string match dir $fileselect(exist)] {
	    set others ""
	}
	foreach f [concat $dirs $others] {
		$fileselect(list) insert end $f
	}
}
proc fileselectOK {{takedir 0}} {
	global fileselect
	if [catch {
	    set spath [file split $fileselect(path)]
	    set first [lindex $spath 0]
	    if [fileselectIsParent? $first] {
		set fileselect(path) [eval file join [lrange $spath 1 end]]
		set fileselect(dir) [file dirname $fileselect(dir)]
		if {[string compare $fileselect(dir) "."] == 0} {
		    set fileselect(dir) [pwd]
		}
		fileselectOK
		return
	    }
	    set path [file join $fileselect(dir) $fileselect(path)]
	    set fileselect(dir) [file dirname $path]
	}] {
	    # Pre 4.1 final code
	    set path [fileselectOKsetupPre4.1]
	    if {$path == ""} {
		return
	    }
	}
	if [file isdirectory $path] {
		if {$takedir && [string match dir $fileselect(exist)]} {
			set fileselect(path) $path
			set fileselect(done) 1
			return
		}
		set fileselect(path) {}
		fileselectList $path
		return
	}
	if [file exists $path] {
		set fileselect(path) $path
		set fileselect(done) 1
		return
	}
	# Neither a file or a directory.
	# See if glob will find something
	if [catch {glob $path} files] {
		# No, perhaps the user typed a new
		# absolute pathname
		if [catch {glob $fileselect(path)} ignore] {
			# Nothing good
			if {$fileselect(exist) == "file"} {
				# Attempt completion
				fileselectComplete
			} elseif {($fileselect(exist) == "")} {
				# Allow new name
				set fileselect(path) $path
				set fileselect(done) 1
			}
			return
		} else {
			# OK - try again
			set fileselect(dir) [file dirname $fileselect(path)]
			set fileselect(path) [file tail $fileselect(path)]
			fileselectOK
			return
		}
	} else {
		# Ok - current directory is ok,
		# either select the file or list them.
		if {[llength $files] == 1} {
			set fileselect(path) [lindex $files 0]
			fileselectOK
		} else {
			set fileselect(dir) [file dirname [lindex $files 0]]
			fileselectList $fileselect(dir) $files
		}
	}
}
proc fileselectOKsetupPre4.1 {} {
	global fileselect
	# Old unix-y code to munge file names

	# Handle the parent directory specially
	if {[regsub {^\.\./?} $fileselect(path) {} newpath] != 0} {
		set fileselect(path) $newpath
		set fileselect(dir) [file dirname $fileselect(dir)]
		if {[string compare $fileselect(dir) "."] == 0} {
		    set fileselect(dir) [pwd]
		}
		fileselectOK
		return ""
	}
	if [string match /* $fileselect(path)] {
		set path $fileselect(path)
		set fileselect(dir) [file dirname $path]
	} elseif {[string match ~* $fileselect(path)]} {
	        set path [glob -nocomplain $fileselect(path)]
	} elseif {[string match / $fileselect(dir)]} {
		set path /$fileselect(path)
	} elseif {[string length $fileselect(path)] == 0} {
		set path $fileselect(dir)
	} else {
		set path $fileselect(dir)/$fileselect(path)
	}
	if {[string length $path] > 1} {
	    set path [string trimright $path /]
	}
	return $path
}
proc fileselectCancel {} {
	global fileselect
	set fileselect(done) 1
	set fileselect(path) {}
}

proc fileselectClick { lb y } {
	# Take the item the user clicked on
	global fileselect
	set fileselect(path) [$lb get [$lb nearest $y]]
}
proc fileselectTake { lb } {
	# Take the currently selected list item
	global fileselect
	set fileselect(path) [$lb get [$lb curselection]]
}

proc fileselectComplete {} {
	global fileselect

	# Do file name completion
	# Nuke the space that triggered this call
	set fileselect(path) [string trim $fileselect(path) \t\ ]

	if [catch {
	    set path [file join $fileselect(dir) $fileselect(path)]
	    set dir [file dirname $path]
	    set tail [file tail $path]
	    set pat $path*
	}] {
	    # Figure out what directory we are looking at
	    # dir is the directory
	    # tail is the partial name
	    if {[string match /* $fileselect(path)]} {
		    set dir [file dirname $fileselect(path)]
		    set tail [file tail $fileselect(path)]
	    } elseif [string match ~* $fileselect(path)] {
		    if [catch {file dirname $fileselect(path)} dir] {
			    return	;# Bad user
		    }
		    set tail [file tail $fileselect(path)]
	    } else {
		    set path $fileselect(dir)/$fileselect(path)
		    set dir [file dirname $path]
		    set tail [file tail $path]
	    }
	    set pat $dir/$tail*
	}
	# See what files are there
	set files [glob -nocomplain $pat]
	if {[llength $files] == 1} {
		# Matched a single file
		set fileselect(dir) $dir
		set fileselect(path) [file tail $files]
	} else {
		if {[llength $files] > 1} {
			# Find the longest common prefix
			set l [expr [string length $tail]-1]
			set miss 0
			# Remember that files has absolute paths
			set file1 [file tail [lindex $files 0]]
			while {!$miss} {
				incr l
				if {$l == [string length $file1]} {
					# file1 is a prefix of all others
					break
				}
				set new [string range $file1 0 $l]
				foreach f $files {
					if ![string match $new* [file tail $f]] {
						set miss 1
						incr l -1
						break
					}
				}
			}
			set fileselect(path) [string range $file1 0 $l]
		}
		fileselectList $dir [lindex $files 0]
	}
}
proc fileselectParent {} {
    global tcl_platform
    if {$tcl_platform(platform) == "macintosh"} {
	return ::
    } else {
	return ../
    }
}
proc fileselectIsParent? {component} {
    global tcl_platform
    if {$tcl_platform(platform) == "macintosh"} {
	return [string match :: $component]
    } else {
	return [regexp {^\.\./?} $component]
    }
}
proc fileselectShowDir {component} {
    global tcl_platform
    if {$tcl_platform(platform) == "macintosh"} {
	return :$component
    } else {
	return $component/
    }
}
