sl@0: # Commands covered:  none
sl@0: #
sl@0: # This file contains a collection of tests for Tcl_AsyncCreate and related
sl@0: # library procedures.  Sourcing this file into Tcl runs the tests and
sl@0: # generates output for errors.  No output means no errors were found.
sl@0: #
sl@0: # Copyright (c) 1993 The Regents of the University of California.
sl@0: # Copyright (c) 1994-1996 Sun Microsystems, Inc.
sl@0: # Copyright (c) 1998-1999 by Scriptics Corporation.
sl@0: #
sl@0: # See the file "license.terms" for information on usage and redistribution
sl@0: # of this file, and for a DISCLAIMER OF ALL WARRANTIES.
sl@0: #
sl@0: # RCS: @(#) $Id: async.test,v 1.5 2000/04/10 17:18:56 ericm Exp $
sl@0: 
sl@0: if {[lsearch [namespace children] ::tcltest] == -1} {
sl@0:     package require tcltest
sl@0:     namespace import -force ::tcltest::*
sl@0: }
sl@0: 
sl@0: if {[info commands testasync] == {}} {
sl@0:     puts "This application hasn't been compiled with the \"testasync\""
sl@0:     puts "command, so I can't test Tcl_AsyncCreate et al."
sl@0:     ::tcltest::cleanupTests
sl@0:     return
sl@0: }
sl@0: 
sl@0: proc async1 {result code} {
sl@0:     global aresult acode
sl@0:     set aresult $result
sl@0:     set acode $code
sl@0:     return "new result"
sl@0: }
sl@0: proc async2 {result code} {
sl@0:     global aresult acode
sl@0:     set aresult $result
sl@0:     set acode $code
sl@0:     return -code error "xyzzy"
sl@0: }
sl@0: proc async3 {result code} {
sl@0:     global aresult
sl@0:     set aresult "test pattern"
sl@0:     return -code $code $result
sl@0: }
sl@0: 
sl@0: set handler1 [testasync create async1]
sl@0: set handler2 [testasync create async2]
sl@0: set handler3 [testasync create async3]
sl@0: test async-1.1 {basic async handlers} {
sl@0:     set aresult xxx
sl@0:     set acode yyy
sl@0:     list [catch {testasync mark $handler1 "original" 0} msg] $msg \
sl@0: 	   $acode $aresult
sl@0: } {0 {new result} 0 original}
sl@0: test async-1.2 {basic async handlers} {
sl@0:     set aresult xxx
sl@0:     set acode yyy
sl@0:     list [catch {testasync mark $handler1 "original" 1} msg] $msg \
sl@0: 	   $acode $aresult
sl@0: } {0 {new result} 1 original}
sl@0: test async-1.3 {basic async handlers} {
sl@0:     set aresult xxx
sl@0:     set acode yyy
sl@0:     list [catch {testasync mark $handler2 "old" 0} msg] $msg \
sl@0: 	   $acode $aresult
sl@0: } {1 xyzzy 0 old}
sl@0: test async-1.4 {basic async handlers} {
sl@0:     set aresult xxx
sl@0:     set acode yyy
sl@0:     list [catch {testasync mark $handler2 "old" 3} msg] $msg \
sl@0: 	   $acode $aresult
sl@0: } {1 xyzzy 3 old}
sl@0: test async-1.5 {basic async handlers} {
sl@0:     set aresult xxx
sl@0:     list [catch {testasync mark $handler3 "foobar" 0} msg] $msg $aresult
sl@0: } {0 foobar {test pattern}}
sl@0: test async-1.6 {basic async handlers} {
sl@0:     set aresult xxx
sl@0:     list [catch {testasync mark $handler3 "foobar" 1} msg] $msg $aresult
sl@0: } {1 foobar {test pattern}}
sl@0: 
sl@0: proc mult1 {result code} {
sl@0:     global x
sl@0:     lappend x mult1
sl@0:     return -code 7 mult1
sl@0: }
sl@0: set hm1 [testasync create mult1]
sl@0: proc mult2 {result code} {
sl@0:     global x
sl@0:     lappend x mult2
sl@0:     return -code 9 mult2
sl@0: }
sl@0: set hm2 [testasync create mult2]
sl@0: proc mult3 {result code} {
sl@0:     global x hm1 hm2
sl@0:     lappend x [catch {testasync mark $hm2 serial2 0}]
sl@0:     lappend x [catch {testasync mark $hm1 serial1 0}]
sl@0:     lappend x mult3
sl@0:     return -code 11 mult3
sl@0: }
sl@0: set hm3 [testasync create mult3]
sl@0: 
sl@0: test async-2.1 {multiple handlers} {
sl@0:     set x {}
sl@0:     list [catch {testasync mark $hm3 "foobar" 5} msg] $msg $x
sl@0: } {9 mult2 {0 0 mult3 mult1 mult2}}
sl@0: 
sl@0: proc del1 {result code} {
sl@0:     global x hm1 hm2 hm3 hm4
sl@0:     lappend x [catch {testasync mark $hm3 serial2 0}]
sl@0:     lappend x [catch {testasync mark $hm1 serial1 0}]
sl@0:     lappend x [catch {testasync mark $hm4 serial1 0}]
sl@0:     testasync delete $hm1
sl@0:     testasync delete $hm2
sl@0:     testasync delete $hm3
sl@0:     lappend x del1
sl@0:     return -code 13 del1
sl@0: }
sl@0: proc del2 {result code} {
sl@0:     global x
sl@0:     lappend x del2
sl@0:     return -code 3 del2
sl@0: }
sl@0: testasync delete $handler1
sl@0: testasync delete $hm2
sl@0: testasync delete $hm3
sl@0: set hm2 [testasync create del1]
sl@0: set hm3 [testasync create mult2]
sl@0: set hm4 [testasync create del2]
sl@0: 
sl@0: test async-3.1 {deleting handlers} {
sl@0:     set x {}
sl@0:     list [catch {testasync mark $hm2 "foobar" 5} msg] $msg $x
sl@0: } {3 del2 {0 0 0 del1 del2}}
sl@0: 
sl@0: # cleanup
sl@0: testasync delete
sl@0: ::tcltest::cleanupTests
sl@0: return
sl@0: 
sl@0: 
sl@0: 
sl@0: 
sl@0: 
sl@0: 
sl@0: 
sl@0: 
sl@0: 
sl@0: 
sl@0: 
sl@0: