1if {[namespace exists tk::test]} {
2    deleteWindows
3    wm geometry . {}
4    raise .
5    return
6}
7
8package require Tcl 8.4
9
10package require Tk 8.4
11tk appname tktest
12wm title . tktest
13# If the main window isn't already mapped (e.g. because the tests are
14# being run automatically) , specify a precise size for it so that the
15# user won't have to position it manually.
16
17if {![winfo ismapped .]} {
18    wm geometry . +0+0
19    update
20}
21
22package require tcltest 2.1
23
24namespace eval tk {
25    namespace eval test {
26
27	namespace export loadTkCommand
28	proc loadTkCommand {} {
29	    set tklib {}
30	    foreach pair [info loaded {}] {
31		foreach {lib pfx} $pair break
32		if {$pfx eq "Tk"} {
33		    set tklib $lib
34		    break
35		}
36	    }
37	    return [list load $tklib Tk]
38	}
39
40	namespace eval bg {
41	    # Manage a background process.
42	    # Replace with slave interp or thread?
43	    namespace import ::tcltest::interpreter
44	    namespace import ::tk::test::loadTkCommand
45	    namespace export setup cleanup do
46
47	    proc cleanup {} {
48		variable fd
49		# catch in case the background process has closed $fd
50		catch {puts $fd exit}
51		catch {close $fd}
52		set fd ""
53	    }
54	    proc setup args {
55		variable fd
56		if {[info exists fd] && [string length $fd]} {
57		    cleanup
58		}
59		set fd [open "|[list [interpreter] \
60			-geometry +0+0 -name tktest] $args" r+]
61		puts $fd "puts foo; flush stdout"
62		flush $fd
63		if {[gets $fd data] < 0} {
64		    error "unexpected EOF from \"[interpreter]\""
65		}
66		if {$data ne "foo"} {
67		    error "unexpected output from\
68			    background process: \"$data\""
69		}
70		puts $fd [loadTkCommand]
71		flush $fd
72		fileevent $fd readable [namespace code Ready]
73	    }
74	    proc Ready {} {
75		variable fd
76		variable Data
77		variable Done
78		set x [gets $fd]
79		if {[eof $fd]} {
80		    fileevent $fd readable {}
81		    set Done 1
82		} elseif {$x eq "**DONE**"} {
83		    set Done 1
84		} else {
85		    append Data $x
86		}
87	    }
88	    proc do {cmd {block 0}} {
89		variable fd
90		variable Data
91		variable Done
92		if {$block} {
93		    fileevent $fd readable {}
94		}
95		puts $fd "[list catch $cmd msg]; update; puts \$msg;\
96			puts **DONE**; flush stdout"
97		flush $fd
98		set Data {}
99		if {$block} {
100		    while {![eof $fd]} {
101			set line [gets $fd]
102			if {$line eq "**DONE**"} {
103			    break
104			}
105			append Data $line
106		    }
107		} else {
108		    set Done 0
109		    vwait [namespace which -variable Done]
110		}
111		return $Data
112	    }
113	}
114
115	proc Export {internal as external} {
116	    uplevel 1 [list namespace import $internal]
117	    uplevel 1 [list rename [namespace tail $internal] $external]
118	    uplevel 1 [list namespace export $external]
119	}
120	Export bg::setup as setupbg
121	Export bg::cleanup as cleanupbg
122	Export bg::do as dobg
123
124	namespace export deleteWindows
125	proc deleteWindows {} {
126	    eval destroy [winfo children .]
127	}
128
129	namespace export fixfocus
130	proc fixfocus {} {
131            catch {destroy .focus}
132            toplevel .focus
133            wm geometry .focus +0+0
134            entry .focus.e
135            .focus.e insert 0 "fixfocus"
136            pack .focus.e
137            update
138            focus -force .focus.e
139            destroy .focus
140	}
141    }
142}
143
144namespace import -force tk::test::*
145
146namespace import -force tcltest::testConstraint
147testConstraint notAqua [expr {[tk windowingsystem] ne "aqua"}]
148testConstraint aqua [expr {[tk windowingsystem] eq "aqua"}]
149testConstraint nonwin [expr {[tk windowingsystem] ne "win32"}]
150testConstraint userInteraction 0
151testConstraint nonUnixUserInteraction [expr {
152    [testConstraint userInteraction] ||
153    ([testConstraint unix] && [testConstraint notAqua])
154}]
155testConstraint haveDISPLAY [info exists env(DISPLAY)]
156testConstraint altDisplay  [info exists env(TK_ALT_DISPLAY)]
157testConstraint noExceed [expr {
158    ![testConstraint unix] || [catch {font actual "\{xyz"}]
159}]
160
161# constraints for testing facilities defined in the tktest executable...
162testConstraint testImageType [expr {[lsearch [image types] test] >= 0}]
163testConstraint testOldImageType [expr {[lsearch [image types] oldtest] >= 0}]
164testConstraint testbitmap    [llength [info commands testbitmap]]
165testConstraint testborder    [llength [info commands testborder]]
166testConstraint testcbind     [llength [info commands testcbind]]
167testConstraint testclipboard [llength [info commands testclipboard]]
168testConstraint testcolor     [llength [info commands testcolor]]
169testConstraint testcursor    [llength [info commands testcursor]]
170testConstraint testembed     [llength [info commands testembed]]
171testConstraint testfont      [llength [info commands testfont]]
172testConstraint testmakeexist [llength [info commands testmakeexist]]
173testConstraint testmenubar   [llength [info commands testmenubar]]
174testConstraint testmenubar   [llength [info commands testmenubar]]
175testConstraint testmetrics   [llength [info commands testmetrics]]
176testConstraint testobjconfig [llength [info commands testobjconfig]]
177testConstraint testsend      [llength [info commands testsend]]
178testConstraint testtext      [llength [info commands testtext]]
179testConstraint testwinevent  [llength [info commands testwinevent]]
180testConstraint testwrapper   [llength [info commands testwrapper]]
181
182# constraint to see what sort of fonts are available
183testConstraint fonts 1
184destroy .e
185entry .e -width 0 -font {Helvetica -12} -bd 1
186.e insert end a.bcd
187if {([winfo reqwidth .e] != 37) || ([winfo reqheight .e] != 20)} {
188    testConstraint fonts 0
189}
190destroy .e
191destroy .t
192text .t -width 80 -height 20 -font {Times -14} -bd 1
193pack .t
194.t insert end "This is\na dot."
195update
196set x [list [.t bbox 1.3] [.t bbox 2.5]]
197destroy .t
198if {![string match {{22 3 6 15} {31 18 [34] 15}} $x]} {
199    testConstraint fonts 0
200}
201testConstraint textfonts [expr {
202    [testConstraint fonts] || $tcl_platform(platform) eq "windows"
203}]
204
205# constraints for the visuals available..
206testConstraint pseudocolor8 [expr {
207    ([catch {
208	toplevel .t -visual {pseudocolor 8} -colormap new
209    }] == 0) && ([winfo depth .t] == 8)
210}]
211destroy .t
212testConstraint haveTruecolor24 [expr {
213    [lsearch -exact [winfo visualsavailable .] {truecolor 24}] >= 0
214}]
215testConstraint haveGrayscale8 [expr {
216    [lsearch -exact [winfo visualsavailable .] {grayscale 8}] >= 0
217}]
218testConstraint defaultPseudocolor8 [expr {
219    ([winfo visual .] eq "pseudocolor") && ([winfo depth .] == 8)
220}]
221
222# constraint based on whether our display is secure
223setupbg
224set app [dobg {tk appname}]
225testConstraint secureserver 0
226if {[llength [info commands send]]} {
227    testConstraint secureserver 1
228    if {[catch {send $app set a 0} msg] == 1} {
229        if {[string match "X server insecure *" $msg]} {
230            testConstraint secureserver 0
231	}
232    }
233}
234cleanupbg
235
236eval tcltest::configure $argv
237namespace import -force tcltest::test
238namespace import -force tcltest::makeFile
239namespace import -force tcltest::removeFile
240namespace import -force tcltest::makeDirectory
241namespace import -force tcltest::removeDirectory
242namespace import -force tcltest::interpreter
243namespace import -force tcltest::testsDirectory
244namespace import -force tcltest::cleanupTests
245namespace import -force tcltest::bytestring
246
247deleteWindows
248wm geometry . {}
249raise .
250
251