1# This file tests the tclWinDde.c file. 2# 3# This file contains a collection of tests for one or more of the Tcl 4# built-in commands. Sourcing this file into Tcl runs the tests and 5# generates output for errors. No output means no errors were found. 6# 7# Copyright © 1999 Scriptics Corporation. 8# 9# See the file "license.terms" for information on usage and redistribution 10# of this file, and for a DISCLAIMER OF ALL WARRANTIES. 11 12if {"::tcltest" ni [namespace children]} { 13 package require tcltest 2.5 14 namespace import -force ::tcltest::* 15} 16 17testConstraint debug [::tcl::pkgconfig get debug] 18testConstraint dde 0 19if {[testConstraint win]} { 20 if {![catch { 21 ::tcltest::loadTestedCommands 22 set ::ddever [package require dde 1.4.4] 23 set ::ddelib [info loaded {} Dde]}]} { 24 testConstraint dde 1 25 } 26} 27testConstraint notWine [expr {![info exists ::env(CI_USING_WINE)]}] 28 29 30# ------------------------------------------------------------------------- 31# Setup a script for a test server 32# 33 34set scriptName [makeFile {} script1.tcl] 35 36proc createChildProcess {ddeServerName args} { 37 file delete -force $::scriptName 38 39 set f [open $::scriptName w+] 40 fconfigure $f -encoding utf-8 41 puts $f [list set ddeServerName $ddeServerName] 42 puts $f [list load $::ddelib Dde] 43 puts $f { 44 # DDE child server - 45 # 46 if {"::tcltest" ni [namespace children]} { 47 package require tcltest 2.5 48 namespace import -force ::tcltest::* 49 } 50 51 # If an error occurs during the tests, this process may end up not 52 # being closed down. To deal with this we create a 30s timeout. 53 proc ::DoTimeout {} { 54 global done ddeServerName 55 set done 1 56 puts "winDde.test child process $ddeServerName timed out." 57 flush stdout 58 } 59 set timeout [after 30000 ::DoTimeout] 60 61 # Define a restricted handler. 62 proc Handler1 {cmd} { 63 if {$cmd eq "stop"} {set ::done 1} 64 if {$cmd == ""} { 65 set cmd "null data" 66 } 67 puts $cmd ; flush stdout 68 return 69 } 70 proc Handler2 {cmd} { 71 if {$cmd eq "stop"} {set ::done 1} 72 puts [uplevel \#0 $cmd] ; flush stdout 73 return 74 } 75 proc Handler3 {prefix cmd} { 76 if {$cmd eq "stop"} {set ::done 1} 77 puts [list $prefix $cmd] ; flush stdout 78 return 79 } 80 } 81 # set the dde server name to the supplied argument. 82 puts $f [list dde servername {*}$args -- $ddeServerName] 83 puts $f { 84 # run the server and handle final cleanup. 85 after 200;# give dde a chance to get going. 86 puts ready 87 flush stdout 88 vwait done 89 # allow enough time for the calling process to 90 # claim all results, to avoid spurious "server did 91 # not respond" 92 after 200 {set reallyDone 1} 93 vwait reallyDone 94 exit 95 } 96 close $f 97 98 # run the child server script. 99 set f [open |[list [interpreter] $::scriptName] r] 100 fconfigure $f -buffering line -encoding utf-8 101 gets $f line 102 return $f 103} 104 105# ------------------------------------------------------------------------- 106test winDde-1.0 {check if we are testing the right dll} {win dde} { 107 set ::ddever 108} {1.4.4} 109 110test winDde-1.1 {Settings the server's topic name} -constraints dde -body { 111 list [dde servername foobar] [dde servername] [dde servername self] 112} -result {foobar foobar self} 113 114test winDde-2.1 {Checking for other services} -constraints dde -body { 115 expr {[llength [dde services {} {}]] >= 0} 116} -result 1 117test winDde-2.2 {Checking for existence, with service and topic specified} \ 118 -constraints dde -body { 119 llength [dde services TclEval self] 120} -result 1 121test winDde-2.3 {Checking for existence, with only the service specified} \ 122 -constraints dde -body { 123 expr {[llength [dde services TclEval {}]] >= 1} 124} -result 1 125test winDde-2.4 {Checking for existence, with only the topic specified} \ 126 -constraints dde -body { 127 expr {[llength [dde services {} self]] >= 1} 128} -result 1 129 130# ------------------------------------------------------------------------- 131 132test winDde-3.1 {DDE execute locally} -constraints dde -body { 133 set \xe1 "" 134 dde execute TclEval self [list set \xe1 foo] 135 set \xe1 136} -result foo 137test winDde-3.2 {DDE execute -async locally} -constraints dde -body { 138 set \xe1 "" 139 dde execute -async TclEval self [list set \xe1 foo] 140 update 141 set \xe1 142} -result foo 143test winDde-3.3 {DDE request locally} -constraints dde -body { 144 set \xe1 "" 145 dde execute TclEval self [list set \xe1 foo] 146 dde request TclEval self \xe1 147} -result foo 148test winDde-3.4 {DDE eval locally} -constraints dde -body { 149 set \xe1 "" 150 dde eval self set \xe1 foo 151} -result foo 152test winDde-3.5 {DDE request locally} -constraints dde -body { 153 set \xe1 "" 154 dde execute TclEval self [list set \xe1 foo] 155 dde request -binary TclEval self \xe1 156} -result "foo\x00" 157# Set variable a to A with diaeresis (unicode C4) by relying on the fact 158# that utf-8 is sent (e.g. "c3 84" on the wire) 159test winDde-3.6 {DDE request utf-8} -constraints dde -body { 160 set \xe1 "not set" 161 dde execute TclEval self "set \xe1 \xc4" 162 scan [set \xe1] %c 163} -result 196 164# Set variable a to A with diaeresis (unicode C4) using binary execute 165# and compose utf-8 (e.g. "c3 84" ) manualy 166test winDde-3.7 {DDE request binary} -constraints {dde notWine} -body { 167 set \xe1 "not set" 168 dde execute -binary TclEval self [list set \xc3\xa1 \xc3\x84\x00] 169 scan [set \xe1] %c 170} -result 196 171test winDde-3.8 {DDE poke locally} -constraints {dde debug} -body { 172 set \xe1 "" 173 dde poke TclEval self \xe1 \xc4 174 dde request TclEval self \xe1 175} -result \xc4 176test winDde-3.9 {DDE poke -binary locally} -constraints {dde debug} -body { 177 set \xe1 "" 178 dde poke -binary TclEval self \xe1 \xc3\x84\x00 179 dde request TclEval self \xe1 180} -result \xc4 181 182# ------------------------------------------------------------------------- 183 184test winDde-4.1 {DDE execute remotely} -constraints {dde stdio} -body { 185 set \xe1 "" 186 set name ch\xEDld-4.1 187 set child [createChildProcess $name] 188 dde execute TclEval $name [list set \xe1 foo] 189 dde execute TclEval $name {set done 1} 190 update 191 set \xe1 192} -result "" 193test winDde-4.2 {DDE execute async remotely} -constraints {dde stdio} -body { 194 set \xe1 "" 195 set name ch\xEDld-4.2 196 set child [createChildProcess $name] 197 dde execute -async TclEval $name [list set \xe1 foo] 198 update 199 dde execute TclEval $name {set done 1} 200 update 201 set \xe1 202} -result "" 203test winDde-4.3 {DDE request remotely} -constraints {dde stdio} -body { 204 set \xe1 "" 205 set name ch\xEDld-4.3 206 set child [createChildProcess $name] 207 dde execute TclEval $name [list set \xe1 foo] 208 set \xe1 [dde request TclEval $name \xe1] 209 dde execute TclEval $name {set done 1} 210 update 211 set \xe1 212} -result foo 213test winDde-4.4 {DDE eval remotely} -constraints {dde stdio} -body { 214 set \xe1 "" 215 set name ch\xEDld-4.4 216 set child [createChildProcess $name] 217 set \xe1 [dde eval $name set \xe1 foo] 218 dde execute TclEval $name {set done 1} 219 update 220 set \xe1 221} -result foo 222test winDde-4.5 {DDE poke remotely} -constraints {dde debug stdio} -body { 223 set \xe1 "" 224 set name ch\xEDld-4.5 225 set child [createChildProcess $name] 226 dde poke TclEval $name \xe1 foo 227 set \xe1 [dde request TclEval $name \xe1] 228 dde execute TclEval $name {set done 1} 229 update 230 set \xe1 231} -result foo 232 233# ------------------------------------------------------------------------- 234 235test winDde-5.1 {check for bad arguments} -constraints dde -body { 236 dde execute "" "" "" "" 237} -returnCodes error -result {wrong # args: should be "dde execute ?-async? ?-binary? serviceName topicName value"} 238test winDde-5.2 {check for bad arguments} -constraints dde -body { 239 dde execute -binary "" "" "" 240} -returnCodes error -result {cannot execute null data} 241test winDde-5.3 {check for bad arguments} -constraints dde -body { 242 dde execute -foo "" "" "" 243} -returnCodes error -result {wrong # args: should be "dde execute ?-async? ?-binary? serviceName topicName value"} 244test winDde-5.4 {DDE eval bad arguments} -constraints dde -body { 245 dde eval "" "foo" 246} -returnCodes error -result {invalid service name ""} 247 248# ------------------------------------------------------------------------- 249 250test winDde-6.1 {DDE servername bad arguments} -constraints dde -body { 251 dde servername -z -z -z 252} -returnCodes error -result {bad option "-z": must be -force, -handler, or --} 253test winDde-6.2 {DDE servername set name} -constraints dde -body { 254 dde servername -- winDde-6.2 255} -result {winDde-6.2} 256test winDde-6.3 {DDE servername set exact name} -constraints dde -body { 257 dde servername -force winDde-6.3 258} -result {winDde-6.3} 259test winDde-6.4 {DDE servername set exact name} -constraints dde -body { 260 dde servername -force -- winDde-6.4 261} -result {winDde-6.4} 262test winDde-6.5 {DDE remote servername collision} -constraints {dde stdio} -setup { 263 set name ch\xEDld-6.5 264 set child [createChildProcess $name] 265} -body { 266 dde servername -- $name 267} -cleanup { 268 dde execute TclEval $name {set done 1} 269 update 270} -result "ch\xEDld-6.5 #2" 271test winDde-6.6 {DDE remote servername collision force} -constraints {dde stdio} -setup { 272 set name ch\xEDld-6.6 273 set child [createChildProcess $name] 274} -body { 275 dde servername -force -- $name 276} -cleanup { 277 dde execute TclEval $name {set done 1} 278 update 279} -result "ch\xEDld-6.6" 280 281# ------------------------------------------------------------------------- 282 283test winDde-7.1 {Load DDE in child interpreter} -constraints dde -setup { 284 interp create child 285} -body { 286 child eval [list load $::ddelib Dde] 287 child eval [list dde servername -- dde-interp-7.1] 288} -cleanup { 289 interp delete child 290} -result {dde-interp-7.1} 291test winDde-7.2 {DDE child cleanup} -constraints dde -setup { 292 interp create child 293 child eval [list load $::ddelib Dde] 294 child eval [list dde servername -- dde-interp-7.5] 295 interp delete child 296} -body { 297 dde services TclEval {} 298 set s [dde services TclEval {}] 299 set m [list [list TclEval dde-interp-7.5]] 300 if {$m in $s} { 301 set s 302 } 303} -result {} 304test winDde-7.3 {DDE present in child interp} -constraints dde -setup { 305 interp create child 306 child eval [list load $::ddelib Dde] 307 child eval [list dde servername -- dde-interp-7.3] 308} -body { 309 dde services TclEval dde-interp-7.3 310} -cleanup { 311 interp delete child 312} -result {{TclEval dde-interp-7.3}} 313test winDde-7.4 {interp name collision with -force} -constraints dde -setup { 314 interp create child 315 child eval [list load $::ddelib Dde] 316 child eval [list dde servername -- dde-interp-7.4] 317} -body { 318 dde servername -force -- dde-interp-7.4 319} -cleanup { 320 interp delete child 321} -result {dde-interp-7.4} 322test winDde-7.5 {interp name collision without -force} -constraints dde -setup { 323 interp create child 324 child eval [list load $::ddelib Dde] 325 child eval [list dde servername -- dde-interp-7.5] 326} -body { 327 dde servername -- dde-interp-7.5 328} -cleanup { 329 interp delete child 330} -result "dde-interp-7.5 #2" 331 332# ------------------------------------------------------------------------- 333 334test winDde-8.1 {Safe DDE load} -constraints dde -setup { 335 interp create -safe child 336 child invokehidden load $::ddelib Dde 337} -body { 338 child eval dde servername child 339} -cleanup { 340 interp delete child 341} -returnCodes error -result {invalid command name "dde"} 342test winDde-8.2 {Safe DDE set servername} -constraints dde -setup { 343 interp create -safe child 344 child invokehidden load $::ddelib Dde 345} -body { 346 child invokehidden dde servername child 347} -cleanup {interp delete child} -result {child} 348test winDde-8.3 {Safe DDE check handler required for eval} -constraints dde -setup { 349 interp create -safe child 350 child invokehidden load $::ddelib Dde 351 child invokehidden dde servername child 352} -body { 353 catch {dde eval child set a 1} msg 354} -cleanup {interp delete child} -result {1} 355test winDde-8.4 {Safe DDE check that execute is denied} -constraints dde -setup { 356 interp create -safe child 357 child invokehidden load $::ddelib Dde 358 child invokehidden dde servername child 359} -body { 360 child eval set a 1 361 dde execute TclEval child {set a 2} 362 child eval set a 363} -cleanup {interp delete child} -result 1 364test winDde-8.5 {Safe DDE check that request is denied} -constraints dde -setup { 365 interp create -safe child 366 child invokehidden load $::ddelib Dde 367 child invokehidden dde servername child 368} -body { 369 child eval set a 1 370 dde request TclEval child a 371} -cleanup { 372 interp delete child 373} -returnCodes error -result {remote server cannot handle this command} 374test winDde-8.6 {Safe DDE assign handler procedure} -constraints dde -setup { 375 interp create -safe child 376 child invokehidden load $::ddelib Dde 377 child eval {proc DDEACCEPT {cmd} {set ::DDECMD $cmd}} 378} -body { 379 child invokehidden dde servername -handler DDEACCEPT child 380} -cleanup {interp delete child} -result child 381test winDde-8.7 {Safe DDE check simple command} -constraints dde -setup { 382 interp create -safe child 383 child invokehidden load $::ddelib Dde 384 child eval {proc DDEACCEPT {cmd} {set ::DDECMD $cmd}} 385 child invokehidden dde servername -handler DDEACCEPT child 386} -body { 387 dde eval child set x 1 388} -cleanup {interp delete child} -result {set x 1} 389test winDde-8.8 {Safe DDE check non-list command} -constraints dde -setup { 390 interp create -safe child 391 child invokehidden load $::ddelib Dde 392 child eval {proc DDEACCEPT {cmd} {set ::DDECMD $cmd}} 393 child invokehidden dde servername -handler DDEACCEPT child 394} -body { 395 set s "c:\\Program Files\\Microsoft Visual Studio\\" 396 dde eval child $s 397 string equal [child eval set DDECMD] $s 398} -cleanup {interp delete child} -result 1 399test winDde-8.9 {Safe DDE check command evaluation} -constraints dde -setup { 400 interp create -safe child 401 child invokehidden load $::ddelib Dde 402 child eval {proc DDEACCEPT {cmd} {set ::DDECMD [uplevel \#0 $cmd]}} 403 child invokehidden dde servername -handler DDEACCEPT child 404} -body { 405 dde eval child set \xe1 1 406 child eval set \xe1 407} -cleanup {interp delete child} -result 1 408test winDde-8.10 {Safe DDE check command evaluation (2)} -constraints dde -setup { 409 interp create -safe child 410 child invokehidden load $::ddelib Dde 411 child eval {proc DDEACCEPT {cmd} {set ::DDECMD [uplevel \#0 $cmd]}} 412 child invokehidden dde servername -handler DDEACCEPT child 413} -body { 414 dde eval child [list set x 1] 415 child eval set x 416} -cleanup {interp delete child} -result 1 417test winDde-8.11 {Safe DDE check command evaluation (3)} -constraints dde -setup { 418 interp create -safe child 419 child invokehidden load $::ddelib Dde 420 child eval {proc DDEACCEPT {cmd} {set ::DDECMD [uplevel \#0 $cmd]}} 421 child invokehidden dde servername -handler DDEACCEPT child 422} -body { 423 dde eval child [list [list set x 1]] 424 child eval set x 425} -cleanup {interp delete child} -returnCodes error -result {invalid command name "set x 1"} 426 427# ------------------------------------------------------------------------- 428 429test winDde-9.1 {External safe DDE check string passing} -constraints {dde stdio} -setup { 430 set name ch\xEDld-9.1 431 set child [createChildProcess $name -handler Handler1] 432 file copy -force script1.tcl dde-script.tcl 433} -body { 434 dde eval $name set x 1 435 gets $child line 436 set line 437} -cleanup { 438 dde execute TclEval $name stop 439 update 440 file delete -force -- dde-script.tcl 441} -result {set x 1} 442test winDde-9.2 {External safe DDE check command evaluation} -constraints {dde stdio} -setup { 443 set name ch\xEDld-9.2 444 set child [createChildProcess $name -handler Handler2] 445 file copy -force script1.tcl dde-script.tcl 446} -body { 447 dde eval $name set x 1 448 gets $child line 449 set line 450} -cleanup { 451 dde execute TclEval $name stop 452 update 453 file delete -force -- dde-script.tcl 454} -result 1 455test winDde-9.3 {External safe DDE check prefixed arguments} -constraints {dde stdio} -setup { 456 set name ch\xEDld-9.3 457 set child [createChildProcess $name -handler [list Handler3 ARG]] 458 file copy -force script1.tcl dde-script.tcl 459} -body { 460 dde eval $name set x 1 461 gets $child line 462 set line 463} -cleanup { 464 dde execute TclEval $name stop 465 update 466 file delete -force -- dde-script.tcl 467} -result {ARG {set x 1}} 468test winDde-9.4 {External safe DDE check null data passing} -constraints {dde stdio} -setup { 469 set name ch\xEDld-9.4 470 set child [createChildProcess $name -handler Handler1] 471 file copy -force script1.tcl dde-script.tcl 472} -body { 473 dde execute TclEval $name "" 474 gets $child line 475 set line 476} -cleanup { 477 dde execute TclEval $name stop 478 update 479 file delete -force -- dde-script.tcl 480} -result {null data} 481 482# ------------------------------------------------------------------------- 483 484#cleanup 485#catch {interp delete $child}; # ensure we clean up the child. 486file delete -force $::scriptName 487::tcltest::cleanupTests 488return 489 490# Local Variables: 491# mode: tcl 492# End: 493