1# This file is a Tcl script to test out Tk's "tk_getOpenFile" and 2# "tk_getSaveFile" commands. It is organized in the standard fashion 3# for Tcl tests. 4# 5# Copyright (c) 1996 Sun Microsystems, Inc. 6# Copyright (c) 1998-1999 by Scriptics Corporation. 7# All rights reserved. 8# 9# RCS: @(#) $Id: filebox.test,v 1.13 2002/07/14 05:48:46 dgp Exp $ 10# 11 12package require tcltest 2.1 13namespace import -force tcltest::configure 14namespace import -force tcltest::testsDirectory 15configure -testdir [file join [pwd] [file dirname [info script]]] 16configure -loadfile [file join [testsDirectory] constraints.tcl] 17tcltest::loadTestedCommands 18 19namespace import -force tcltest::makeFile 20namespace import -force tcltest::removeFile 21 22set tk_strictMotif_old $tk_strictMotif 23 24#---------------------------------------------------------------------- 25# 26# Procedures needed by this test file 27# 28#---------------------------------------------------------------------- 29 30proc ToPressButton {parent btn} { 31 global isNative 32 if {!$isNative} { 33 after 100 SendButtonPress $parent $btn mouse 34 } 35} 36 37proc ToEnterFileByKey {parent fileName fileDir} { 38 global isNative 39 if {!$isNative} { 40 after 100 EnterFileByKey $parent [list $fileName] [list $fileDir] 41 } 42} 43 44proc PressButton {btn} { 45 event generate $btn <Enter> 46 event generate $btn <1> -x 5 -y 5 47 event generate $btn <ButtonRelease-1> -x 5 -y 5 48} 49 50proc EnterFileByKey {parent fileName fileDir} { 51 global tk_strictMotif 52 if {$parent == "."} { 53 set w .__tk_filedialog 54 } else { 55 set w $parent.__tk_filedialog 56 } 57 upvar ::tk::dialog::file::__tk_filedialog data 58 59 if {$tk_strictMotif} { 60 $data(sEnt) delete 0 end 61 $data(sEnt) insert 0 [file join $fileDir $fileName] 62 } else { 63 $data(ent) delete 0 end 64 $data(ent) insert 0 $fileName 65 } 66 67 update 68 SendButtonPress $parent ok mouse 69} 70 71proc SendButtonPress {parent btn type} { 72 global tk_strictMotif 73 if {$parent == "."} { 74 set w .__tk_filedialog 75 } else { 76 set w $parent.__tk_filedialog 77 } 78 upvar ::tk::dialog::file::__tk_filedialog data 79 80 set button $data($btn\Btn) 81 if ![winfo ismapped $button] { 82 update 83 } 84 85 if {$type == "mouse"} { 86 PressButton $button 87 } else { 88 event generate $w <Enter> 89 focus $w 90 event generate $button <Enter> 91 event generate $w <KeyPress> -keysym Return 92 } 93} 94 95 96#---------------------------------------------------------------------- 97# 98# The test suite proper 99# 100#---------------------------------------------------------------------- 101 102if {$tcl_platform(platform) == "unix"} { 103 set modes "0 1" 104} else { 105 set modes 1 106} 107 108set unknownOptionsMsg(tk_getOpenFile) {1 {bad option "-foo": must be -defaultextension, -filetypes, -initialdir, -initialfile, -multiple, -parent, or -title}} 109set unknownOptionsMsg(tk_getSaveFile) {1 {bad option "-foo": must be -defaultextension, -filetypes, -initialdir, -initialfile, -parent, or -title}} 110 111set tmpFile "filebox.tmp" 112makeFile { 113 # this file can be empty! 114} $tmpFile 115 116array set filters { 117 1 {} 118 2 { 119 {"Text files" {.txt .doc} } 120 {"Text files" {} TEXT} 121 {"Tcl Scripts" {.tcl} TEXT} 122 {"C Source Files" {.c .h} } 123 {"All Source Files" {.tcl .c .h} } 124 {"Image Files" {.gif} } 125 {"Image Files" {.jpeg .jpg} } 126 {"Image Files" "" {GIFF JPEG}} 127 {"All files" *} 128 } 129 3 { 130 {"Text files" {.txt .doc} TEXT} 131 {"Foo" {""} TEXT} 132 } 133} 134 135foreach mode $modes { 136 137 # 138 # Test both the motif version and the "tk" version of the file dialog 139 # box on Unix. 140 # 141 # Note that this can use the same test number twice! 142 # 143 144 set addedExtensions {} 145 if {$tcl_platform(platform) == "unix"} { 146 set tk_strictMotif $mode 147 # Extension adding is only done when using the non-motif file 148 # box with an extension-less filename 149 if {!$mode} { 150 set addedExtensions {NONE {} .txt .txt} 151 } 152 } 153 154 test filebox-1.1 "tk_getOpenFile command" { 155 list [catch {tk_getOpenFile -foo} msg] $msg 156 } $unknownOptionsMsg(tk_getOpenFile) 157 158 catch {tk_getOpenFile -foo 1} msg 159 regsub -all , $msg "" options 160 regsub \"-foo\" $options "" options 161 162 foreach option $options { 163 if {[string index $option 0] == "-"} { 164 test filebox-1.2 "tk_getOpenFile command" { 165 list [catch {tk_getOpenFile $option} msg] $msg 166 } [list 1 "value for \"$option\" missing"] 167 } 168 } 169 170 test filebox-1.3 "tk_getOpenFile command" { 171 list [catch {tk_getOpenFile -foo bar} msg] $msg 172 } $unknownOptionsMsg(tk_getOpenFile) 173 174 test filebox-1.4 "tk_getOpenFile command" { 175 list [catch {tk_getOpenFile -initialdir} msg] $msg 176 } {1 {value for "-initialdir" missing}} 177 178 test filebox-1.5 "tk_getOpenFile command" { 179 list [catch {tk_getOpenFile -parent foo.bar} msg] $msg 180 } {1 {bad window path name "foo.bar"}} 181 182 test filebox-1.6 "tk_getOpenFile command" { 183 list [catch {tk_getOpenFile -filetypes {Foo}} msg] $msg 184 } {1 {bad file type "Foo", should be "typeName {extension ?extensions ...?} ?{macType ?macTypes ...?}?"}} 185 186 if {[info commands tk::MotifFDialog] == "" && [info commands ::tk::dialog::file::] == ""} { 187 set isNative 1 188 } else { 189 set isNative 0 190 } 191 192 set parent . 193 194 set verylongstring longstring: 195 set verylongstring $verylongstring$verylongstring 196 set verylongstring $verylongstring$verylongstring 197 set verylongstring $verylongstring$verylongstring 198 set verylongstring $verylongstring$verylongstring 199 # set verylongstring $verylongstring$verylongstring 200 # set verylongstring $verylongstring$verylongstring 201 # set verylongstring $verylongstring$verylongstring 202 # set verylongstring $verylongstring$verylongstring 203 # set verylongstring $verylongstring$verylongstring 204 205 set color #404040 206 test filebox-2.1 "tk_getOpenFile command" {nonUnixUserInteraction} { 207 ToPressButton $parent cancel 208 tk_getOpenFile -title "Press Cancel ($verylongstring)" -parent $parent 209 } "" 210 211 set fileName $tmpFile 212 set fileDir [pwd] 213 set pathName [file join $fileDir $fileName] 214 215 test filebox-2.2 "tk_getOpenFile command" {nonUnixUserInteraction} { 216 ToPressButton $parent ok 217 set choice [tk_getOpenFile -title "Press Ok" \ 218 -parent $parent -initialfile $fileName -initialdir $fileDir] 219 } $pathName 220 221 test filebox-2.3 "tk_getOpenFile command" {nonUnixUserInteraction} { 222 ToEnterFileByKey $parent $fileName $fileDir 223 set choice [tk_getOpenFile -title "Enter \"$fileName\" and press Ok" \ 224 -parent $parent -initialdir $fileDir] 225 } $pathName 226 227 test filebox-2.4 "tk_getOpenFile command" {nonUnixUserInteraction} { 228 ToPressButton $parent ok 229 set choice [tk_getOpenFile -title "Enter \"$fileName\" and press Ok" \ 230 -parent $parent -initialdir . \ 231 -initialfile $fileName] 232 } $pathName 233 234 test filebox-2.5 "tk_getOpenFile command" {nonUnixUserInteraction} { 235 ToPressButton $parent ok 236 set choice [tk_getOpenFile -title "Enter \"$fileName\" and press Ok" \ 237 -parent $parent -initialdir /badpath \ 238 -initialfile $fileName] 239 } $pathName 240 241 test filebox-2.6 "tk_getOpenFile command" {nonUnixUserInteraction} { 242 toplevel .t1; toplevel .t2 243 wm geometry .t1 +0+0 244 wm geometry .t2 +0+0 245 ToPressButton .t1 ok 246 set choice {} 247 lappend choice [tk_getOpenFile \ 248 -title "Enter \"$fileName\" and press Ok" \ 249 -parent .t1 -initialdir $fileDir \ 250 -initialfile $fileName] 251 ToPressButton .t2 ok 252 lappend choice [tk_getOpenFile \ 253 -title "Enter \"$fileName\" and press Ok" \ 254 -parent .t2 -initialdir $fileDir \ 255 -initialfile $fileName] 256 ToPressButton .t1 ok 257 lappend choice [tk_getOpenFile \ 258 -title "Enter \"$fileName\" and press Ok" \ 259 -parent .t1 -initialdir $fileDir \ 260 -initialfile $fileName] 261 destroy .t1 262 destroy .t2 263 set choice 264 } [list $pathName $pathName $pathName] 265 266 foreach x [lsort -integer [array names filters]] { 267 test filebox-3.$x "tk_getOpenFile command" {nonUnixUserInteraction} { 268 ToPressButton $parent ok 269 set choice [tk_getOpenFile -title "Press Ok" -filetypes $filters($x)\ 270 -parent $parent -initialfile $fileName -initialdir $fileDir] 271 } $pathName 272 } 273 274 test filebox-4.1 "tk_getSaveFile command" { 275 list [catch {tk_getSaveFile -foo} msg] $msg 276 } $unknownOptionsMsg(tk_getSaveFile) 277 278 catch {tk_getSaveFile -foo 1} msg 279 regsub -all , $msg "" options 280 regsub \"-foo\" $options "" options 281 282 foreach option $options { 283 if {[string index $option 0] == "-"} { 284 test filebox-4.2 "tk_getSaveFile command" { 285 list [catch {tk_getSaveFile $option} msg] $msg 286 } [list 1 "value for \"$option\" missing"] 287 } 288 } 289 290 test filebox-4.3 "tk_getSaveFile command" { 291 list [catch {tk_getSaveFile -foo bar} msg] $msg 292 } $unknownOptionsMsg(tk_getSaveFile) 293 294 test filebox-4.4 "tk_getSaveFile command" { 295 list [catch {tk_getSaveFile -initialdir} msg] $msg 296 } {1 {value for "-initialdir" missing}} 297 298 test filebox-4.5 "tk_getSaveFile command" { 299 list [catch {tk_getSaveFile -parent foo.bar} msg] $msg 300 } {1 {bad window path name "foo.bar"}} 301 302 test filebox-4.6 "tk_getSaveFile command" { 303 list [catch {tk_getSaveFile -filetypes {Foo}} msg] $msg 304 } {1 {bad file type "Foo", should be "typeName {extension ?extensions ...?} ?{macType ?macTypes ...?}?"}} 305 306 if {[info commands tk::MotifFDialog] == "" && [info commands ::tk::dialog::file::] == ""} { 307 set isNative 1 308 } else { 309 set isNative 0 310 } 311 312 set parent . 313 314 set verylongstring longstring: 315 set verylongstring $verylongstring$verylongstring 316 set verylongstring $verylongstring$verylongstring 317 set verylongstring $verylongstring$verylongstring 318 set verylongstring $verylongstring$verylongstring 319 # set verylongstring $verylongstring$verylongstring 320 # set verylongstring $verylongstring$verylongstring 321 # set verylongstring $verylongstring$verylongstring 322 # set verylongstring $verylongstring$verylongstring 323 # set verylongstring $verylongstring$verylongstring 324 325 set color #404040 326 test filebox-5.1 "tk_getSaveFile command" {nonUnixUserInteraction} { 327 ToPressButton $parent cancel 328 tk_getSaveFile -title "Press Cancel ($verylongstring)" -parent $parent 329 } "" 330 331 set fileName "12x 455" 332 set fileDir [pwd] 333 set pathName [file join [pwd] $fileName] 334 335 test filebox-5.2 "tk_getSaveFile command" {nonUnixUserInteraction} { 336 ToPressButton $parent ok 337 set choice [tk_getSaveFile -title "Press Ok" \ 338 -parent $parent -initialfile $fileName -initialdir $fileDir] 339 } $pathName 340 341 test filebox-5.3 "tk_getSaveFile command" {nonUnixUserInteraction} { 342 ToEnterFileByKey $parent $fileName $fileDir 343 set choice [tk_getSaveFile -title "Enter \"$fileName\" and press Ok" \ 344 -parent $parent -initialdir $fileDir] 345 } $pathName 346 347 test filebox-5.4 "tk_getSaveFile command" {nonUnixUserInteraction} { 348 ToPressButton $parent ok 349 set choice [tk_getSaveFile -title "Enter \"$fileName\" and press Ok" \ 350 -parent $parent -initialdir . \ 351 -initialfile $fileName] 352 } $pathName 353 354 test filebox-5.5 "tk_getSaveFile command" {nonUnixUserInteraction} { 355 ToPressButton $parent ok 356 set choice [tk_getSaveFile -title "Enter \"$fileName\" and press Ok" \ 357 -parent $parent -initialdir /badpath \ 358 -initialfile $fileName] 359 } $pathName 360 361 test filebox-5.6 "tk_getSaveFile command" {nonUnixUserInteraction} { 362 toplevel .t1; toplevel .t2 363 wm geometry .t1 +0+0 364 wm geometry .t2 +0+0 365 ToPressButton .t1 ok 366 set choice {} 367 lappend choice [tk_getSaveFile \ 368 -title "Enter \"$fileName\" and press Ok" \ 369 -parent .t1 -initialdir $fileDir \ 370 -initialfile $fileName] 371 ToPressButton .t2 ok 372 lappend choice [tk_getSaveFile \ 373 -title "Enter \"$fileName\" and press Ok" \ 374 -parent .t2 -initialdir $fileDir \ 375 -initialfile $fileName] 376 ToPressButton .t1 ok 377 lappend choice [tk_getSaveFile \ 378 -title "Enter \"$fileName\" and press Ok" \ 379 -parent .t1 -initialdir $fileDir \ 380 -initialfile $fileName] 381 destroy .t1 382 destroy .t2 383 set choice 384 } [list $pathName $pathName $pathName] 385 386 foreach x [lsort -integer [array names filters]] { 387 test filebox-6.$x "tk_getSaveFile command" {nonUnixUserInteraction} { 388 ToPressButton $parent ok 389 set choice [tk_getSaveFile -title "Press Ok" -filetypes $filters($x)\ 390 -parent $parent -initialfile $fileName -initialdir $fileDir] 391 } $pathName[lindex $addedExtensions $x] 392 } 393 394 # The rest of the tests need to be executed on Unix only. 395 # The test whether the dialog box widgets were implemented correctly. 396 # These tests are not 397 # needed on the other platforms because they use native file dialogs. 398} 399 400set tk_strictMotif $tk_strictMotif_old 401 402# cleanup 403::tcltest::cleanupTests 404return 405