Initial revision

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
+}