# 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. # # RCS: @(#) $Id: filebox.test,v 1.18 2004/12/20 10:34:20 vincentdarley Exp $ # package require tcltest 2.1 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 event generate $btn <1> -x 5 -y 5 event generate $btn -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 focus $w event generate $button event generate $w -keysym Return } } #---------------------------------------------------------------------- # # The test suite proper # #---------------------------------------------------------------------- if {$tcl_platform(platform) == "unix"} { set modes "0 1" } else { set modes 1 } 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 -defaultextension, -filetypes, -initialdir, -initialfile, -parent, -title, or -typevariable} 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-$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] 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-$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 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 [pwd] 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 { 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]} { regexp {^(.*) \(.*\)$} $tv dummy typeName } else { set typeName "-unset-" } set typeName } $res } 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] 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-$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 . 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] } # 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. } set tk_strictMotif $tk_strictMotif_old # cleanup removeFile filebox.tmp cleanupTests return