Fixed handling of -mustexist flag for tk_chooseDirectory.

FossilOrigin-Name: b4a3ebbf8a9f27bce3d14ac8ae97b31938879b40

2 files changed, 135 insertions, 22 deletions

diff --git a/library/choosedir.tcl b/library/choosedir.tcl
index 724b33c..6ccbb9f 100644
--- a/library/choosedir.tcl
+++ b/library/choosedir.tcl
@@ -6,7 +6,7 @@
 # Copyright (c) 1998-2000 by Scriptics Corporation.

 # All rights reserved.

 # 

-# RCS: @(#) $Id: choosedir.tcl,v 1.2 2000/02/01 23:23:21 ericm Exp $

+# RCS: @(#) $Id: choosedir.tcl,v 1.3 2000/02/14 22:00:17 ericm Exp $

 

 # Make sure the tk::dialog namespace, in which all dialogs should live, exists

 namespace eval ::tk::dialog {}

@@ -22,12 +22,13 @@ proc ::tk::dialog::chooseDir::tkChooseDirectory { args } {
 

     # Error messages

     append err(usage) "tk_chooseDirectory "

-    append err(usage) "?-initialdir directory? ?-mustexist? "

+    append err(usage) "?-initialdir directory? ?-mustexist boolean? "

     append err(usage) "?-parent window? ?-title title?"

 

     set err(wrongNumArgs) "wrong # args: should be \"$err(usage)\""

     set err(valueMissing) "value for \"%s\" missing: should be \"$err(usage)\""

     set err(unknownOpt)   "unknown option \"%s\": should be \"$err(usage)\""

+    set err(badWindow)    "bad window path name \"%s\""

 

     # Default values

     set opts(-initialdir)	[pwd]

@@ -40,36 +41,26 @@ proc ::tk::dialog::chooseDir::tkChooseDirectory { args } {
     for { set i 0 } { $i < $len } {incr i} {

 	set flag [lindex $args $i]

 	incr i

+	if { $i >= $len } {

+	    error [format $err(valueMissing) $flag]

+	}

 	switch -glob -- $flag {

-	    "-initialdir" {

-		if { $i >= $len } {

-		    error [format $err(valueMissing) $flag]

-		}

-		set opts($flag) [lindex $args $i]

-	    }

-	    "-mustexist" {

-		set opts($flag) 1

-		incr i -1

-	    }

-	    "-parent" {

-		if { $i >= $len } {

-		    error [format $err(valueMissing) $flag]

-		}

-		set opts($flag) [lindex $args $i]

-	    }

+	    "-initialdir" -

+	    "-mustexist"  -

+	    "-parent"     -

 	    "-title" {

-		if { $i >= $len } {

-		    error [format $err(valueMissing) $flag]

-		}

 		set opts($flag) [lindex $args $i]

 	    }

 	    default {

-		error [format $err(unknownOpt) [lindex $args $i]]

+		error [format $err(unknownOpt) $flag]

 	    }

 	}

     }

 	    

     # Handle default parent window

+    if { ![winfo exists $opts(-parent)] } {

+	error [format $err(badWindow) $opts(-parent)]

+    }

     if {[string equal $opts(-parent) "."]} {

 	set opts(-parent) ""

     }

diff --git a/tests/choosedir.test b/tests/choosedir.test
new file mode 100644
index 0000000..3f88147
--- /dev/null
+++ b/tests/choosedir.test
@@ -0,0 +1,122 @@
+# This file is a Tcl script to test out Tk's "tk_chooseDir" and
+# It is organized in the standard fashion for Tcl tests.
+#
+# Copyright (c) 1996 Sun Microsystems, Inc.
+# Copyright (c) 1998-1999 by Scriptics Corporation.
+# All rights reserved.
+#
+# RCS: @(#) $Id: choosedir.test,v 1.1 2000/02/14 22:00:17 ericm Exp $
+#
+
+if {[lsearch [namespace children] ::tcltest] == -1} {
+    package require tcltest
+    namespace import ::tcltest::*
+}
+
+#----------------------------------------------------------------------
+#
+# Procedures needed by this test file
+#
+#----------------------------------------------------------------------
+
+proc ToPressButton {parent btn} {
+    after 100 SendButtonPress $parent $btn mouse
+}
+
+proc ToEnterDirByKey {parent dir} {
+    after 100 EnterDirByKey $parent [list $dir]
+}
+
+proc PressButton {btn} {
+    event generate $btn <Enter>
+    event generate $btn <1> -x 5 -y 5
+    event generate $btn <ButtonRelease-1> -x 5 -y 5
+}
+
+proc EnterDirByKey {parent dir} {
+    if {$parent == "."} {
+	set w .choosedirectory
+    } else {
+	set w $parent.choosedirectory
+    }
+
+    $w.e delete 0 end
+    $w.e insert 0 $dir
+
+    update
+    SendButtonPress $parent ok mouse
+}
+
+proc SendButtonPress {parent btn type} {
+    if {$parent == "."} {
+	set w .choosedirectory
+    } else {
+	set w $parent.choosedirectory
+    }
+
+    set button $w.$btn
+    if ![winfo ismapped $button] {
+	update
+    }
+
+    if {$type == "mouse"} {
+	PressButton $button
+    } else {
+	event generate $w <Enter>
+	focus $w
+	event generate $button <Enter>
+	event generate $w <KeyPress> -keysym Return
+    }
+}
+
+
+#----------------------------------------------------------------------
+#
+# The test suite proper
+#
+#----------------------------------------------------------------------
+
+append err(usage) "tk_chooseDirectory "
+append err(usage) "?-initialdir directory? ?-mustexist boolean? "
+append err(usage) "?-parent window? ?-title title?"
+
+set err(wrongNumArgs) "wrong # args: should be \"$err(usage)\""
+set err(valueMissing) "value for \"%s\" missing: should be \"$err(usage)\""
+set err(unknownOpt)   "unknown option \"%s\": should be \"$err(usage)\""
+
+foreach opt {-initialdir -mustexist -parent -title} {
+    test filebox-1.1 "tk_chooseDirectory command" {
+	list [catch {tk_chooseDirectory $opt} msg] $msg
+    } [list 1 [format $err(valueMissing) $opt]]
+}
+test filebox-1.2 "tk_chooseDirectory command" {
+    list [catch {tk_chooseDirectory -foo bar} msg] $msg
+} [list 1 [format $err(unknownOpt) "-foo"]]
+test filebox-1.3 "tk_chooseDirectory command" {
+    list [catch {tk_chooseDirectory -parent foo.bar} msg] $msg
+} {1 {bad window path name "foo.bar"}}
+
+set parent .
+set initialdir [pwd]
+set pathName [pwd]
+set otherdir "/tmp"
+
+test filebox-2.1 "tk_chooseDirectory command" {unixOnly} {
+    ToPressButton $parent cancel
+    tk_chooseDirectory -title "Press Cancel" -parent $parent
+} ""
+test filebox-2.2 "tk_chooseDirectory command" {unixOnly} {
+    ToPressButton $parent ok
+    set choice [tk_chooseDirectory -title "Press Ok" \
+	    -parent $parent -initialdir $initialdir]
+} $initialdir
+test filebox-2.3 "tk_chooseDirectory command" {unixOnly} {
+    ToEnterDirByKey $parent $otherdir
+    set choice [tk_chooseDirectory \
+	    -title "Enter \"$otherdir\" and press Ok" \
+	    -parent $parent -initialdir $initialdir]
+} $otherdir
+ 
+# cleanup
+::tcltest::cleanupTests
+return