--- /dev/null
+# 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.
+# Copyright (c) 1998-1999 by Scriptics Corporation.
+# All rights reserved.
+
+package require tcltest 2.2
+eval tcltest::configure $argv
+tcltest::loadTestedCommands
+
+test fileDialog-0.1 {GetFileName: file types: MakeFilter() fails} {
+ # MacOS type that is too long
+
+ set res [list [catch {tk_getSaveFile -filetypes {{"foo" .foo {\0\0\0\0\0}}}} msg] $msg]
+ regsub -all "\0" $res {\\0}
+} {1 {bad Macintosh file type "\0\0\0\0\0"}}
+test fileDialog-0.2 {GetFileName: file types: MakeFilter() fails} {
+ # MacOS type that is too short, but looks ok in utf (4 bytes).
+
+ set x [catch {tk_getSaveFile -filetypes {{"foo" .foo {\0\0}}}} msg]
+ regsub -all "\0" $msg {\\0} msg
+ list $x $msg
+} {1 {bad Macintosh file type "\0\0"}}
+
+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
+ if {$parent == "."} {
+ set w .__tk_filedialog
+ } else {
+ set w $parent.__tk_filedialog
+ }
+ upvar ::tk::dialog::file::__tk_filedialog 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
+ if {$parent == "."} {
+ set w .__tk_filedialog
+ } else {
+ set w $parent.__tk_filedialog
+ }
+ upvar ::tk::dialog::file::__tk_filedialog 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 {$tcl_platform(platform) == "unix"} {
+ set modes "0 1"
+} else {
+ set modes 1
+}
+
+set unknownOptionsMsg(tk_getOpenFile,notAqua) {bad option "-foo": must be -defaultextension, -filetypes, -initialdir, -initialfile, -multiple, -parent, -title, or -typevariable}
+set unknownOptionsMsg(tk_getOpenFile,aqua) {bad option "-foo": must be -defaultextension, -filetypes, -initialdir, -initialfile, -message, -multiple, -parent, -title, -typevariable, or -command}
+set unknownOptionsMsg(tk_getSaveFile,notAqua) {bad option "-foo": must be -confirmoverwrite, -defaultextension, -filetypes, -initialdir, -initialfile, -parent, -title, or -typevariable}
+set unknownOptionsMsg(tk_getSaveFile,aqua) {bad option "-foo": must be -defaultextension, -filetypes, -initialdir, -initialfile, -message, -parent, -title, -typevariable, -command, or -confirmoverwrite}
+
+set tmpFile "filebox.tmp"
+makeFile {
+ # this file can be empty!
+} $tmpFile
+
+array set filters {
+ 1 {}
+ 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" *}
+ }
+ 3 {
+ {"Text files" {.txt .doc} TEXT}
+ {"Foo" {""} TEXT}
+ }
+}
+
+foreach mode $modes {
+ #
+ # Test both the motif version and the "tk" version of the file dialog
+ # box on Unix.
+ #
+ # Note that this means that test names are unusually complex.
+ #
+
+ set addedExtensions {}
+ if {$tcl_platform(platform) == "unix"} {
+ set tk_strictMotif $mode
+ # Extension adding is only done when using the non-motif file
+ # box with an extension-less filename
+ if {!$mode} {
+ set addedExtensions {NONE {} .txt .txt}
+ }
+ }
+
+ test filebox-1.1.1-$mode "tk_getOpenFile command" -constraints notAqua -body {
+ tk_getOpenFile -foo
+ } -returnCodes error -result $unknownOptionsMsg(tk_getOpenFile,notAqua)
+ test filebox-1.1.2-$mode "tk_getOpenFile command" -constraints aqua -body {
+ tk_getOpenFile -foo
+ } -returnCodes error -result $unknownOptionsMsg(tk_getOpenFile,aqua)
+
+ catch {tk_getOpenFile -foo 1} msg
+ regsub -all , $msg "" options
+ regsub \"-foo\" $options "" options
+
+ foreach option $options {
+ if {[string index $option 0] eq "-"} {
+ test filebox-1.2-$mode$option "tk_getOpenFile command" -body {
+ tk_getOpenFile $option
+ } -returnCodes error -result "value for \"$option\" missing"
+ }
+ }
+
+ test filebox-1.3.1-$mode "tk_getOpenFile command" -constraints notAqua -body {
+ tk_getOpenFile -foo bar
+ } -returnCodes error -result $unknownOptionsMsg(tk_getOpenFile,notAqua)
+ test filebox-1.3.2-$mode "tk_getOpenFile command" -constraints aqua -body {
+ tk_getOpenFile -foo bar
+ } -returnCodes error -result $unknownOptionsMsg(tk_getOpenFile,aqua)
+ test filebox-1.4-$mode "tk_getOpenFile command" -body {
+ tk_getOpenFile -initialdir
+ } -returnCodes error -result {value for "-initialdir" missing}
+ test filebox-1.5-$mode "tk_getOpenFile command" -body {
+ tk_getOpenFile -parent foo.bar
+ } -returnCodes error -result {bad window path name "foo.bar"}
+ test filebox-1.6-$mode "tk_getOpenFile command" -body {
+ tk_getOpenFile -filetypes {Foo}
+ } -returnCodes error -result {bad file type "Foo", should be "typeName {extension ?extensions ...?} ?{macType ?macTypes ...?}?"}
+
+ set isNative [expr {
+ [info commands ::tk::MotifFDialog] eq "" &&
+ [info commands ::tk::dialog::file::] eq ""
+ }]
+
+ 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-$mode "tk_getOpenFile command" nonUnixUserInteraction {
+ ToPressButton $parent cancel
+ tk_getOpenFile -title "Press Cancel ($verylongstring)" -parent $parent
+ } ""
+
+ set fileName $tmpFile
+ set fileDir [tcltest::temporaryDirectory]
+ set pathName [file join $fileDir $fileName]
+
+ test filebox-2.2-$mode "tk_getOpenFile command" nonUnixUserInteraction {
+ ToPressButton $parent ok
+ set choice [tk_getOpenFile -title "Press Ok" \
+ -parent $parent -initialfile $fileName -initialdir $fileDir]
+ } $pathName
+ test filebox-2.3-$mode "tk_getOpenFile command" nonUnixUserInteraction {
+ ToEnterFileByKey $parent $fileName $fileDir
+ set choice [tk_getOpenFile -title "Enter \"$fileName\" and press Ok" \
+ -parent $parent -initialdir $fileDir]
+ } $pathName
+ test filebox-2.4-$mode "tk_getOpenFile command" nonUnixUserInteraction {
+ cd $fileDir
+ ToPressButton $parent ok
+ set choice [tk_getOpenFile -title "Enter \"$fileName\" and press Ok" \
+ -parent $parent -initialdir . -initialfile $fileName]
+ } $pathName
+ test filebox-2.5-$mode "tk_getOpenFile command" nonUnixUserInteraction {
+ ToPressButton $parent ok
+ set choice [tk_getOpenFile -title "Enter \"$fileName\" and press Ok" \
+ -parent $parent -initialdir /badpath -initialfile $fileName]
+ } $pathName
+ test filebox-2.6-$mode "tk_getOpenFile command" -setup {
+ toplevel .t1; toplevel .t2
+ wm geometry .t1 +0+0
+ wm geometry .t2 +0+0
+ } -constraints nonUnixUserInteraction -body {
+ set choice {}
+ ToPressButton .t1 ok
+ lappend choice [tk_getOpenFile \
+ -title "Enter \"$fileName\" and press Ok" \
+ -parent .t1 -initialdir $fileDir \
+ -initialfile $fileName]
+ ToPressButton .t2 ok
+ lappend choice [tk_getOpenFile \
+ -title "Enter \"$fileName\" and press Ok" \
+ -parent .t2 -initialdir $fileDir \
+ -initialfile $fileName]
+ ToPressButton .t1 ok
+ lappend choice [tk_getOpenFile \
+ -title "Enter \"$fileName\" and press Ok" \
+ -parent .t1 -initialdir $fileDir \
+ -initialfile $fileName]
+ } -result [list $pathName $pathName $pathName] -cleanup {
+ destroy .t1
+ destroy .t2
+ }
+
+ foreach x [lsort -integer [array names filters]] {
+ test filebox-3.$x-$mode "tk_getOpenFile command" nonUnixUserInteraction {
+ ToPressButton $parent ok
+ set choice [tk_getOpenFile -title "Press Ok" \
+ -filetypes $filters($x) -parent $parent \
+ -initialfile $fileName -initialdir $fileDir]
+ } $pathName
+ }
+ foreach {x res} [list 1 "-unset-" 2 "Text files"] {
+ set t [expr {$x + [llength [array names filters]]}]
+ test filebox-3.$t-$mode "tk_getOpenFile command" nonUnixUserInteraction {
+ catch {unset tv}
+ catch {unset typeName}
+ ToPressButton $parent ok
+ if {[info exists tv]} {
+ } else {
+ }
+ set choice [tk_getOpenFile -title "Press Ok" \
+ -filetypes $filters($x) -parent $parent \
+ -initialfile $fileName -initialdir $fileDir \
+ -typevariable tv]
+ if {[info exists tv]} {
+ set typeName $tv
+ } else {
+ set typeName "-unset-"
+ }
+ set typeName
+ } $res
+ }
+
+ test filebox-4.1.1-$mode "tk_getSaveFile command" -constraints notAqua -body {
+ tk_getSaveFile -foo
+ } -returnCodes error -result $unknownOptionsMsg(tk_getSaveFile,notAqua)
+ test filebox-4.1.2-$mode "tk_getSaveFile command" -constraints aqua -body {
+ tk_getSaveFile -foo
+ } -returnCodes error -result $unknownOptionsMsg(tk_getSaveFile,aqua)
+
+ catch {tk_getSaveFile -foo 1} msg
+ regsub -all , $msg "" options
+ regsub \"-foo\" $options "" options
+
+ foreach option $options {
+ if {[string index $option 0] eq "-"} {
+ test filebox-4.2-$mode$option "tk_getSaveFile command" -body {
+ tk_getSaveFile $option
+ } -returnCodes error -result "value for \"$option\" missing"
+ }
+ }
+
+ test filebox-4.3.1-$mode "tk_getSaveFile command" -constraints notAqua -body {
+ tk_getSaveFile -foo bar
+ } -returnCodes error -result $unknownOptionsMsg(tk_getSaveFile,notAqua)
+ test filebox-4.3.2-$mode "tk_getSaveFile command" -constraints aqua -body {
+ tk_getSaveFile -foo bar
+ } -returnCodes error -result $unknownOptionsMsg(tk_getSaveFile,aqua)
+ test filebox-4.4-$mode "tk_getSaveFile command" -body {
+ tk_getSaveFile -initialdir
+ } -returnCodes error -result {value for "-initialdir" missing}
+ test filebox-4.5-$mode "tk_getSaveFile command" -body {
+ tk_getSaveFile -parent foo.bar
+ } -returnCodes error -result {bad window path name "foo.bar"}
+ test filebox-4.6-$mode "tk_getSaveFile command" -body {
+ tk_getSaveFile -filetypes {Foo}
+ } -returnCodes error -result {bad file type "Foo", should be "typeName {extension ?extensions ...?} ?{macType ?macTypes ...?}?"}
+
+ set isNative [expr {
+ [info commands ::tk::MotifFDialog] eq "" &&
+ [info commands ::tk::dialog::file::] eq ""
+ }]
+
+ 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-5.1-$mode "tk_getSaveFile command" nonUnixUserInteraction {
+ ToPressButton $parent cancel
+ tk_getSaveFile -title "Press Cancel ($verylongstring)" -parent $parent
+ } ""
+
+ set fileName "12x 455"
+ set fileDir [pwd]
+ set pathName [file join [pwd] $fileName]
+
+ test filebox-5.2-$mode "tk_getSaveFile command" nonUnixUserInteraction {
+ ToPressButton $parent ok
+ set choice [tk_getSaveFile -title "Press Ok" \
+ -parent $parent -initialfile $fileName -initialdir $fileDir]
+ } $pathName
+ test filebox-5.3-$mode "tk_getSaveFile command" nonUnixUserInteraction {
+ ToEnterFileByKey $parent $fileName $fileDir
+ set choice [tk_getSaveFile -title "Enter \"$fileName\" and press Ok" \
+ -parent $parent -initialdir $fileDir]
+ } $pathName
+ test filebox-5.4-$mode "tk_getSaveFile command" nonUnixUserInteraction {
+ ToPressButton $parent ok
+ set choice [tk_getSaveFile -title "Enter \"$fileName\" and press Ok" \
+ -parent $parent -initialdir . -initialfile $fileName]
+ } $pathName
+ test filebox-5.5-$mode "tk_getSaveFile command" nonUnixUserInteraction {
+ ToPressButton $parent ok
+ set choice [tk_getSaveFile -title "Enter \"$fileName\" and press Ok" \
+ -parent $parent -initialdir /badpath -initialfile $fileName]
+ } $pathName
+
+ test filebox-5.6-$mode "tk_getSaveFile command" -setup {
+ toplevel .t1; toplevel .t2
+ wm geometry .t1 +0+0
+ wm geometry .t2 +0+0
+ } -constraints nonUnixUserInteraction -body {
+ set choice {}
+ ToPressButton .t1 ok
+ lappend choice [tk_getSaveFile \
+ -title "Enter \"$fileName\" and press Ok" \
+ -parent .t1 -initialdir $fileDir -initialfile $fileName]
+ ToPressButton .t2 ok
+ lappend choice [tk_getSaveFile \
+ -title "Enter \"$fileName\" and press Ok" \
+ -parent .t2 -initialdir $fileDir -initialfile $fileName]
+ ToPressButton .t1 ok
+ lappend choice [tk_getSaveFile \
+ -title "Enter \"$fileName\" and press Ok" \
+ -parent .t1 -initialdir $fileDir -initialfile $fileName]
+ } -result [list $pathName $pathName $pathName] -cleanup {
+ destroy .t1
+ destroy .t2
+ }
+
+ foreach x [lsort -integer [array names filters]] {
+ test filebox-6.$x-$mode "tk_getSaveFile command" nonUnixUserInteraction {
+ ToPressButton $parent ok
+ set choice [tk_getSaveFile -title "Press Ok" \
+ -filetypes $filters($x) -parent $parent \
+ -initialfile $fileName -initialdir $fileDir]
+ } $pathName[lindex $addedExtensions $x]
+ }
+
+ if {!$mode} {
+
+ test filebox-7.1-$mode "tk_getOpenFile - directory not readable" \
+ -constraints nonUnixUserInteraction \
+ -setup {
+ rename ::tk_messageBox ::saved_messageBox
+ set ::gotmessage {}
+ proc tk_messageBox args {
+ set ::gotmessage $args
+ }
+ toplevel .t1
+ file mkdir [file join $fileDir NOTREADABLE]
+ file attributes [file join $fileDir NOTREADABLE] \
+ -permissions 300
+ } \
+ -cleanup {
+ rename ::tk_messageBox {}
+ rename ::saved_messageBox ::tk_messageBox
+ unset ::gotmessage
+ destroy .t1
+ file delete -force [file join $fileDir NOTREADABLE]
+ } \
+ -body {
+ ToEnterFileByKey .t1 NOTREADABLE $fileDir
+ ToPressButton .t1 ok
+ ToPressButton .t1 cancel
+ tk_getOpenFile -parent .t1 \
+ -title "Please select the NOTREADABLE directory" \
+ -initialdir $fileDir
+ set gotmessage
+ } \
+ -match glob \
+ -result "*NOTREADABLE*"
+
+ test filebox-7.2-$mode "tk_getOpenFile - bad file name" \
+ -constraints nonUnixUserInteraction \
+ -setup {
+ rename ::tk_messageBox ::saved_messageBox
+ set ::gotmessage {}
+ proc tk_messageBox args {
+ set ::gotmessage $args
+ }
+ toplevel .t1
+ } \
+ -cleanup {
+ rename ::tk_messageBox {}
+ rename ::saved_messageBox ::tk_messageBox
+ unset ::gotmessage
+ destroy .t1
+ } \
+ -body {
+ ToEnterFileByKey .t1 RUBBISH $fileDir
+ ToPressButton .t1 ok
+ ToPressButton .t1 cancel
+ tk_getOpenFile -parent .t1 \
+ -title "Please enter RUBBISH as a file name" \
+ -initialdir $fileDir
+ set gotmessage
+ } \
+ -match glob \
+ -result "*RUBBISH*"
+ }
+
+ # The rest of the tests need to be executed on Unix only.
+ # They test whether the dialog box widgets were implemented correctly.
+ # These tests are not
+ # needed on the other platforms because they use native file dialogs.
+}
+
+set tk_strictMotif $tk_strictMotif_old
+
+# cleanup
+removeFile filebox.tmp
+cleanupTests
+return
OSDN Git Service
