util/src/TclTk/tcl8.6.12/tests/winDde.test

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