summaryrefslogtreecommitdiffstats
path: root/library/tcltest/tcltest.tcl
diff options
context:
space:
mode:
authorwelch <welch>2000-04-11 01:04:19 (GMT)
committerwelch <welch>2000-04-11 01:04:19 (GMT)
commit4b9e527208cf58f3cd5f3d0e7d7b3b2afc435441 (patch)
treed3b5748e4a573d7fd7ba2598ce8e56527538c66d /library/tcltest/tcltest.tcl
parentf29f165ad5d35de6c987e53405b7157ada93f497 (diff)
downloadtcl-4b9e527208cf58f3cd5f3d0e7d7b3b2afc435441.zip
tcl-4b9e527208cf58f3cd5f3d0e7d7b3b2afc435441.tar.gz
tcl-4b9e527208cf58f3cd5f3d0e7d7b3b2afc435441.tar.bz2
Updated to work with thread extension, if present
Diffstat (limited to 'library/tcltest/tcltest.tcl')
-rw-r--r--library/tcltest/tcltest.tcl29
1 files changed, 26 insertions, 3 deletions
diff --git a/library/tcltest/tcltest.tcl b/library/tcltest/tcltest.tcl
index b3188a8..5898cf6 100644
--- a/library/tcltest/tcltest.tcl
+++ b/library/tcltest/tcltest.tcl
@@ -12,7 +12,7 @@
# Copyright (c) 1998-1999 by Scriptics Corporation.
# All rights reserved.
#
-# RCS: @(#) $Id: tcltest.tcl,v 1.23 2000/04/08 02:35:24 hobbs Exp $
+# RCS: @(#) $Id: tcltest.tcl,v 1.24 2000/04/11 01:04:19 welch Exp $
package provide tcltest 1.0
@@ -170,8 +170,10 @@ namespace eval tcltest {
if {![info exists mainThread]} {
variable mainThread 1
- if {[info commands testthread] != {}} {
- set mainThread [testthread names]
+ if {[info commands thread::id] != {}} {
+ set mainThread [thread::id]
+ } elseif {[info commands testthread] != {}} {
+ set mainThread [testthread id]
}
}
@@ -1851,6 +1853,9 @@ proc ::tcltest::restore_locale {} {
# Returns the number of existing threads.
proc ::tcltest::threadReap {} {
if {[info commands testthread] != {}} {
+
+ # testthread built into tcltest
+
testthread errorproc ThreadNullError
while {[llength [testthread names]] > 1} {
foreach tid [testthread names] {
@@ -1865,6 +1870,24 @@ proc ::tcltest::threadReap {} {
}
testthread errorproc ThreadError
return [llength [testthread names]]
+ } elseif {[info commands thread::id] != {}} {
+
+ # Thread extension
+
+ thread::errorproc ThreadNullError
+ while {[llength [thread::names]] > 1} {
+ foreach tid [thread::names] {
+ if {$tid != $::tcltest::mainThread} {
+ catch {thread::send -async $tid {thread::exit}}
+ }
+ }
+ ## Enter a bit a sleep to give the threads enough breathing
+ ## room to kill themselves off, otherwise the end up with a
+ ## massive queue of repeated events
+ after 1
+ }
+ thread::errorproc ThreadError
+ return [llength [thread::names]]
} else {
return 1
}