os/persistentdata/persistentstorage/sqlite3api/TEST/TCL/tcldistribution/tests/async.test
1.1 --- /dev/null Thu Jan 01 00:00:00 1970 +0000
1.2 +++ b/os/persistentdata/persistentstorage/sqlite3api/TEST/TCL/tcldistribution/tests/async.test Fri Jun 15 03:10:57 2012 +0200
1.3 @@ -0,0 +1,151 @@
1.4 +# Commands covered: none
1.5 +#
1.6 +# This file contains a collection of tests for Tcl_AsyncCreate and related
1.7 +# library procedures. Sourcing this file into Tcl runs the tests and
1.8 +# generates output for errors. No output means no errors were found.
1.9 +#
1.10 +# Copyright (c) 1993 The Regents of the University of California.
1.11 +# Copyright (c) 1994-1996 Sun Microsystems, Inc.
1.12 +# Copyright (c) 1998-1999 by Scriptics Corporation.
1.13 +#
1.14 +# See the file "license.terms" for information on usage and redistribution
1.15 +# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
1.16 +#
1.17 +# RCS: @(#) $Id: async.test,v 1.5 2000/04/10 17:18:56 ericm Exp $
1.18 +
1.19 +if {[lsearch [namespace children] ::tcltest] == -1} {
1.20 + package require tcltest
1.21 + namespace import -force ::tcltest::*
1.22 +}
1.23 +
1.24 +if {[info commands testasync] == {}} {
1.25 + puts "This application hasn't been compiled with the \"testasync\""
1.26 + puts "command, so I can't test Tcl_AsyncCreate et al."
1.27 + ::tcltest::cleanupTests
1.28 + return
1.29 +}
1.30 +
1.31 +proc async1 {result code} {
1.32 + global aresult acode
1.33 + set aresult $result
1.34 + set acode $code
1.35 + return "new result"
1.36 +}
1.37 +proc async2 {result code} {
1.38 + global aresult acode
1.39 + set aresult $result
1.40 + set acode $code
1.41 + return -code error "xyzzy"
1.42 +}
1.43 +proc async3 {result code} {
1.44 + global aresult
1.45 + set aresult "test pattern"
1.46 + return -code $code $result
1.47 +}
1.48 +
1.49 +set handler1 [testasync create async1]
1.50 +set handler2 [testasync create async2]
1.51 +set handler3 [testasync create async3]
1.52 +test async-1.1 {basic async handlers} {
1.53 + set aresult xxx
1.54 + set acode yyy
1.55 + list [catch {testasync mark $handler1 "original" 0} msg] $msg \
1.56 + $acode $aresult
1.57 +} {0 {new result} 0 original}
1.58 +test async-1.2 {basic async handlers} {
1.59 + set aresult xxx
1.60 + set acode yyy
1.61 + list [catch {testasync mark $handler1 "original" 1} msg] $msg \
1.62 + $acode $aresult
1.63 +} {0 {new result} 1 original}
1.64 +test async-1.3 {basic async handlers} {
1.65 + set aresult xxx
1.66 + set acode yyy
1.67 + list [catch {testasync mark $handler2 "old" 0} msg] $msg \
1.68 + $acode $aresult
1.69 +} {1 xyzzy 0 old}
1.70 +test async-1.4 {basic async handlers} {
1.71 + set aresult xxx
1.72 + set acode yyy
1.73 + list [catch {testasync mark $handler2 "old" 3} msg] $msg \
1.74 + $acode $aresult
1.75 +} {1 xyzzy 3 old}
1.76 +test async-1.5 {basic async handlers} {
1.77 + set aresult xxx
1.78 + list [catch {testasync mark $handler3 "foobar" 0} msg] $msg $aresult
1.79 +} {0 foobar {test pattern}}
1.80 +test async-1.6 {basic async handlers} {
1.81 + set aresult xxx
1.82 + list [catch {testasync mark $handler3 "foobar" 1} msg] $msg $aresult
1.83 +} {1 foobar {test pattern}}
1.84 +
1.85 +proc mult1 {result code} {
1.86 + global x
1.87 + lappend x mult1
1.88 + return -code 7 mult1
1.89 +}
1.90 +set hm1 [testasync create mult1]
1.91 +proc mult2 {result code} {
1.92 + global x
1.93 + lappend x mult2
1.94 + return -code 9 mult2
1.95 +}
1.96 +set hm2 [testasync create mult2]
1.97 +proc mult3 {result code} {
1.98 + global x hm1 hm2
1.99 + lappend x [catch {testasync mark $hm2 serial2 0}]
1.100 + lappend x [catch {testasync mark $hm1 serial1 0}]
1.101 + lappend x mult3
1.102 + return -code 11 mult3
1.103 +}
1.104 +set hm3 [testasync create mult3]
1.105 +
1.106 +test async-2.1 {multiple handlers} {
1.107 + set x {}
1.108 + list [catch {testasync mark $hm3 "foobar" 5} msg] $msg $x
1.109 +} {9 mult2 {0 0 mult3 mult1 mult2}}
1.110 +
1.111 +proc del1 {result code} {
1.112 + global x hm1 hm2 hm3 hm4
1.113 + lappend x [catch {testasync mark $hm3 serial2 0}]
1.114 + lappend x [catch {testasync mark $hm1 serial1 0}]
1.115 + lappend x [catch {testasync mark $hm4 serial1 0}]
1.116 + testasync delete $hm1
1.117 + testasync delete $hm2
1.118 + testasync delete $hm3
1.119 + lappend x del1
1.120 + return -code 13 del1
1.121 +}
1.122 +proc del2 {result code} {
1.123 + global x
1.124 + lappend x del2
1.125 + return -code 3 del2
1.126 +}
1.127 +testasync delete $handler1
1.128 +testasync delete $hm2
1.129 +testasync delete $hm3
1.130 +set hm2 [testasync create del1]
1.131 +set hm3 [testasync create mult2]
1.132 +set hm4 [testasync create del2]
1.133 +
1.134 +test async-3.1 {deleting handlers} {
1.135 + set x {}
1.136 + list [catch {testasync mark $hm2 "foobar" 5} msg] $msg $x
1.137 +} {3 del2 {0 0 0 del1 del2}}
1.138 +
1.139 +# cleanup
1.140 +testasync delete
1.141 +::tcltest::cleanupTests
1.142 +return
1.143 +
1.144 +
1.145 +
1.146 +
1.147 +
1.148 +
1.149 +
1.150 +
1.151 +
1.152 +
1.153 +
1.154 +