diff options
| -rw-r--r-- | doc/chooseDirectory.n | 52 | ||||
| -rw-r--r-- | doc/getOpenFile.n | 5 | ||||
| -rw-r--r-- | library/choosedir.tcl | 196 | ||||
| -rw-r--r-- | library/tclIndex | 1 | ||||
| -rw-r--r-- | library/tk.tcl | 7 | ||||
| -rw-r--r-- | unix/mkLinks | 4 |
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 |