util/src/TclTk/tk8.6.12/tests/filebox.test

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