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