path: root/tests/thread.test

# Commands covered:  (test)thread
#
# This file contains a collection of tests for one or more of the Tcl
# built-in commands.  Sourcing this file into Tcl runs the tests and
# generates output for errors.  No output means no errors were found.
#
# Copyright (c) 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: thread.test,v 1.2 1999/04/16 00:47:35 stanton Exp $

if {[lsearch [namespace children] ::tcltest] == -1} {
    source [file join [pwd] [file dirname [info script]] defs.tcl]
}

if {[info command testthread] == ""} {
    puts "skipping: tests require the testthread command"
    ::tcltest::cleanupTests
    return
}

set mainthread [testthread names]
proc ThreadReap {} {
    global mainthread
    testthread errorproc ThreadNullError
    while {[llength [testthread names]] > 1} {
	foreach tid [testthread names] {
	    if {$tid != $mainthread} {
		catch {testthread send -async $tid {testthread exit}}
		update
	    }
	}
    }
    testthread errorproc ThreadError
    return [llength [testthread names]]
}
testthread errorproc ThreadError
proc ThreadError {id info} {
    global threadError
    set threadError $info
}
proc ThreadNullError {id info} {
    # ignore
}

test thread-1.1 {Tcl_ThreadObjCmd: no args} {
    list [catch {testthread} msg] $msg
} {1 {wrong # args: should be "testthread option ?args?"}}

test thread-1.2 {Tcl_ThreadObjCmd: bad option} {
    list [catch {testthread foo} msg] $msg
} {1 {bad option "foo": must be create, exit, id, names, send, wait, or errorproc}}

test thread-1.3 {Tcl_ThreadObjCmd: initial thread list} {
    list [catch {testthread names} mainthread] [llength $mainthread]
} {0 1}

test thread-1.4 {Tcl_ThreadObjCmd: thread create } {
    set serverthread [testthread create]
    update
    set numthreads [llength [testthread names]]
} {2}
ThreadReap

test thread-1.5 {Tcl_ThreadObjCmd: thread create one shot} {
    testthread create {set x 5}
    foreach try {0 1 2 4 5 6} {
	# Try various ways to yeild
	update
	after 10
	set l [llength [testthread names]]
	if {$l == 1} {
	    break
	}
    }
    set l
} {1}
ThreadReap

test thread-1.6 {Tcl_ThreadObjCmd: thread exit} {
    testthread create {testthread exit}
    update
    after 10
    llength [testthread names]
} {1}
ThreadReap

test thread-1.7 {Tcl_ThreadObjCmd: thread id args} {
    set x [catch {testthread id x} msg]
    list $x $msg
} {1 {wrong # args: should be "testthread id"}}

test thread-1.8 {Tcl_ThreadObjCmd: thread id} {
    string compare [testthread id] $mainthread
} {0}

test thread-1.9 {Tcl_ThreadObjCmd: thread names args} {
    set x [catch {testthread names x} msg]
    list $x $msg
} {1 {wrong # args: should be "testthread names"}}

test thread-1.10 {Tcl_ThreadObjCmd: thread id} {
    string compare [testthread names] $mainthread
} {0}

test thread-1.11 {Tcl_ThreadObjCmd: send args} {
    set x [catch {testthread send} msg]
    list $x $msg
} {1 {wrong # args: should be "testthread send ?-async? id script"}}

test thread-1.12 {Tcl_ThreadObjCmd: send nonint} {
    set x [catch {testthread send abc command} msg]
    list $x $msg
} {1 {expected integer but got "abc"}}

test thread-1.13 {Tcl_ThreadObjCmd: send args} {
    set serverthread [testthread create]
    set five [testthread send $serverthread {set x 5}]
    ThreadReap
    set five
} 5

test thread-1.14 {Tcl_ThreadObjCmd: send bad id} {
    set tid [expr $mainthread + 10]
    set x [catch {testthread send $tid {set x 5}} msg]
    list $x $msg
} {1 {invalid thread id}}

test thread-1.15 {Tcl_ThreadObjCmd: wait} {
    set serverthread [testthread create {set z 5 ; testthread wait}]
    set five [testthread send $serverthread {set z}]
    ThreadReap
    set five
} 5

test thread-1.16 {Tcl_ThreadObjCmd: errorproc args} {
    set x [catch {testthread errorproc foo bar} msg]
    list $x $msg
} {1 {wrong # args: should be "testthread errorproc proc"}}

test thread-1.17 {Tcl_ThreadObjCmd: errorproc change} {
    testthread errorproc foo
    testthread errorproc ThreadError
} {}

# The tests above also cover:
# TclCreateThread, except when pthread_create fails
# NewThread, safe and regular
# ThreadErrorProc, except for printing to standard error

test thread-2.1 {ListUpdateInner and ListRemove} {
    catch {unset tid}
    foreach t {0 1 2} {
	upvar #0 t$t tid
	set tid [testthread create]
    }
    ThreadReap
} 1

test thread-3.1 {TclThreadList} {
    catch {unset tid}
    set mainthread [testthread names]
    set l1  {}
    foreach t {0 1 2} {
	lappend l1 [testthread create]
    }
    set l2 [testthread names]
    list $l1 $l2
    set c [string compare [lsort -integer [concat $mainthread $l1]] [lsort -integer $l2]]
    ThreadReap
    set c
} 0

test thread-4.1 {TclThreadSend to self} {
    catch {unset x}
    testthread send [testthread id] {
	set x 4
    }
    set x
} {4}

test thread-4.1 {TclThreadSend -async} {
    set mainthread [testthread names]
    set serverthread [testthread create]
    testthread send -async $serverthread {
	after 1000
	testthread exit
    }
    set two [llength [testthread names]]
    after 1500 {set done 1}
    vwait done
    list [llength [testthread names]] $two
} {1 2}

test thread-4.2 {TclThreadSend preserve errorInfo} {
    set mainthread [testthread names]
    set serverthread [testthread create]
    set x [catch {testthread send $serverthread {set undef}} msg]
    list $x $msg $errorInfo
} {1 {can't read "undef": no such variable} {can't read "undef": no such variable
    while executing
"set undef"
    invoked from within
"testthread send $serverthread {set undef}"}}
ThreadReap

test thread-4.3 {TclThreadSend preserve code} {
    set mainthread [testthread names]
    set serverthread [testthread create]
    set x [catch {testthread send $serverthread {break}} msg]
    list $x $msg $errorInfo
} {3 {} {}}
ThreadReap

test thread-4.4 {TclThreadSend preserve errorCode} {
    set mainthread [testthread names]
    set serverthread [testthread create]
    set x [catch {testthread send $serverthread {error ERR INFO CODE}} msg]
    list $x $msg $errorCode
} {1 ERR CODE}
ThreadReap

# cleanup
::tcltest::cleanupTests
return