home *** CD-ROM | disk | FTP | other *** search
/ OS/2 Shareware BBS: 10 Tools / 10-Tools.zip / tcl2-73c.zip / tcl7.3 / tests / async.test < prev    next >
Text File  |  1993-08-14  |  5KB  |  146 lines
  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. # All rights reserved.
  9. #
  10. # Permission is hereby granted, without written agreement and without
  11. # license or royalty fees, to use, copy, modify, and distribute this
  12. # software and its documentation for any purpose, provided that the
  13. # above copyright notice and the following two paragraphs appear in
  14. # all copies of this software.
  15. #
  16. # IN NO EVENT SHALL THE UNIVERSITY OF CALIFORNIA BE LIABLE TO ANY PARTY FOR
  17. # DIRECT, INDIRECT, SPECIAL, INCIDENTAL, OR CONSEQUENTIAL DAMAGES ARISING OUT
  18. # OF THE USE OF THIS SOFTWARE AND ITS DOCUMENTATION, EVEN IF THE UNIVERSITY OF
  19. # CALIFORNIA HAS BEEN ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
  20. #
  21. # THE UNIVERSITY OF CALIFORNIA SPECIFICALLY DISCLAIMS ANY WARRANTIES,
  22. # INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY
  23. # AND FITNESS FOR A PARTICULAR PURPOSE.  THE SOFTWARE PROVIDED HEREUNDER IS
  24. # ON AN "AS IS" BASIS, AND THE UNIVERSITY OF CALIFORNIA HAS NO OBLIGATION TO
  25. # PROVIDE MAINTENANCE, SUPPORT, UPDATES, ENHANCEMENTS, OR MODIFICATIONS.
  26. #
  27. # $Header: /user6/ouster/tcl/tests/RCS/async.test,v 1.2 93/08/14 17:07:43 ouster Exp $ (Berkeley)
  28.  
  29. if {[info commands testasync] == {}} {
  30.     puts "This application hasn't been compiled with the \"testasync\""
  31.     puts "command, so I can't test Tcl_AsyncCreate et al."
  32.     return
  33. }
  34.  
  35. if {[string compare test [info procs test]] == 1} then {source defs}
  36.  
  37. proc async1 {result code} {
  38.     global aresult acode
  39.     set aresult $result
  40.     set acode $code
  41.     return "new result"
  42. }
  43. proc async2 {result code} {
  44.     global aresult acode
  45.     set aresult $result
  46.     set acode $code
  47.     return -code error "xyzzy"
  48. }
  49. proc async3 {result code} {
  50.     global aresult
  51.     set aresult "test pattern"
  52.     return -code $code $result
  53. }
  54.  
  55. set handler1 [testasync create async1]
  56. set handler2 [testasync create async2]
  57. set handler3 [testasync create async3]
  58. test async-1.1 {basic async handlers} {
  59.     set aresult xxx
  60.     set acode yyy
  61.     list [catch {testasync mark $handler1 "original" 0} msg] $msg \
  62.        $acode $aresult
  63. } {0 {new result} 0 original}
  64. test async-1.2 {basic async handlers} {
  65.     set aresult xxx
  66.     set acode yyy
  67.     list [catch {testasync mark $handler1 "original" 1} msg] $msg \
  68.        $acode $aresult
  69. } {0 {new result} 1 original}
  70. test async-1.3 {basic async handlers} {
  71.     set aresult xxx
  72.     set acode yyy
  73.     list [catch {testasync mark $handler2 "old" 0} msg] $msg \
  74.        $acode $aresult
  75. } {1 xyzzy 0 old}
  76. test async-1.4 {basic async handlers} {
  77.     set aresult xxx
  78.     set acode yyy
  79.     list [catch {testasync mark $handler2 "old" 3} msg] $msg \
  80.        $acode $aresult
  81. } {1 xyzzy 3 old}
  82. test async-1.5 {basic async handlers} {
  83.     set aresult xxx
  84.     list [catch {testasync mark $handler3 "foobar" 0} msg] $msg $aresult
  85. } {0 foobar {test pattern}}
  86. test async-1.6 {basic async handlers} {
  87.     set aresult xxx
  88.     list [catch {testasync mark $handler3 "foobar" 1} msg] $msg $aresult
  89. } {1 foobar {test pattern}}
  90.  
  91. proc mult1 {result code} {
  92.     global x
  93.     lappend x mult1
  94.     return -code 7 mult1
  95. }
  96. set hm1 [testasync create mult1]
  97. proc mult2 {result code} {
  98.     global x
  99.     lappend x mult2
  100.     return -code 9 mult2
  101. }
  102. set hm2 [testasync create mult2]
  103. proc mult3 {result code} {
  104.     global x hm1 hm2
  105.     lappend x [catch {testasync mark $hm2 serial2 0}]
  106.     lappend x [catch {testasync mark $hm1 serial1 0}]
  107.     lappend x mult3
  108.     return -code 11 mult3
  109. }
  110. set hm3 [testasync create mult3]
  111.  
  112. test async-2.1 {multiple handlers} {
  113.     set x {}
  114.     list [catch {testasync mark $hm3 "foobar" 5} msg] $msg $x
  115. } {9 mult2 {0 0 mult3 mult1 mult2}}
  116.  
  117. proc del1 {result code} {
  118.     global x hm1 hm2 hm3 hm4
  119.     lappend x [catch {testasync mark $hm3 serial2 0}]
  120.     lappend x [catch {testasync mark $hm1 serial1 0}]
  121.     lappend x [catch {testasync mark $hm4 serial1 0}]
  122.     testasync delete $hm1
  123.     testasync delete $hm2
  124.     testasync delete $hm3
  125.     lappend x del1
  126.     return -code 13 del1
  127. }
  128. proc del2 {result code} {
  129.     global x
  130.     lappend x del2
  131.     return -code 3 del2
  132. }
  133. testasync delete $handler1
  134. testasync delete $hm2
  135. testasync delete $hm3
  136. set hm2 [testasync create del1]
  137. set hm3 [testasync create mult2]
  138. set hm4 [testasync create del2]
  139.  
  140. test async-3.1 {deleting handlers} {
  141.     set x {}
  142.     list [catch {testasync mark $hm2 "foobar" 5} msg] $msg $x
  143. } {3 del2 {0 0 0 del1 del2}}
  144.  
  145. testasync delete
  146.