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