home *** CD-ROM | disk | FTP | other *** search
/ Celestin Apprentice 7 / Apprentice-Release7.iso / Source Code / C / Applications / Tcl-Tk 8.0 / Pre-installed version / tcl8.0 / tests / async.test < prev    next >
Encoding:
Text File  |  1997-08-15  |  3.6 KB  |  132 lines  |  [TEXT/ALFA]
  1. # Commands covered:  none
  2. #
  3. # This file contains a collection of tests for Tcl_AsyncCreate and related
  4. # library procedures.  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) 1993 The Regents of the University of California.
  8. # Copyright (c) 1994-1996 Sun Microsystems, Inc.
  9. #
  10. # See the file "license.terms" for information on usage and redistribution
  11. # of this file, and for a DISCLAIMER OF ALL WARRANTIES.
  12. #
  13. # SCCS: @(#) async.test 1.5 96/04/05 15:29:38
  14.  
  15. if {[info commands testasync] == {}} {
  16.     puts "This application hasn't been compiled with the \"testasync\""
  17.     puts "command, so I can't test Tcl_AsyncCreate et al."
  18.     return
  19. }
  20.  
  21. if {[string compare test [info procs test]] == 1} then {source defs}
  22.  
  23. proc async1 {result code} {
  24.     global aresult acode
  25.     set aresult $result
  26.     set acode $code
  27.     return "new result"
  28. }
  29. proc async2 {result code} {
  30.     global aresult acode
  31.     set aresult $result
  32.     set acode $code
  33.     return -code error "xyzzy"
  34. }
  35. proc async3 {result code} {
  36.     global aresult
  37.     set aresult "test pattern"
  38.     return -code $code $result
  39. }
  40.  
  41. set handler1 [testasync create async1]
  42. set handler2 [testasync create async2]
  43. set handler3 [testasync create async3]
  44. test async-1.1 {basic async handlers} {
  45.     set aresult xxx
  46.     set acode yyy
  47.     list [catch {testasync mark $handler1 "original" 0} msg] $msg \
  48.        $acode $aresult
  49. } {0 {new result} 0 original}
  50. test async-1.2 {basic async handlers} {
  51.     set aresult xxx
  52.     set acode yyy
  53.     list [catch {testasync mark $handler1 "original" 1} msg] $msg \
  54.        $acode $aresult
  55. } {0 {new result} 1 original}
  56. test async-1.3 {basic async handlers} {
  57.     set aresult xxx
  58.     set acode yyy
  59.     list [catch {testasync mark $handler2 "old" 0} msg] $msg \
  60.        $acode $aresult
  61. } {1 xyzzy 0 old}
  62. test async-1.4 {basic async handlers} {
  63.     set aresult xxx
  64.     set acode yyy
  65.     list [catch {testasync mark $handler2 "old" 3} msg] $msg \
  66.        $acode $aresult
  67. } {1 xyzzy 3 old}
  68. test async-1.5 {basic async handlers} {
  69.     set aresult xxx
  70.     list [catch {testasync mark $handler3 "foobar" 0} msg] $msg $aresult
  71. } {0 foobar {test pattern}}
  72. test async-1.6 {basic async handlers} {
  73.     set aresult xxx
  74.     list [catch {testasync mark $handler3 "foobar" 1} msg] $msg $aresult
  75. } {1 foobar {test pattern}}
  76.  
  77. proc mult1 {result code} {
  78.     global x
  79.     lappend x mult1
  80.     return -code 7 mult1
  81. }
  82. set hm1 [testasync create mult1]
  83. proc mult2 {result code} {
  84.     global x
  85.     lappend x mult2
  86.     return -code 9 mult2
  87. }
  88. set hm2 [testasync create mult2]
  89. proc mult3 {result code} {
  90.     global x hm1 hm2
  91.     lappend x [catch {testasync mark $hm2 serial2 0}]
  92.     lappend x [catch {testasync mark $hm1 serial1 0}]
  93.     lappend x mult3
  94.     return -code 11 mult3
  95. }
  96. set hm3 [testasync create mult3]
  97.  
  98. test async-2.1 {multiple handlers} {
  99.     set x {}
  100.     list [catch {testasync mark $hm3 "foobar" 5} msg] $msg $x
  101. } {9 mult2 {0 0 mult3 mult1 mult2}}
  102.  
  103. proc del1 {result code} {
  104.     global x hm1 hm2 hm3 hm4
  105.     lappend x [catch {testasync mark $hm3 serial2 0}]
  106.     lappend x [catch {testasync mark $hm1 serial1 0}]
  107.     lappend x [catch {testasync mark $hm4 serial1 0}]
  108.     testasync delete $hm1
  109.     testasync delete $hm2
  110.     testasync delete $hm3
  111.     lappend x del1
  112.     return -code 13 del1
  113. }
  114. proc del2 {result code} {
  115.     global x
  116.     lappend x del2
  117.     return -code 3 del2
  118. }
  119. testasync delete $handler1
  120. testasync delete $hm2
  121. testasync delete $hm3
  122. set hm2 [testasync create del1]
  123. set hm3 [testasync create mult2]
  124. set hm4 [testasync create del2]
  125.  
  126. test async-3.1 {deleting handlers} {
  127.     set x {}
  128.     list [catch {testasync mark $hm2 "foobar" 5} msg] $msg $x
  129. } {3 del2 {0 0 0 del1 del2}}
  130.  
  131. testasync delete
  132.