summaryrefslogtreecommitdiffstats
path: root/tests/choosedir.test
diff options
context:
space:
mode:
Diffstat (limited to 'tests/choosedir.test')
-rw-r--r--tests/choosedir.test122
1 files changed, 122 insertions, 0 deletions
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