From 40b335d9b0c6ca46aa6f5bba4f95528fea233129 Mon Sep 17 00:00:00 2001 From: ericm Date: Thu, 27 Jan 2000 00:23:10 +0000 Subject: * 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). --- doc/chooseDirectory.n | 52 ++++++++++++++ doc/getOpenFile.n | 5 +- library/choosedir.tcl | 196 ++++++++++++++++++++++++++++++++++++++++++++++++++ library/tclIndex | 1 + library/tk.tcl | 7 +- unix/mkLinks | 4 ++ 6 files changed, 263 insertions(+), 2 deletions(-) create mode 100644 doc/chooseDirectory.n create mode 100644 library/choosedir.tcl 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 + # is the same as OK + bind $w $okCommand + + # is the same as cancel + bind $w $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 [namespace code [list Update $ent $lst]] + bind $lst [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 -- cgit v0.12