summaryrefslogtreecommitdiffstats
path: root/tests/filebox.test
diff options
context:
space:
mode:
Diffstat (limited to 'tests/filebox.test')
-rw-r--r--tests/filebox.test335
1 files changed, 205 insertions, 130 deletions
diff --git a/tests/filebox.test b/tests/filebox.test
index 353cc97..7b9fa2c 100644
--- a/tests/filebox.test
+++ b/tests/filebox.test
@@ -7,14 +7,22 @@
# All rights reserved.
package require tcltest 2.1
-namespace import -force tcltest::configure
-namespace import -force tcltest::testsDirectory
-configure -testdir [file join [pwd] [file dirname [info script]]]
-configure -loadfile [file join [testsDirectory] constraints.tcl]
+eval tcltest::configure $argv
tcltest::loadTestedCommands
-namespace import -force tcltest::makeFile
-namespace import -force tcltest::removeFile
+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
@@ -102,8 +110,8 @@ if {$tcl_platform(platform) == "unix"} {
set modes 1
}
-set unknownOptionsMsg(tk_getOpenFile) {1 {bad option "-foo": must be -defaultextension, -filetypes, -initialdir, -initialfile, -multiple, -parent, or -title}}
-set unknownOptionsMsg(tk_getSaveFile) {1 {bad option "-foo": must be -defaultextension, -filetypes, -initialdir, -initialfile, -parent, or -title}}
+set unknownOptionsMsg(tk_getOpenFile) {bad option "-foo": must be -defaultextension, -filetypes, -initialdir, -initialfile, -multiple, -parent, -title, or -typevariable}
+set unknownOptionsMsg(tk_getSaveFile) {bad option "-foo": must be -confirmoverwrite, -defaultextension, -filetypes, -initialdir, -initialfile, -parent, -title, or -typevariable}
set tmpFile "filebox.tmp"
makeFile {
@@ -130,12 +138,11 @@ array set filters {
}
foreach mode $modes {
-
#
# Test both the motif version and the "tk" version of the file dialog
# box on Unix.
#
- # Note that this can use the same test number twice!
+ # Note that this means that test names are unusually complex.
#
set addedExtensions {}
@@ -148,46 +155,42 @@ foreach mode $modes {
}
}
- test filebox-1.1 "tk_getOpenFile command" {
- list [catch {tk_getOpenFile -foo} msg] $msg
- } $unknownOptionsMsg(tk_getOpenFile)
+ test filebox-1.1-$mode "tk_getOpenFile command" -body {
+ tk_getOpenFile -foo
+ } -returnCodes error -result $unknownOptionsMsg(tk_getOpenFile)
catch {tk_getOpenFile -foo 1} msg
regsub -all , $msg "" options
regsub \"-foo\" $options "" options
foreach option $options {
- if {[string index $option 0] == "-"} {
- test filebox-1.2 "tk_getOpenFile command" {
- list [catch {tk_getOpenFile $option} msg] $msg
- } [list 1 "value for \"$option\" missing"]
+ 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 "tk_getOpenFile command" {
- list [catch {tk_getOpenFile -foo bar} msg] $msg
- } $unknownOptionsMsg(tk_getOpenFile)
-
- test filebox-1.4 "tk_getOpenFile command" {
- list [catch {tk_getOpenFile -initialdir} msg] $msg
- } {1 {value for "-initialdir" missing}}
-
- test filebox-1.5 "tk_getOpenFile command" {
- list [catch {tk_getOpenFile -parent foo.bar} msg] $msg
- } {1 {bad window path name "foo.bar"}}
-
- test filebox-1.6 "tk_getOpenFile command" {
- list [catch {tk_getOpenFile -filetypes {Foo}} msg] $msg
- } {1 {bad file type "Foo", should be "typeName {extension ?extensions ...?} ?{macType ?macTypes ...?}?"}}
-
- if {[info commands tk::MotifFDialog] == "" && [info commands ::tk::dialog::file::] == ""} {
- set isNative 1
- } else {
- set isNative 0
- }
-
+
+ test filebox-1.3-$mode "tk_getOpenFile command" -body {
+ tk_getOpenFile -foo bar
+ } -returnCodes error -result $unknownOptionsMsg(tk_getOpenFile)
+ 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
@@ -200,111 +203,125 @@ foreach mode $modes {
# set verylongstring $verylongstring$verylongstring
set color #404040
- test filebox-2.1 "tk_getOpenFile command" {nonUnixUserInteraction} {
+ 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 [pwd]
+ set fileDir [tcltest::temporaryDirectory]
set pathName [file join $fileDir $fileName]
-
- test filebox-2.2 "tk_getOpenFile command" {nonUnixUserInteraction} {
+
+ 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]
+ -parent $parent -initialfile $fileName -initialdir $fileDir]
} $pathName
-
- test filebox-2.3 "tk_getOpenFile command" {nonUnixUserInteraction} {
+ 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]
+ -parent $parent -initialdir $fileDir]
} $pathName
-
- test filebox-2.4 "tk_getOpenFile command" {nonUnixUserInteraction} {
+ 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]
+ -parent $parent -initialdir . -initialfile $fileName]
} $pathName
-
- test filebox-2.5 "tk_getOpenFile command" {nonUnixUserInteraction} {
+ 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]
+ -parent $parent -initialdir /badpath -initialfile $fileName]
} $pathName
-
- test filebox-2.6 "tk_getOpenFile command" {nonUnixUserInteraction} {
+ test filebox-2.6-$mode "tk_getOpenFile command" -setup {
toplevel .t1; toplevel .t2
wm geometry .t1 +0+0
wm geometry .t2 +0+0
- ToPressButton .t1 ok
+ } -constraints nonUnixUserInteraction -body {
set choice {}
+ ToPressButton .t1 ok
lappend choice [tk_getOpenFile \
- -title "Enter \"$fileName\" and press Ok" \
- -parent .t1 -initialdir $fileDir \
- -initialfile $fileName]
+ -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]
+ -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]
+ -title "Enter \"$fileName\" and press Ok" \
+ -parent .t1 -initialdir $fileDir \
+ -initialfile $fileName]
+ } -result [list $pathName $pathName $pathName] -cleanup {
destroy .t1
destroy .t2
- set choice
- } [list $pathName $pathName $pathName]
+ }
foreach x [lsort -integer [array names filters]] {
- test filebox-3.$x "tk_getOpenFile command" {nonUnixUserInteraction} {
- ToPressButton $parent ok
- set choice [tk_getOpenFile -title "Press Ok" -filetypes $filters($x)\
- -parent $parent -initialfile $fileName -initialdir $fileDir]
+ 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]} {
+ regexp {^(.*) \(.*\)$} $tv dummy typeName
+ } else {
+ set typeName "-unset-"
+ }
+ set typeName
+ } $res
+ }
- test filebox-4.1 "tk_getSaveFile command" {
- list [catch {tk_getSaveFile -foo} msg] $msg
- } $unknownOptionsMsg(tk_getSaveFile)
+ test filebox-4.1-$mode "tk_getSaveFile command" -body {
+ tk_getSaveFile -foo
+ } -returnCodes error -result $unknownOptionsMsg(tk_getSaveFile)
catch {tk_getSaveFile -foo 1} msg
regsub -all , $msg "" options
regsub \"-foo\" $options "" options
foreach option $options {
- if {[string index $option 0] == "-"} {
- test filebox-4.2 "tk_getSaveFile command" {
- list [catch {tk_getSaveFile $option} msg] $msg
- } [list 1 "value for \"$option\" missing"]
+ 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 "tk_getSaveFile command" {
- list [catch {tk_getSaveFile -foo bar} msg] $msg
- } $unknownOptionsMsg(tk_getSaveFile)
-
- test filebox-4.4 "tk_getSaveFile command" {
- list [catch {tk_getSaveFile -initialdir} msg] $msg
- } {1 {value for "-initialdir" missing}}
-
- test filebox-4.5 "tk_getSaveFile command" {
- list [catch {tk_getSaveFile -parent foo.bar} msg] $msg
- } {1 {bad window path name "foo.bar"}}
-
- test filebox-4.6 "tk_getSaveFile command" {
- list [catch {tk_getSaveFile -filetypes {Foo}} msg] $msg
- } {1 {bad file type "Foo", should be "typeName {extension ?extensions ...?} ?{macType ?macTypes ...?}?"}}
-
- if {[info commands tk::MotifFDialog] == "" && [info commands ::tk::dialog::file::] == ""} {
- set isNative 1
- } else {
- set isNative 0
- }
+ test filebox-4.3-$mode "tk_getSaveFile command" -body {
+ tk_getSaveFile -foo bar
+ } -returnCodes error -result $unknownOptionsMsg(tk_getSaveFile)
+ 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 .
@@ -320,7 +337,7 @@ foreach mode $modes {
# set verylongstring $verylongstring$verylongstring
set color #404040
- test filebox-5.1 "tk_getSaveFile command" {nonUnixUserInteraction} {
+ test filebox-5.1-$mode "tk_getSaveFile command" nonUnixUserInteraction {
ToPressButton $parent cancel
tk_getSaveFile -title "Press Cancel ($verylongstring)" -parent $parent
} ""
@@ -329,65 +346,122 @@ foreach mode $modes {
set fileDir [pwd]
set pathName [file join [pwd] $fileName]
- test filebox-5.2 "tk_getSaveFile command" {nonUnixUserInteraction} {
+ 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 "tk_getSaveFile command" {nonUnixUserInteraction} {
+ 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 "tk_getSaveFile command" {nonUnixUserInteraction} {
+ 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]
+ -parent $parent -initialdir . -initialfile $fileName]
} $pathName
-
- test filebox-5.5 "tk_getSaveFile command" {nonUnixUserInteraction} {
+ 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]
+ -parent $parent -initialdir /badpath -initialfile $fileName]
} $pathName
- test filebox-5.6 "tk_getSaveFile command" {nonUnixUserInteraction} {
+ test filebox-5.6-$mode "tk_getSaveFile command" -setup {
toplevel .t1; toplevel .t2
wm geometry .t1 +0+0
wm geometry .t2 +0+0
- ToPressButton .t1 ok
+ } -constraints nonUnixUserInteraction -body {
set choice {}
+ ToPressButton .t1 ok
lappend choice [tk_getSaveFile \
-title "Enter \"$fileName\" and press Ok" \
- -parent .t1 -initialdir $fileDir \
- -initialfile $fileName]
+ -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]
+ -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]
+ -parent .t1 -initialdir $fileDir -initialfile $fileName]
+ } -result [list $pathName $pathName $pathName] -cleanup {
destroy .t1
destroy .t2
- set choice
- } [list $pathName $pathName $pathName]
+ }
foreach x [lsort -integer [array names filters]] {
- test filebox-6.$x "tk_getSaveFile command" {nonUnixUserInteraction} {
+ 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]
+ 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.
# The test whether the dialog box widgets were implemented correctly.
# These tests are not
@@ -397,5 +471,6 @@ foreach mode $modes {
set tk_strictMotif $tk_strictMotif_old
# cleanup
-::tcltest::cleanupTests
+removeFile filebox.tmp
+cleanupTests
return