# 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.1.1.1 2007/07/10 15:05:18 duncan Exp $ # 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] tcltest::loadTestedCommands namespace import -force tcltest::makeFile namespace import -force tcltest::removeFile 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) {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 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 can use the same test number twice! # 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 "tk_getOpenFile command" { list [catch {tk_getOpenFile -foo} msg] $msg } $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"] } } 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 } 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 "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 "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 "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 "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 "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 "tk_getOpenFile command" {nonUnixUserInteraction} { toplevel .t1; toplevel .t2 wm geometry .t1 +0+0 wm geometry .t2 +0+0 ToPressButton .t1 ok set choice {} 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] 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] } $pathName } test filebox-4.1 "tk_getSaveFile command" { list [catch {tk_getSaveFile -foo} msg] $msg } $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"] } } 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 } 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 "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 "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} { 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} { ToPressButton $parent ok set choice [tk_getSaveFile -title "Enter \"$fileName\" and press Ok" \ -parent $parent -initialdir . \ -initialfile $fileName] } $pathName test filebox-5.5 "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 "tk_getSaveFile command" {nonUnixUserInteraction} { toplevel .t1; toplevel .t2 wm geometry .t1 +0+0 wm geometry .t2 +0+0 ToPressButton .t1 ok set choice {} 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] 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} { 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 ::tcltest::cleanupTests return