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