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$ 10# 11 12package require tcltest 2.1 13eval tcltest::configure $argv 14tcltest::loadTestedCommands 15 16test fileDialog-0.1 {GetFileName: file types: MakeFilter() fails} { 17 # MacOS type that is too long 18 19 set res [list [catch {tk_getSaveFile -filetypes {{"foo" .foo {\0\0\0\0\0}}}} msg] $msg] 20 regsub -all "\0" $res {\\0} 21} {1 {bad Macintosh file type "\0\0\0\0\0"}} 22test fileDialog-0.2 {GetFileName: file types: MakeFilter() fails} { 23 # MacOS type that is too short, but looks ok in utf (4 bytes). 24 25 set x [catch {tk_getSaveFile -filetypes {{"foo" .foo {\0\0}}}} msg] 26 regsub -all "\0" $msg {\\0} msg 27 list $x $msg 28} {1 {bad Macintosh file type "\0\0"}} 29 30set tk_strictMotif_old $tk_strictMotif 31 32#---------------------------------------------------------------------- 33# 34# Procedures needed by this test file 35# 36#---------------------------------------------------------------------- 37 38proc ToPressButton {parent btn} { 39 global isNative 40 if {!$isNative} { 41 after 100 SendButtonPress $parent $btn mouse 42 } 43} 44 45proc ToEnterFileByKey {parent fileName fileDir} { 46 global isNative 47 if {!$isNative} { 48 after 100 EnterFileByKey $parent [list $fileName] [list $fileDir] 49 } 50} 51 52proc PressButton {btn} { 53 event generate $btn <Enter> 54 event generate $btn <1> -x 5 -y 5 55 event generate $btn <ButtonRelease-1> -x 5 -y 5 56} 57 58proc EnterFileByKey {parent fileName fileDir} { 59 global tk_strictMotif 60 if {$parent == "."} { 61 set w .__tk_filedialog 62 } else { 63 set w $parent.__tk_filedialog 64 } 65 upvar ::tk::dialog::file::__tk_filedialog data 66 67 if {$tk_strictMotif} { 68 $data(sEnt) delete 0 end 69 $data(sEnt) insert 0 [file join $fileDir $fileName] 70 } else { 71 $data(ent) delete 0 end 72 $data(ent) insert 0 $fileName 73 } 74 75 update 76 SendButtonPress $parent ok mouse 77} 78 79proc SendButtonPress {parent btn type} { 80 global tk_strictMotif 81 if {$parent == "."} { 82 set w .__tk_filedialog 83 } else { 84 set w $parent.__tk_filedialog 85 } 86 upvar ::tk::dialog::file::__tk_filedialog data 87 88 set button $data($btn\Btn) 89 if ![winfo ismapped $button] { 90 update 91 } 92 93 if {$type == "mouse"} { 94 PressButton $button 95 } else { 96 event generate $w <Enter> 97 focus $w 98 event generate $button <Enter> 99 event generate $w <KeyPress> -keysym Return 100 } 101} 102 103 104#---------------------------------------------------------------------- 105# 106# The test suite proper 107# 108#---------------------------------------------------------------------- 109 110if {$tcl_platform(platform) == "unix"} { 111 set modes "0 1" 112} else { 113 set modes 1 114} 115 116set unknownOptionsMsg(tk_getOpenFile) {bad option "-foo": must be -defaultextension, -filetypes, -initialdir, -initialfile, -multiple, -parent, -title, or -typevariable} 117set unknownOptionsMsg(tk_getSaveFile) {bad option "-foo": must be -defaultextension, -filetypes, -initialdir, -initialfile, -parent, -title, or -typevariable} 118 119set tmpFile "filebox.tmp" 120makeFile { 121 # this file can be empty! 122} $tmpFile 123 124array set filters { 125 1 {} 126 2 { 127 {"Text files" {.txt .doc} } 128 {"Text files" {} TEXT} 129 {"Tcl Scripts" {.tcl} TEXT} 130 {"C Source Files" {.c .h} } 131 {"All Source Files" {.tcl .c .h} } 132 {"Image Files" {.gif} } 133 {"Image Files" {.jpeg .jpg} } 134 {"Image Files" "" {GIFF JPEG}} 135 {"All files" *} 136 } 137 3 { 138 {"Text files" {.txt .doc} TEXT} 139 {"Foo" {""} TEXT} 140 } 141} 142 143foreach mode $modes { 144 # 145 # Test both the motif version and the "tk" version of the file dialog 146 # box on Unix. 147 # 148 # Note that this means that test names are unusually complex. 149 # 150 151 set addedExtensions {} 152 if {$tcl_platform(platform) == "unix"} { 153 set tk_strictMotif $mode 154 # Extension adding is only done when using the non-motif file 155 # box with an extension-less filename 156 if {!$mode} { 157 set addedExtensions {NONE {} .txt .txt} 158 } 159 } 160 161 test filebox-1.1-$mode "tk_getOpenFile command" -body { 162 tk_getOpenFile -foo 163 } -returnCodes error -result $unknownOptionsMsg(tk_getOpenFile) 164 165 catch {tk_getOpenFile -foo 1} msg 166 regsub -all , $msg "" options 167 regsub \"-foo\" $options "" options 168 169 foreach option $options { 170 if {[string index $option 0] eq "-"} { 171 test filebox-1.2-$mode$option "tk_getOpenFile command" -body { 172 tk_getOpenFile $option 173 } -returnCodes error -result "value for \"$option\" missing" 174 } 175 } 176 177 test filebox-1.3-$mode "tk_getOpenFile command" -body { 178 tk_getOpenFile -foo bar 179 } -returnCodes error -result $unknownOptionsMsg(tk_getOpenFile) 180 test filebox-1.4-$mode "tk_getOpenFile command" -body { 181 tk_getOpenFile -initialdir 182 } -returnCodes error -result {value for "-initialdir" missing} 183 test filebox-1.5-$mode "tk_getOpenFile command" -body { 184 tk_getOpenFile -parent foo.bar 185 } -returnCodes error -result {bad window path name "foo.bar"} 186 test filebox-1.6-$mode "tk_getOpenFile command" -body { 187 tk_getOpenFile -filetypes {Foo} 188 } -returnCodes error -result {bad file type "Foo", should be "typeName {extension ?extensions ...?} ?{macType ?macTypes ...?}?"} 189 190 set isNative [expr { 191 [info commands ::tk::MotifFDialog] eq "" && 192 [info commands ::tk::dialog::file::] eq "" 193 }] 194 195 set parent . 196 197 set verylongstring longstring: 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 # set verylongstring $verylongstring$verylongstring 205 # set verylongstring $verylongstring$verylongstring 206 # set verylongstring $verylongstring$verylongstring 207 208 set color #404040 209 test filebox-2.1-$mode "tk_getOpenFile command" nonUnixUserInteraction { 210 ToPressButton $parent cancel 211 tk_getOpenFile -title "Press Cancel ($verylongstring)" -parent $parent 212 } "" 213 214 set fileName $tmpFile 215 set fileDir [tcltest::temporaryDirectory] 216 set pathName [file join $fileDir $fileName] 217 218 test filebox-2.2-$mode "tk_getOpenFile command" nonUnixUserInteraction { 219 ToPressButton $parent ok 220 set choice [tk_getOpenFile -title "Press Ok" \ 221 -parent $parent -initialfile $fileName -initialdir $fileDir] 222 } $pathName 223 test filebox-2.3-$mode "tk_getOpenFile command" nonUnixUserInteraction { 224 ToEnterFileByKey $parent $fileName $fileDir 225 set choice [tk_getOpenFile -title "Enter \"$fileName\" and press Ok" \ 226 -parent $parent -initialdir $fileDir] 227 } $pathName 228 test filebox-2.4-$mode "tk_getOpenFile command" nonUnixUserInteraction { 229 cd $fileDir 230 ToPressButton $parent ok 231 set choice [tk_getOpenFile -title "Enter \"$fileName\" and press Ok" \ 232 -parent $parent -initialdir . -initialfile $fileName] 233 } $pathName 234 test filebox-2.5-$mode "tk_getOpenFile command" nonUnixUserInteraction { 235 ToPressButton $parent ok 236 set choice [tk_getOpenFile -title "Enter \"$fileName\" and press Ok" \ 237 -parent $parent -initialdir /badpath -initialfile $fileName] 238 } $pathName 239 test filebox-2.6-$mode "tk_getOpenFile command" -setup { 240 toplevel .t1; toplevel .t2 241 wm geometry .t1 +0+0 242 wm geometry .t2 +0+0 243 } -constraints nonUnixUserInteraction -body { 244 set choice {} 245 ToPressButton .t1 ok 246 lappend choice [tk_getOpenFile \ 247 -title "Enter \"$fileName\" and press Ok" \ 248 -parent .t1 -initialdir $fileDir \ 249 -initialfile $fileName] 250 ToPressButton .t2 ok 251 lappend choice [tk_getOpenFile \ 252 -title "Enter \"$fileName\" and press Ok" \ 253 -parent .t2 -initialdir $fileDir \ 254 -initialfile $fileName] 255 ToPressButton .t1 ok 256 lappend choice [tk_getOpenFile \ 257 -title "Enter \"$fileName\" and press Ok" \ 258 -parent .t1 -initialdir $fileDir \ 259 -initialfile $fileName] 260 } -result [list $pathName $pathName $pathName] -cleanup { 261 destroy .t1 262 destroy .t2 263 } 264 265 foreach x [lsort -integer [array names filters]] { 266 test filebox-3.$x-$mode "tk_getOpenFile command" nonUnixUserInteraction { 267 ToPressButton $parent ok 268 set choice [tk_getOpenFile -title "Press Ok" \ 269 -filetypes $filters($x) -parent $parent \ 270 -initialfile $fileName -initialdir $fileDir] 271 } $pathName 272 } 273 foreach {x res} [list 1 "-unset-" 2 "Text files"] { 274 set t [expr {$x + [llength [array names filters]]}] 275 test filebox-3.$t-$mode "tk_getOpenFile command" nonUnixUserInteraction { 276 catch {unset tv} 277 catch {unset typeName} 278 ToPressButton $parent ok 279 if {[info exists tv]} { 280 } else { 281 } 282 set choice [tk_getOpenFile -title "Press Ok" \ 283 -filetypes $filters($x) -parent $parent \ 284 -initialfile $fileName -initialdir $fileDir \ 285 -typevariable tv] 286 if {[info exists tv]} { 287 regexp {^(.*) \(.*\)$} $tv dummy typeName 288 } else { 289 set typeName "-unset-" 290 } 291 set typeName 292 } $res 293 } 294 295 test filebox-4.1-$mode "tk_getSaveFile command" -body { 296 tk_getSaveFile -foo 297 } -returnCodes error -result $unknownOptionsMsg(tk_getSaveFile) 298 299 catch {tk_getSaveFile -foo 1} msg 300 regsub -all , $msg "" options 301 regsub \"-foo\" $options "" options 302 303 foreach option $options { 304 if {[string index $option 0] eq "-"} { 305 test filebox-4.2-$mode$option "tk_getSaveFile command" -body { 306 tk_getSaveFile $option 307 } -returnCodes error -result "value for \"$option\" missing" 308 } 309 } 310 311 test filebox-4.3-$mode "tk_getSaveFile command" -body { 312 tk_getSaveFile -foo bar 313 } -returnCodes error -result $unknownOptionsMsg(tk_getSaveFile) 314 test filebox-4.4-$mode "tk_getSaveFile command" -body { 315 tk_getSaveFile -initialdir 316 } -returnCodes error -result {value for "-initialdir" missing} 317 test filebox-4.5-$mode "tk_getSaveFile command" -body { 318 tk_getSaveFile -parent foo.bar 319 } -returnCodes error -result {bad window path name "foo.bar"} 320 test filebox-4.6-$mode "tk_getSaveFile command" -body { 321 tk_getSaveFile -filetypes {Foo} 322 } -returnCodes error -result {bad file type "Foo", should be "typeName {extension ?extensions ...?} ?{macType ?macTypes ...?}?"} 323 324 set isNative [expr { 325 [info commands ::tk::MotifFDialog] eq "" && 326 [info commands ::tk::dialog::file::] eq "" 327 }] 328 329 set parent . 330 331 set verylongstring longstring: 332 set verylongstring $verylongstring$verylongstring 333 set verylongstring $verylongstring$verylongstring 334 set verylongstring $verylongstring$verylongstring 335 set verylongstring $verylongstring$verylongstring 336 # set verylongstring $verylongstring$verylongstring 337 # set verylongstring $verylongstring$verylongstring 338 # set verylongstring $verylongstring$verylongstring 339 # set verylongstring $verylongstring$verylongstring 340 # set verylongstring $verylongstring$verylongstring 341 342 set color #404040 343 test filebox-5.1-$mode "tk_getSaveFile command" nonUnixUserInteraction { 344 ToPressButton $parent cancel 345 tk_getSaveFile -title "Press Cancel ($verylongstring)" -parent $parent 346 } "" 347 348 set fileName "12x 455" 349 set fileDir [pwd] 350 set pathName [file join [pwd] $fileName] 351 352 test filebox-5.2-$mode "tk_getSaveFile command" nonUnixUserInteraction { 353 ToPressButton $parent ok 354 set choice [tk_getSaveFile -title "Press Ok" \ 355 -parent $parent -initialfile $fileName -initialdir $fileDir] 356 } $pathName 357 test filebox-5.3-$mode "tk_getSaveFile command" nonUnixUserInteraction { 358 ToEnterFileByKey $parent $fileName $fileDir 359 set choice [tk_getSaveFile -title "Enter \"$fileName\" and press Ok" \ 360 -parent $parent -initialdir $fileDir] 361 } $pathName 362 test filebox-5.4-$mode "tk_getSaveFile command" nonUnixUserInteraction { 363 ToPressButton $parent ok 364 set choice [tk_getSaveFile -title "Enter \"$fileName\" and press Ok" \ 365 -parent $parent -initialdir . -initialfile $fileName] 366 } $pathName 367 test filebox-5.5-$mode "tk_getSaveFile command" nonUnixUserInteraction { 368 ToPressButton $parent ok 369 set choice [tk_getSaveFile -title "Enter \"$fileName\" and press Ok" \ 370 -parent $parent -initialdir /badpath -initialfile $fileName] 371 } $pathName 372 373 test filebox-5.6-$mode "tk_getSaveFile command" -setup { 374 toplevel .t1; toplevel .t2 375 wm geometry .t1 +0+0 376 wm geometry .t2 +0+0 377 } -constraints nonUnixUserInteraction -body { 378 set choice {} 379 ToPressButton .t1 ok 380 lappend choice [tk_getSaveFile \ 381 -title "Enter \"$fileName\" and press Ok" \ 382 -parent .t1 -initialdir $fileDir -initialfile $fileName] 383 ToPressButton .t2 ok 384 lappend choice [tk_getSaveFile \ 385 -title "Enter \"$fileName\" and press Ok" \ 386 -parent .t2 -initialdir $fileDir -initialfile $fileName] 387 ToPressButton .t1 ok 388 lappend choice [tk_getSaveFile \ 389 -title "Enter \"$fileName\" and press Ok" \ 390 -parent .t1 -initialdir $fileDir -initialfile $fileName] 391 } -result [list $pathName $pathName $pathName] -cleanup { 392 destroy .t1 393 destroy .t2 394 } 395 396 foreach x [lsort -integer [array names filters]] { 397 test filebox-6.$x-$mode "tk_getSaveFile command" nonUnixUserInteraction { 398 ToPressButton $parent ok 399 set choice [tk_getSaveFile -title "Press Ok" \ 400 -filetypes $filters($x) -parent $parent \ 401 -initialfile $fileName -initialdir $fileDir] 402 } $pathName[lindex $addedExtensions $x] 403 } 404 405 if {!$mode} { 406 407 test filebox-7.1-$mode "tk_getOpenFile - directory not readable" \ 408 -constraints nonUnixUserInteraction \ 409 -setup { 410 rename ::tk_messageBox ::saved_messageBox 411 set ::gotmessage {} 412 proc tk_messageBox args { 413 set ::gotmessage $args 414 } 415 toplevel .t1 416 file mkdir [file join $fileDir NOTREADABLE] 417 file attributes [file join $fileDir NOTREADABLE] \ 418 -permissions 300 419 } \ 420 -cleanup { 421 rename ::tk_messageBox {} 422 rename ::saved_messageBox ::tk_messageBox 423 unset ::gotmessage 424 destroy .t1 425 file delete -force [file join $fileDir NOTREADABLE] 426 } \ 427 -body { 428 ToEnterFileByKey .t1 NOTREADABLE $fileDir 429 ToPressButton .t1 ok 430 ToPressButton .t1 cancel 431 tk_getOpenFile -parent .t1 \ 432 -title "Please select the NOTREADABLE directory" \ 433 -initialdir $fileDir 434 set gotmessage 435 } \ 436 -match glob \ 437 -result "*NOTREADABLE*" 438 439 test filebox-7.2-$mode "tk_getOpenFile - bad file name" \ 440 -constraints nonUnixUserInteraction \ 441 -setup { 442 rename ::tk_messageBox ::saved_messageBox 443 set ::gotmessage {} 444 proc tk_messageBox args { 445 set ::gotmessage $args 446 } 447 toplevel .t1 448 } \ 449 -cleanup { 450 rename ::tk_messageBox {} 451 rename ::saved_messageBox ::tk_messageBox 452 unset ::gotmessage 453 destroy .t1 454 } \ 455 -body { 456 ToEnterFileByKey .t1 RUBBISH $fileDir 457 ToPressButton .t1 ok 458 ToPressButton .t1 cancel 459 tk_getOpenFile -parent .t1 \ 460 -title "Please enter RUBBISH as a file name" \ 461 -initialdir $fileDir 462 set gotmessage 463 } \ 464 -match glob \ 465 -result "*RUBBISH*" 466 } 467 468 # The rest of the tests need to be executed on Unix only. 469 # The test whether the dialog box widgets were implemented correctly. 470 # These tests are not 471 # needed on the other platforms because they use native file dialogs. 472} 473 474set tk_strictMotif $tk_strictMotif_old 475 476# cleanup 477removeFile filebox.tmp 478cleanupTests 479return 480