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