* doc/getOpenFile.n:

* doc/chooseDirectory.n: Man page/cross links for
tk_chooseDirectory (bug #1786).

* library/tk.tcl:
* library/tclIndex: Added hooks for tk_chooseDirectory. (bug #1786)

* library/choosedir.tcl: tk_chooseDirectory implementation for
Unix/Mac (bug #1786).

6 files changed, 263 insertions, 2 deletions

diff --git a/doc/chooseDirectory.n b/doc/chooseDirectory.n
new file mode 100644
index 0000000..42bf636
--- /dev/null
+++ b/doc/chooseDirectory.n
@@ -0,0 +1,52 @@
+'\"
+'\" Copyright (c) 1998-2000 by Scriptics Corporation.
+'\" All rights reserved.
+'\" 
+'\" RCS: @(#) $Id: chooseDirectory.n,v 1.1 2000/01/27 00:23:10 ericm Exp $
+'\" 
+.so man.macros
+.TH tk_chooseDirectory n 8.3 Tk "Tk Built-In Commands"
+.BS
+'\" Note:  do not modify the .SH NAME line immediately below!
+.SH NAME
+tk_chooseDirectory \- pops up a dialog box for the user to select a directory.
+.PP
+.SH SYNOPSIS
+\fBtk_chooseDirectory \fR?\fIoption value ...\fR?
+.BE
+
+.SH DESCRIPTION
+.PP
+The procedure \fBtk_chooseDirectory\fR pops up a dialog box for the
+user to select a directory. The following \fIoption\-value\fR pairs are
+possible as command line arguments:
+.TP
+\fB\-initialdir\fR \fIdirname\fR
+Specifies that the directories in \fIdirectory\fR should be displayed
+when the dialog pops up. If this parameter is not specified, then
+the directories in the current working directory are displayed. If the
+parameter specifies a relative path, the return value will convert the
+relative path to an absolute path.  This option may not always work on
+the Macintosh.  This is not a bug. Rather, the \fIGeneral Controls\fR
+control panel on the Mac allows the end user to override the
+application default directory.
+.TP
+\fB\-parent\fR \fIwindow\fR
+Makes \fIwindow\fR the logical parent of the dialog. The dialog
+is displayed on top of its parent window.
+.TP
+\fB\-title\fR \fItitleString\fR
+Specifies a string to display as the title of the dialog box. If this
+option is not specified, then a default title will be displayed.
+.TP
+\fB\-mustexist\fR \fIboolean\fR
+Specifies whether the user may specify non-existant directories.  If
+this parameter is true, then the user may only select directories that
+already exist.  The default value is \fIfalse\fR.
+.LP
+
+.SH "SEE ALSO"
+tk_getOpenFile, tk_getSaveFile
+
+.SH KEYWORDS
+directory selection dialog
diff --git a/doc/getOpenFile.n b/doc/getOpenFile.n
index 4c19e65..de17086 100644
--- a/doc/getOpenFile.n
+++ b/doc/getOpenFile.n
@@ -4,7 +4,7 @@
 '\" See the file "license.terms" for information on usage and redistribution
 '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES.
 '\" 
-'\" RCS: @(#) $Id: getOpenFile.n,v 1.4 1999/12/16 21:57:11 hobbs Exp $
+'\" RCS: @(#) $Id: getOpenFile.n,v 1.5 2000/01/27 00:23:10 ericm Exp $
 '\" 
 .so man.macros
 .TH tk_getOpenFile n 4.2 Tk "Tk Built-In Commands"
@@ -152,5 +152,8 @@ if {$filename != ""} {
 }
 .CE
 
+.SH "SEE ALSO"
+tk_chooseDirectory
+
 .SH KEYWORDS
 file selection dialog
diff --git a/library/choosedir.tcl b/library/choosedir.tcl
new file mode 100644
index 0000000..fb92599
--- /dev/null
+++ b/library/choosedir.tcl
@@ -0,0 +1,196 @@
+# choosedir.tcl --

+#

+#	Choose directory dialog implementation for Unix/Mac.  Adapted from

+#	Christopher Nelson's (chris@pinebush.com) implementation.

+#

+# Copyright (c) 1998-2000 by Scriptics Corporation.

+# All rights reserved.

+# 

+# RCS: @(#) $Id: choosedir.tcl,v 1.1 2000/01/27 00:23:10 ericm Exp $

+

+package require opt

+

+namespace eval ::tkChooseDirectory {

+    variable value

+}

+

+::tcl::OptProc ::tkChooseDirectory::tk_chooseDirectory {

+    {-initialdir -string ""  

+            "Initial directory for browser"}

+    {-mustexist              

+            "If specified, user can't type in a new directory"}

+    {-parent     -string "."

+            "Parent window for browser"}

+    {-title      -string "Choose Directory"

+            "Title for browser window"}

+} {

+    # Handle default directory

+    if {[string length $initialdir] == 0} {

+	set initialdir [pwd]

+    }

+

+    # Handle default parent window

+    if {[string compare $parent "."] == 0} {

+	set parent ""

+    }

+

+    set w [toplevel $parent.choosedirectory]

+    wm title $w $title

+

+    # Commands for various bindings (which follow)

+    set okCommand  [namespace code \

+	    [list Done $w ok ::tkChooseDirectory::value($w)]]

+

+    set cancelCommand  [namespace code \

+	    [list Done $w cancel ::tkChooseDirectory::value($w)]]

+

+    # Create controls.

+    set lbl  [label $w.l -text "Directory name:" -anchor w]

+    set ent  [entry $w.e -width 30]

+    set frm  [frame $w.f]

+    set lst  [listbox $frm.lb -height 8 \

+	    -yscrollcommand [list $frm.sb set] \

+	    -selectmode browse \

+	    -setgrid true \

+	    -exportselection 0 \

+	    -takefocus 1]

+    set scr  [scrollbar $frm.sb -orient vertical \

+	    -command [list $frm.lb yview]]

+    set bOK  [button $w.ok     -width 8 -text OK -command $okCommand \

+	    -default active]

+    set bCan [button $w.cancel -width 8 -text Cancel -command $cancelCommand]

+

+    if {[llength [file volumes]]} {

+	# On Macs it would be nice to add a volume combobox

+    }

+

+    # Place controls on window

+    set padding 4

+    grid $lst $scr -sticky nsew

+    grid columnconfigure $frm 0 -weight 1

+    grid rowconfigure    $frm 0 -weight 1

+

+    grid $lbl $bOK  -padx $padding -pady $padding

+    grid $ent $bCan -padx $padding -pady $padding

+    grid $frm       -padx $padding -pady $padding

+

+    grid configure $lbl -sticky w

+    grid configure $ent -sticky ew

+    grid configure $frm -sticky nsew

+    grid columnconfigure . 0 -weight 1

+    grid columnconfigure . 1 -weight 1

+

+    $ent insert end $initialdir

+

+    # Set bindings

+    # <Return> is the same as OK

+    bind $w <Return> $okCommand

+

+    # <Escape> is the same as cancel

+    bind $w <Escape> $cancelCommand

+

+    # Closing the window is the same as cancel

+    wm protocol $w WM_DELETE_WINDOW $cancelCommand

+    

+    # Fill listbox and bind for browsing

+    Refresh $lst $initialdir

+    

+    bind $lst <Return> [namespace code [list Update $ent $lst]]

+    bind $lst <Double-ButtonRelease-1> [namespace code [list Update $ent $lst]]

+

+    ::tk::PlaceWindow $w widget [winfo parent $w]

+

+    # Set the min size when the size is known

+#    tkwait visibility $w

+#    tkChooseDirectory::MinSize $w

+

+    focus $ent

+    $ent selection range 0 end

+    grab set $w

+

+    # Wait for OK, Cancel or close

+    tkwait window $w

+

+    grab release $w

+    

+    set dir $::tkChooseDirectory::value($w)

+    unset ::tkChooseDirectory::value($w)

+    return $dir

+}

+# tkChooseDirectory::tk_chooseDirectory

+

+proc ::tkChooseDirectory::MinSize { w } {

+    set geometry [wm geometry $w]

+

+    regexp {([0-9]*)x([0-9]*)\+} geometry whole width height

+

+    wm minsize $w $width $height

+}

+

+proc ::tkChooseDirectory::Done { w why varName } {

+    variable value

+

+    switch -- $why {

+	ok {

+	    # If mustexist, validate with [cd]

+	    set value($w) [$w.e get]

+	}

+	cancel {

+	    set value($w) ""

+	}

+    }

+

+    destroy $w

+}

+

+proc ::tkChooseDirectory::Refresh { listbox dir } {

+    $listbox delete 0 end

+

+    # Find the parent directory; if it is different (ie, we're not

+    # already at the root), add a ".." entry

+    set parentDir [file dirname $dir]

+    if { ![string equal $parentDir $dir] } {

+	$listbox insert end ".."

+    }

+    

+    # add the subdirs to the listbox

+    foreach f [lsort [glob -nocomplain $dir/*]] {

+	if {[file isdirectory $f]} {

+	    $listbox insert end "[file tail $f]/"

+	}

+    }

+}

+

+proc ::tkChooseDirectory::Update { entry listbox } {

+    set sel [$listbox curselection]

+    if { [string equal $sel ""] } {

+	return

+    }

+    set subdir [$listbox get $sel]

+    if {[string compare $subdir ".."] == 0} {

+	set fullpath [file dirname [$entry get]]

+	if { [string equal $fullpath [$entry get]] } {

+	    return

+	}

+    } else {

+	set fullpath [file join [$entry get] $subdir]

+    }

+    $entry delete 0 end

+    $entry insert end $fullpath

+    Refresh $listbox $fullpath

+}

+

+# Some test code

+if {[string compare [info script] $argv0] == 0} {

+    catch {rename ::tk_chooseDirectory tk_chooseDir}

+    

+    proc tk_chooseDirectory { args } {

+	uplevel ::tkChooseDirectory::tk_chooseDirectory $args

+    }

+

+    wm withdraw .

+    set dir [tk_chooseDirectory -initialdir [pwd] \

+	    -title "Choose a directory"]

+    tk_messageBox -message "dir:<<$dir>>"

+    exit

+}

diff --git a/library/tclIndex b/library/tclIndex
index e2cf7f1..d0d2407 100644
--- a/library/tclIndex
+++ b/library/tclIndex
@@ -242,3 +242,4 @@ set auto_index(tkListBoxKeyAccel_Unset) [list source [file join $dir xmfbox.tcl]
 set auto_index(tkListBoxKeyAccel_Key) [list source [file join $dir xmfbox.tcl]]
 set auto_index(tkListBoxKeyAccel_Goto) [list source [file join $dir xmfbox.tcl]]
 set auto_index(tkListBoxKeyAccel_Reset) [list source [file join $dir xmfbox.tcl]]
+set auto_index(::tkChooseDirectory::tk_chooseDirectory) [list source [file join $dir choosedir.tcl]]
diff --git a/library/tk.tcl b/library/tk.tcl
index 5c8e5cc..e5347cc 100644
--- a/library/tk.tcl
+++ b/library/tk.tcl
@@ -3,7 +3,7 @@
 # Initialization script normally executed in the interpreter for each
 # Tk-based application.  Arranges class bindings for widgets.
 #
-# RCS: @(#) $Id: tk.tcl,v 1.16 2000/01/20 02:32:52 ericm Exp $
+# RCS: @(#) $Id: tk.tcl,v 1.17 2000/01/27 00:23:10 ericm Exp $
 #
 # Copyright (c) 1992-1994 The Regents of the University of California.
 # Copyright (c) 1994-1996 Sun Microsystems, Inc.
@@ -254,6 +254,11 @@ if {[string equal [info commands tk_messageBox] ""]} {
 	return [eval tkMessageBox $args]
     }
 }
+if {[string equal [info command tk_chooseDirectory] ""]} {
+    proc tk_chooseDirectory {args} {
+	return [eval ::tkChooseDirectory::tk_chooseDirectory $args]
+    }
+}
 	
 #----------------------------------------------------------------------
 # Define the set of common virtual events.
diff --git a/unix/mkLinks b/unix/mkLinks
index 08e5480..975b639 100644
--- a/unix/mkLinks
+++ b/unix/mkLinks
@@ -959,6 +959,10 @@ if test -r chooseColor.n; then
     rm -f tk_chooseColor.n
     ln chooseColor.n tk_chooseColor.n
 fi
+if test -r chooseDirectory.n; then
+    rm -f tk_chooseDirectory.n
+    ln chooseDirectory.n tk_chooseDirectory.n
+fi
 if test -r dialog.n; then
     rm -f tk_dialog.n
     ln dialog.n tk_dialog.n