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