diff options
Diffstat (limited to 'tests/filebox.test')
| -rw-r--r-- | tests/filebox.test | 251 |
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 +} |