1# -*- tcl -*- 2# This file is a Tcl script to test the Windows specific behavior of 3# the common dialog boxes. It is organized in the standard 4# fashion for Tcl tests. 5# 6# Copyright (c) 1997 Sun Microsystems, Inc. 7# Copyright (c) 1998-1999 by Scriptics Corporation. 8# Copyright (c) 1998-1999 ActiveState Corporation. 9# 10# RCS: @(#) $Id$ 11 12package require tcltest 2.1 13eval tcltest::configure $argv 14tcltest::loadTestedCommands 15 16if {[testConstraint testwinevent]} { 17 catch {testwinevent debug 1} 18} 19 20# Locale identifier LANG_ENGLISH is 0x09 21testConstraint english [expr { 22 [llength [info commands testwinlocale]] 23 && (([testwinlocale] & 0xff) == 9) 24}] 25 26proc start {arg} { 27 set ::tk_dialog 0 28 set ::iter_after 0 29 30 after 1 $arg 31} 32 33proc then {cmd} { 34 set ::command $cmd 35 set ::dialogresult {} 36 37 afterbody 38 vwait ::dialogresult 39 return $::dialogresult 40} 41 42proc afterbody {} { 43 if {$::tk_dialog == 0} { 44 if {[incr ::iter_after] > 30} { 45 set ::dialogresult ">30 iterations waiting on tk_dialog" 46 return 47 } 48 after 150 {afterbody} 49 return 50 } 51 uplevel #0 {set dialogresult [eval $command]} 52} 53 54proc Click {button} { 55 switch -exact -- $button { 56 ok { set button 1 } 57 cancel { set button 2 } 58 } 59 testwinevent $::tk_dialog $button WM_LBUTTONDOWN 1 0x000a000b 60 testwinevent $::tk_dialog $button WM_LBUTTONUP 0 0x000a000b 61} 62 63proc GetText {id} { 64 switch -exact -- $id { 65 ok { set id 1 } 66 cancel { set id 2 } 67 } 68 return [testwinevent $::tk_dialog $id WM_GETTEXT] 69} 70 71proc SetText {id text} { 72 return [testwinevent $::tk_dialog $id WM_SETTEXT $text] 73} 74 75test winDialog-1.1.0 {Tk_ChooseColorObjCmd} -constraints { 76 testwinevent 77} -body { 78 start {tk_chooseColor} 79 then { 80 Click cancel 81 } 82} -result {0} 83test winDialog-1.1.1 {Tk_ChooseColorObjCmd} -constraints { 84 testwinevent 85} -body { 86 start {set clr [tk_chooseColor -initialcolor "#ff9933"]} 87 then { 88 set x [Click cancel] 89 } 90 list $x $clr 91} -result {0 {}} 92test winDialog-1.1.2 {Tk_ChooseColorObjCmd} -constraints { 93 testwinevent 94} -body { 95 start {set clr [tk_chooseColor -initialcolor "#ff9933"]} 96 then { 97 set x [Click ok] 98 } 99 list $x $clr 100} -result [list 0 "#ff9933"] 101test winDialog-1.1.3 {Tk_ChooseColorObjCmd: -title} -constraints { 102 testwinevent 103} -setup {unset -nocomplain a x} -body { 104 set x {} 105 start {set clr [tk_chooseColor -initialcolor "#ff9933" -title "Hello"]} 106 then { 107 if {[catch { 108 array set a [testgetwindowinfo $::tk_dialog] 109 if {[info exists a(text)]} {lappend x $a(text)} 110 } err]} { lappend x $err } 111 lappend x [Click ok] 112 } 113 lappend x $clr 114} -result [list Hello 0 "#ff9933"] 115test winDialog-1.1.4 {Tk_ChooseColorObjCmd: -title} -constraints { 116 testwinevent 117} -setup {unset -nocomplain a x} -body { 118 set x {} 119 start { 120 set clr [tk_chooseColor -initialcolor "#ff9933" \ 121 -title "\u041f\u0440\u0438\u0432\u0435\u0442"] 122 } 123 then { 124 if {[catch { 125 array set a [testgetwindowinfo $::tk_dialog] 126 if {[info exists a(text)]} {lappend x $a(text)} 127 } err]} { lappend x $err } 128 lappend x [Click ok] 129 } 130 lappend x $clr 131} -result [list "\u041f\u0440\u0438\u0432\u0435\u0442" 0 "#ff9933"] 132test winDialog-1.1.5 {Tk_ChooseColorObjCmd: -parent} -constraints { 133 testwinevent 134} -setup {unset -nocomplain a x} -body { 135 start {set clr [tk_chooseColor -initialcolor "#ff9933" -parent .]} 136 set x {} 137 then { 138 if {[catch { 139 array set a [testgetwindowinfo $::tk_dialog] 140 if {[info exists a(parent)]} { 141 append x [expr {$a(parent) == [wm frame .]}] 142 } 143 } err]} {lappend x $err} 144 Click ok 145 } 146 list $x $clr 147} -result [list 1 "#ff9933"] 148test winDialog-1.1.6 {Tk_ChooseColorObjCmd: -parent} -constraints { 149 testwinevent 150} -body { 151 tk_chooseColor -initialcolor "#ff9933" -parent .xyzzy12 152} -returnCodes error -match glob -result {bad window path name*} 153 154test winDialog-2.1 {ColorDlgHookProc} {emptyTest nt} { 155} {} 156 157test winDialog-3.1 {Tk_GetOpenFileObjCmd} {nt testwinevent english} { 158 start {tk_getOpenFile} 159 then { 160 set x [GetText cancel] 161 Click cancel 162 } 163 set x 164} {Cancel} 165 166test winDialog-4.1 {Tk_GetSaveFileObjCmd} {nt testwinevent english} { 167 start {tk_getSaveFile} 168 then { 169 set x [GetText cancel] 170 Click cancel 171 } 172 set x 173} {Cancel} 174 175test winDialog-5.1 {GetFileName: no arguments} {nt testwinevent} { 176 start {tk_getOpenFile -title Open} 177 then { 178 Click cancel 179 } 180} {0} 181test winDialog-5.2 {GetFileName: one argument} {nt} { 182 list [catch {tk_getOpenFile -foo} msg] $msg 183} {1 {bad option "-foo": must be -defaultextension, -filetypes, -initialdir, -initialfile, -multiple, -parent, -title, or -typevariable}} 184test winDialog-5.4 {GetFileName: many arguments} {nt testwinevent} { 185 start {tk_getOpenFile -initialdir c:/ -parent . -title test -initialfile foo} 186 then { 187 Click cancel 188 } 189} {0} 190test winDialog-5.5 {GetFileName: Tcl_GetIndexFromObj() != TCL_OK} {nt} { 191 list [catch {tk_getOpenFile -foo bar -abc} msg] $msg 192} {1 {bad option "-foo": must be -defaultextension, -filetypes, -initialdir, -initialfile, -multiple, -parent, -title, or -typevariable}} 193test winDialog-5.6 {GetFileName: Tcl_GetIndexFromObj() == TCL_OK} {nt testwinevent} { 194 start {tk_getOpenFile -title bar} 195 then { 196 Click cancel 197 } 198} {0} 199test winDialog-5.7 {GetFileName: valid option, but missing value} {nt} { 200 list [catch {tk_getOpenFile -initialdir bar -title} msg] $msg 201} {1 {value for "-title" missing}} 202test winDialog-5.8 {GetFileName: extension begins with .} {nt testwinevent} { 203# if (string[0] == '.') { 204# string++; 205# } 206 207 start {set x [tk_getSaveFile -defaultextension .foo -title Save]} 208 then { 209 SetText 0x480 bar 210 Click ok 211 } 212 string totitle $x 213} [string totitle [file join [pwd] bar.foo]] 214test winDialog-5.9 {GetFileName: extension doesn't begin with .} {nt testwinevent} { 215 start {set x [tk_getSaveFile -defaultextension foo -title Save]} 216 then { 217 SetText 0x480 bar 218 Click ok 219 } 220 string totitle $x 221} [string totitle [file join [pwd] bar.foo]] 222test winDialog-5.10 {GetFileName: file types} {nt testwinevent} { 223# case FILE_TYPES: 224 225 start {tk_getSaveFile -filetypes {{"foo files" .foo FOOF}} -title Foo} 226 then { 227 set x [GetText 0x470] 228 Click cancel 229 } 230 set x 231} {foo files (*.foo)} 232test winDialog-5.11 {GetFileName: file types: MakeFilter() fails} {nt} { 233# if (MakeFilter(interp, string, &utfFilterString) != TCL_OK) 234 235 list [catch {tk_getSaveFile -filetypes {{"foo" .foo FOO}}} msg] $msg 236} {1 {bad Macintosh file type "FOO"}} 237if {[info exists ::env(TEMP)]} { 238test winDialog-5.12 {GetFileName: initial directory} {nt testwinevent} { 239# case FILE_INITDIR: 240 241 start {set x [tk_getSaveFile \ 242 -initialdir [file normalize $::env(TEMP)] \ 243 -initialfile "12x 455" -title Foo]} 244 then { 245 Click ok 246 } 247 set x 248} [file join [file normalize $::env(TEMP)] "12x 455"] 249} 250test winDialog-5.13 {GetFileName: initial directory: Tcl_TranslateFilename()} \ 251 {nt} { 252# if (Tcl_TranslateFileName(interp, string, &ds) == NULL) 253 254 list [catch {tk_getOpenFile -initialdir ~12x/455} msg] $msg 255} {1 {user "12x" doesn't exist}} 256test winDialog-5.14 {GetFileName: initial file} {nt testwinevent} { 257# case FILE_INITFILE: 258 259 start {set x [tk_getSaveFile -initialfile "12x 456" -title Foo]} 260 then { 261 Click ok 262 } 263 string totitle $x 264} [string totitle [file join [pwd] "12x 456"]] 265test winDialog-5.15 {GetFileName: initial file: Tcl_TranslateFileName()} {nt} { 266# if (Tcl_TranslateFileName(interp, string, &ds) == NULL) 267 list [catch {tk_getOpenFile -initialfile ~12x/455} msg] $msg 268} {1 {user "12x" doesn't exist}} 269test winDialog-5.16 {GetFileName: initial file: long name} {nt testwinevent} { 270 start { 271 set dialogresult [catch { 272 tk_getSaveFile -initialfile [string repeat a 1024] -title Long 273 } x] 274 } 275 then { 276 Click ok 277 } 278 list $dialogresult [string match "invalid filename *" $x] 279} {1 1} 280test winDialog-5.17 {GetFileName: parent} {nt} { 281# case FILE_PARENT: 282 283 toplevel .t 284 set x 0 285 start {tk_getOpenFile -parent .t -title Parent; set x 1} 286 then { 287 destroy .t 288 } 289 set x 290} {1} 291test winDialog-5.18 {GetFileName: title} {nt testwinevent} { 292# case FILE_TITLE: 293 294 start {tk_getOpenFile -title Narf} 295 then { 296 Click cancel 297 } 298} {0} 299test winDialog-5.19 {GetFileName: no filter specified} {nt testwinevent} { 300# if (ofn.lpstrFilter == NULL) 301 302 start {tk_getOpenFile -title Filter} 303 then { 304 set x [GetText 0x470] 305 Click cancel 306 } 307 set x 308} {All Files (*.*)} 309test winDialog-5.20 {GetFileName: parent HWND doesn't yet exist} {nt} { 310# if (Tk_WindowId(parent) == None) 311 312 toplevel .t 313 start {tk_getOpenFile -parent .t -title Open} 314 then { 315 destroy .t 316 } 317} {} 318test winDialog-5.21 {GetFileName: parent HWND already exists} {nt} { 319 toplevel .t 320 update 321 start {tk_getOpenFile -parent .t -title Open} 322 then { 323 destroy .t 324 } 325} {} 326test winDialog-5.22 {GetFileName: call GetOpenFileName} {nt testwinevent english} { 327# winCode = GetOpenFileName(&ofn); 328 329 start {tk_getOpenFile -title Open} 330 then { 331 set x [GetText ok] 332 Click cancel 333 } 334 set x 335} {&Open} 336test winDialog-5.23 {GetFileName: call GetSaveFileName} {nt testwinevent english} { 337# winCode = GetSaveFileName(&ofn); 338 339 start {tk_getSaveFile -title Save} 340 then { 341 set x [GetText ok] 342 Click cancel 343 } 344 set x 345} {&Save} 346if {[info exists ::env(TEMP)]} { 347test winDialog-5.24 {GetFileName: convert \ to /} {nt testwinevent} { 348 start {set x [tk_getSaveFile -title Back]} 349 then { 350 SetText 0x480 [file nativename \ 351 [file join [file normalize $::env(TEMP)] "12x 457"]] 352 Click ok 353 } 354 set x 355} [file join [file normalize $::env(TEMP)] "12x 457"] 356} 357test winDialog-5.25 {GetFileName: file types: MakeFilter() succeeds} {nt} { 358 # MacOS type that is correct, but has embedded nulls. 359 360 start {set x [catch {tk_getSaveFile -filetypes {{"foo" .foo {\0\0\0\0}}}}]} 361 then { 362 Click cancel 363 } 364 set x 365} {0} 366test winDialog-5.26 {GetFileName: file types: MakeFilter() succeeds} {nt} { 367 # MacOS type that is correct, but has embedded high-bit chars. 368 369 start {set x [catch {tk_getSaveFile -filetypes {{"foo" .foo {\u2022\u2022\u2022\u2022}}}}]} 370 then { 371 Click cancel 372 } 373 set x 374} {0} 375 376test winDialog-6.1 {MakeFilter} {emptyTest nt} {} {} 377 378test winDialog-7.1 {Tk_MessageBoxObjCmd} {emptyTest nt} {} {} 379 380test winDialog-8.1 {OFNHookProc} {emptyTest nt} {} {} 381 382## The Tk_ChooseDirectoryObjCmd hang on the static build of Windows 383## because somehow the GetOpenFileName ends up a noop in the static 384## build. 385## 386test winDialog-9.1 {Tk_ChooseDirectoryObjCmd: no arguments} {nt testwinevent} { 387 start {tk_chooseDirectory} 388 then { 389 Click cancel 390 } 391} {0} 392test winDialog-9.2 {Tk_ChooseDirectoryObjCmd: one argument} {nt} { 393 list [catch {tk_chooseDirectory -foo} msg] $msg 394} {1 {bad option "-foo": must be -initialdir, -mustexist, -parent, or -title}} 395test winDialog-9.3 {Tk_ChooseDirectoryObjCmd: many arguments} {nt testwinevent} { 396 start { 397 tk_chooseDirectory -initialdir c:/ -mustexist 1 -parent . -title test 398 } 399 then { 400 Click cancel 401 } 402} {0} 403test winDialog-9.4 {Tk_ChooseDirectoryObjCmd:\ 404 Tcl_GetIndexFromObj() != TCL_OK} {nt} { 405 list [catch {tk_chooseDirectory -foo bar -abc} msg] $msg 406} {1 {bad option "-foo": must be -initialdir, -mustexist, -parent, or -title}} 407test winDialog-9.5 {Tk_ChooseDirectoryObjCmd:\ 408 Tcl_GetIndexFromObj() == TCL_OK} {nt testwinevent} { 409 start {tk_chooseDirectory -title bar} 410 then { 411 Click cancel 412 } 413} {0} 414test winDialog-9.6 {Tk_ChooseDirectoryObjCmd:\ 415 valid option, but missing value} {nt} { 416 list [catch {tk_chooseDirectory -initialdir bar -title} msg] $msg 417} {1 {value for "-title" missing}} 418test winDialog-9.7 {Tk_ChooseDirectoryObjCmd: -initialdir} {nt testwinevent} { 419# case DIR_INITIAL: 420 421 start {set x [tk_chooseDirectory -initialdir c:/ -title Foo]} 422 then { 423 Click ok 424 } 425 string tolower [set x] 426} {c:/} 427test winDialog-9.8 {Tk_ChooseDirectoryObjCmd:\ 428 initial directory: Tcl_TranslateFilename()} {nt} { 429# if (Tcl_TranslateFileName(interp, string, 430# &utfDirString) == NULL) 431 432 list [catch {tk_chooseDirectory -initialdir ~12x/455} msg] $msg 433} {1 {user "12x" doesn't exist}} 434 435if {[testConstraint testwinevent]} { 436 catch {testwinevent debug 0} 437} 438 439# cleanup 440cleanupTests 441return 442