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	namespace eval bg {
27	    # Manage a background process.
28	    # Replace with slave interp or thread?
29	    namespace import ::tcltest::interpreter
30	    namespace export setup cleanup do
31
32	    proc cleanup {} {
33		variable fd
34		# catch in case the background process has closed $fd
35		catch {puts $fd exit}
36		catch {close $fd}
37		set fd ""
38	    }
39	    proc setup args {
40		variable fd
41		if {[info exists fd] && [string length $fd]} {
42		    cleanup
43		}
44		set fd [open "|[list [interpreter] \
45			-geometry +0+0 -name tktest] $args" r+]
46		puts $fd "puts foo; flush stdout"
47		flush $fd
48		if {[gets $fd data] < 0} {
49		    error "unexpected EOF from \"[interpreter]\""
50		}
51		if {$data ne "foo"} {
52		    error "unexpected output from\
53			    background process: \"$data\""
54		}
55		fileevent $fd readable [namespace code Ready]
56	    }
57	    proc Ready {} {
58		variable fd
59		variable Data
60		variable Done
61		set x [gets $fd]
62		if {[eof $fd]} {
63		    fileevent $fd readable {}
64		    set Done 1
65		} elseif {$x eq "**DONE**"} {
66		    set Done 1
67		} else {
68		    append Data $x
69		}
70	    }
71	    proc do {cmd {block 0}} {
72		variable fd
73		variable Data
74		variable Done
75		if {$block} {
76		    fileevent $fd readable {}
77		}
78		puts $fd "[list catch $cmd msg]; update; puts \$msg;\
79			puts **DONE**; flush stdout"
80		flush $fd
81		set Data {}
82		if {$block} {
83		    while {![eof $fd]} {
84			set line [gets $fd]
85			if {$line eq "**DONE**"} {
86			    break
87			}
88			append Data $line
89		    }
90		} else {
91		    set Done 0
92		    vwait [namespace which -variable Done]
93		}
94		return $Data
95	    }
96	}
97
98	proc Export {internal as external} {
99	    uplevel 1 [list namespace import $internal]
100	    uplevel 1 [list rename [namespace tail $internal] $external]
101	    uplevel 1 [list namespace export $external]
102	}
103	Export bg::setup as setupbg
104	Export bg::cleanup as cleanupbg
105	Export bg::do as dobg
106
107	namespace export deleteWindows
108	proc deleteWindows {} {
109	    eval destroy [winfo children .]
110	}
111
112	namespace export fixfocus
113	proc fixfocus {} {
114            catch {destroy .focus}
115            toplevel .focus
116            wm geometry .focus +0+0
117            entry .focus.e
118            .focus.e insert 0 "fixfocus"
119            pack .focus.e
120            update
121            focus -force .focus.e
122            destroy .focus
123	}
124    }
125}
126
127namespace import -force tk::test::*
128
129namespace import -force tcltest::testConstraint
130testConstraint notAqua [expr {[tk windowingsystem] ne "aqua"}]
131testConstraint aqua [expr {[tk windowingsystem] eq "aqua"}]
132testConstraint userInteraction 0
133testConstraint nonUnixUserInteraction [expr {[testConstraint userInteraction]
134                                                || [testConstraint unix]}]
135testConstraint altDisplay [info exists env(TK_ALT_DISPLAY)]
136testConstraint noExceed [expr {![testConstraint unix]
137			|| [catch {font actual "\{xyz"}]}]
138testConstraint testImageType [expr {[lsearch [image types] test] >= 0}]
139testConstraint testembed [llength [info commands testembed]]
140testConstraint testwrapper [llength [info commands testwrapper]]
141testConstraint testfont [llength [info commands testfont]]
142testConstraint fonts 1
143destroy .e
144entry .e -width 0 -font {Helvetica -12} -bd 1
145.e insert end a.bcd
146if {([winfo reqwidth .e] != 37) || ([winfo reqheight .e] != 20)} {
147    testConstraint fonts 0
148}
149destroy .e
150destroy .t
151text .t -width 80 -height 20 -font {Times -14} -bd 1
152pack .t
153.t insert end "This is\na dot."
154update
155set x [list [.t bbox 1.3] [.t bbox 2.5]]
156destroy .t
157if {![string match {{22 3 6 15} {31 18 [34] 15}} $x]} {
158    testConstraint fonts 0
159}
160testConstraint pseudocolor8 [expr {([catch {
161                        toplevel .t -visual {pseudocolor 8} -colormap new
162                        }] == 0) && ([winfo depth .t] == 8)}]
163destroy .t
164testConstraint haveTruecolor24 [expr {[lsearch [winfo visualsavailable .] {truecolor 24}] != -1}]
165setupbg
166set app [dobg {tk appname}]
167testConstraint secureserver 0
168if {[llength [info commands send]]} {
169    testConstraint secureserver 1
170    if {[catch {send $app set a 0} msg] == 1} {
171        if {[string match "X server insecure *" $msg]} {
172            testConstraint secureserver 0
173	}
174    }
175}
176cleanupbg
177
178eval tcltest::configure $argv
179namespace import -force tcltest::test
180
181deleteWindows
182wm geometry . {}
183raise .
184
185