summaryrefslogtreecommitdiffstats
path: root/tests/filebox.test
diff options
context:
space:
mode:
Diffstat (limited to 'tests/filebox.test')
-rw-r--r--tests/filebox.test251
1 files changed, 251 insertions, 0 deletions
diff --git a/tests/filebox.test b/tests/filebox.test
new file mode 100644
index 0000000..6bae6c5
--- /dev/null
+++ b/tests/filebox.test
@@ -0,0 +1,251 @@
+# This file is a Tcl script to test out Tk's "tk_getOpenFile" and
+# "tk_getSaveFile" commands. It is organized in the standard fashion
+# for Tcl tests.
+#
+# Copyright (c) 1996 Sun Microsystems, Inc.
+#
+# See the file "license.terms" for information on usage and redistribution
+# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
+#
+# SCCS: @(#) filebox.test 1.5 97/10/10 11:03:21
+#
+
+set tk_strictMotif_old $tk_strictMotif
+
+#----------------------------------------------------------------------
+#
+# Procedures needed by this test file
+#
+#----------------------------------------------------------------------
+
+proc ToPressButton {parent btn} {
+ global isNative
+ if {!$isNative} {
+ after 100 SendButtonPress $parent $btn mouse
+ }
+}
+
+proc ToEnterFileByKey {parent fileName fileDir} {
+ global isNative
+ if {!$isNative} {
+ after 100 EnterFileByKey $parent [list $fileName] [list $fileDir]
+ }
+}
+
+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 EnterFileByKey {parent fileName fileDir} {
+ global tk_strictMotif
+ set w .__tk_filedialog
+ upvar #0 [winfo name $w] data
+
+ if {$tk_strictMotif} {
+ $data(sEnt) delete 0 end
+ $data(sEnt) insert 0 [file join $fileDir $fileName]
+ } else {
+ $data(ent) delete 0 end
+ $data(ent) insert 0 $fileName
+ }
+
+ update
+ SendButtonPress $parent ok mouse
+}
+
+proc SendButtonPress {parent btn type} {
+ global tk_strictMotif
+ set w .__tk_filedialog
+ upvar #0 [winfo name $w] data
+
+ set button $data($btn\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
+#
+#----------------------------------------------------------------------
+
+if {[string compare test [info procs test]] == 1} {
+ source defs
+}
+
+if {$tcl_platform(platform) == "unix"} {
+ set modes "0 1"
+} else {
+ set modes 1
+}
+
+set unknownOptionsMsg {1 {unknown option "-foo", must be -defaultextension, -filetypes, -initialdir, -initialfile, -parent or -title}}
+
+foreach mode $modes {
+
+ #
+ # Test both the motif version and the "tk" version of the file dialog
+ # box on Unix.
+ #
+
+ if {$tcl_platform(platform) == "unix"} {
+ set tk_strictMotif $mode
+ }
+
+ #
+ # Test both the "open" and the "save" dialogs
+ #
+
+ foreach command "tk_getOpenFile tk_getSaveFile" {
+
+ test filebox-1.1 "$command command" {
+ list [catch {$command -foo} msg] $msg
+ } $unknownOptionsMsg
+
+ regsub -all , $msg "" options
+ regsub \"-foo\" $options "" options
+
+ foreach option $options {
+ if {[string index $option 0] == "-"} {
+ test filebox-1.2 "$command command" {
+ list [catch {$command $option} msg] $msg
+ } [list 1 "value for \"$option\" missing"]
+ }
+ }
+
+ test filebox-1.3 "$command command" {
+ list [catch {$command -foo bar} msg] $msg
+ } $unknownOptionsMsg
+
+ test filebox-1.4 "$command command" {
+ list [catch {$command -initialdir} msg] $msg
+ } {1 {value for "-initialdir" missing}}
+
+ test filebox-1.5 "$command command" {
+ list [catch {$command -parent foo.bar} msg] $msg
+ } {1 {bad window path name "foo.bar"}}
+
+ test filebox-1.6 "$command command" {
+ list [catch {$command -filetypes {Foo}} msg] $msg
+ } {1 {bad file type "Foo", should be "typeName {extension ?extensions ...?} ?{macType ?macTypes ...?}?"}}
+
+ if {[info commands tkMotifFDialog] == "" && [info commands tkFDialog] == ""} {
+ set isNative 1
+ } else {
+ set isNative 0
+ }
+
+ if {$isNative && ![info exists INTERACTIVE]} {
+ continue
+ }
+
+ set parent .
+
+ set verylongstring longstring:
+ set verylongstring $verylongstring$verylongstring
+ set verylongstring $verylongstring$verylongstring
+ set verylongstring $verylongstring$verylongstring
+ set verylongstring $verylongstring$verylongstring
+# set verylongstring $verylongstring$verylongstring
+# set verylongstring $verylongstring$verylongstring
+# set verylongstring $verylongstring$verylongstring
+# set verylongstring $verylongstring$verylongstring
+# set verylongstring $verylongstring$verylongstring
+
+ set color #404040
+ test filebox-2.1 "$command command" {
+ ToPressButton $parent cancel
+ $command -title "Press Cancel ($verylongstring)" -parent $parent
+ } ""
+
+
+ if {$command == "tk_getSaveFile"} {
+ set fileName "12x 455"
+ set fileDir [pwd]
+ set pathName [file join [pwd] $fileName]
+ } else {
+ set thisFile [info script]
+ set fileName [file tail $thisFile]
+ set appPWD [pwd]
+ cd [file dirname $thisFile]
+ set fileDir [pwd]
+ cd $appPWD
+ set pathName [file join $fileDir $fileName]
+ }
+
+ test filebox-2.2 "$command command" {
+ ToPressButton $parent ok
+ set choice [$command -title "Press Ok" \
+ -parent $parent -initialfile $fileName -initialdir $fileDir]
+ } $pathName
+
+ test filebox-2.3 "$command command" {
+ ToEnterFileByKey $parent $fileName $fileDir
+ set choice [$command -title "Enter \"$fileName\" and press Ok" \
+ -parent $parent -initialdir $fileDir]
+ } $pathName
+
+ set filters(1) {}
+
+ set filters(2) {
+ {"Text files" {.txt .doc} }
+ {"Text files" {} TEXT}
+ {"Tcl Scripts" {.tcl} TEXT}
+ {"C Source Files" {.c .h} }
+ {"All Source Files" {.tcl .c .h} }
+ {"Image Files" {.gif} }
+ {"Image Files" {.jpeg .jpg} }
+ {"Image Files" "" {GIFF JPEG}}
+ {"All files" *}
+ }
+
+ set filters(3) {
+ {"Text files" {.txt .doc} TEXT}
+ {"Foo" {""} TEXT}
+ }
+
+ foreach x [lsort -integer [array names filters]] {
+ test filebox-3.$x "$command command" {
+ ToPressButton $parent ok
+ set choice [$command -title "Press Ok" -filetypes $filters($x)\
+ -parent $parent -initialfile $fileName -initialdir $fileDir]
+ } $pathName
+ }
+
+ #
+ # The rest of the tests need to be executed on Unix only. The test whether
+ # the dialog box widgets were implemented correctly. These tests are not
+ # needed on the other platforms because they use native file dialogs.
+ #
+
+
+
+
+ # end inner if
+ }
+
+ # end outer if
+}
+
+set tk_strictMotif $tk_strictMotif_old
+
+if {$isNative && ![info exists INTERACTIVE]} {
+ puts " Some tests were skipped because they could not be performed"
+ puts " automatically on this platform. If you wish to execute them"
+ puts " interactively, set the TCL variable INTERACTIVE and re-run"
+ puts " the test."
+ return
+}