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