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