# Commands covered:  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-2000 Scriptics Corporation.
# Copyright (c) 2002 ActiveState 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.13 2003/01/26 03:57:16 mdejong Exp $

package require tcltest
namespace import -force ::tcltest::*

# Require the accurate version for the tests so we don't pick up
# older Thread packages by accident
if {$::tcl_version == 8.3} {
    package require Thread 2.1.5
} else {
    package require Thread 2.5
}

set ::tcltest::testConstraints(only83)   [expr {($::tcl_version == 8.3)}]
set ::tcltest::testConstraints(notFor83) [expr {!($::tcl_version == 8.3)}]

thread::errorproc ThreadError

proc ThreadError {id info} {
    global threadError
    set threadError $info
}

proc ThreadNullError {id info} {
    # ignore
}

proc ThreadReap {} {
    thread::errorproc ThreadNullError
    while {[llength [thread::names]] > 1} {
	foreach tid [thread::names] {
	    if {$tid != $::tcltest::mainThread} {
		catch {thread::send -async $tid {thread::unwind}}
	    }
	}
	## Enter a bit of sleep to give the threads enough breathing
	## room to kill themselves off, otherwise we end up with a
	## massive queue of repeated events
	after 1
    }
    thread::errorproc ThreadError
    return [llength [thread::names]]
}

::tcltest::makeFile dummyForTransfer dummyForTransfer
set dummy  [file join $::tcltest::temporaryDirectory dummyForTransfer]

test thread-1.1.83 {thread package check} {only83} {
    package provide Thread
} {2.1.5}
test thread-1.1.84 {thread package check} {notFor83} {
    package provide Thread
} {2.5}

test thread-1.2.0 {no global thread command} {
    info commands thread
} {}

# Make sure this value is correct, now that we've loaded the test module
set tcltest::mainThread [thread::id]

test thread-1.2.83 {thread subcommands} {only83} {
    lsort [info commands thread::*]
} {::thread::cond ::thread::configure ::thread::create ::thread::errorproc ::thread::eval ::thread::exists ::thread::exit ::thread::id ::thread::mutex ::thread::names ::thread::preserve ::thread::release ::thread::send ::thread::sv_append ::thread::sv_array ::thread::sv_exists ::thread::sv_get ::thread::sv_incr ::thread::sv_lappend ::thread::sv_lindex ::thread::sv_linsert ::thread::sv_llength ::thread::sv_lock ::thread::sv_lpop ::thread::sv_lpush ::thread::sv_lrange ::thread::sv_lreplace ::thread::sv_lsearch ::thread::sv_move ::thread::sv_names ::thread::sv_object ::thread::sv_pop ::thread::sv_set ::thread::sv_unset ::thread::sv_var ::thread::unwind ::thread::wait}

test thread-1.2.84 {thread subcommands} {notFor83} {
    lsort [info commands thread::*]
} {::thread::attach ::thread::cond ::thread::configure ::thread::create ::thread::detach ::thread::errorproc ::thread::eval ::thread::exists ::thread::exit ::thread::id ::thread::join ::thread::mutex ::thread::names ::thread::preserve ::thread::release ::thread::send ::thread::sv_append ::thread::sv_array ::thread::sv_exists ::thread::sv_get ::thread::sv_incr ::thread::sv_lappend ::thread::sv_lindex ::thread::sv_linsert ::thread::sv_llength ::thread::sv_lock ::thread::sv_lpop ::thread::sv_lpush ::thread::sv_lrange ::thread::sv_lreplace ::thread::sv_lsearch ::thread::sv_move ::thread::sv_names ::thread::sv_object ::thread::sv_pop ::thread::sv_set ::thread::sv_unset ::thread::sv_var ::thread::transfer ::thread::unwind ::thread::wait}

test thread-1.3 {ThreadObjCmd: initial thread list} {
    list [ThreadReap] [llength [thread::names]]
} {1 1}

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

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

test thread-1.6 {ThreadObjCmd: thread::unwind} {
    ThreadReap
    thread::create {thread::unwind}
    update
    after 10
    set result [llength [thread::names]]
    ThreadReap
    set result
} {1}

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

test thread-1.8 {ThreadObjCmd: thread::id} {
    string compare [thread::id] $::tcltest::mainThread
} {0}

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

test thread-1.10 {ThreadObjCmd: thread::id} {
    ThreadReap
    string compare [thread::names] $::tcltest::mainThread
} {0}

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

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

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

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

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

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

test thread-1.17 {ThreadObjCmd: errorproc change} {
    thread::errorproc foo
    thread::errorproc ThreadError
} {}

test thread-1.18 {ThreadObjCmd: errorproc introspection} {
    thread::errorproc
} {ThreadError}

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

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

test thread-3.1 {Thread_List} {
    ThreadReap
    catch {unset tid}
    set len [llength [thread::names]]
    set l1  {}
    foreach t {0 1 2} {
	lappend l1 [thread::create]
    }
    set l2 [thread::names]
    list $l1 $l2
    set c [string compare \
	    [lsort -integer [concat $::tcltest::mainThread $l1]] \
	    [lsort -integer $l2]]
    ThreadReap
    list $len $c
} {1 0}

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

test thread-4.2 {Thread_Send -async} {
    ThreadReap
    set len [llength [thread::names]]
    set serverthread [thread::create]
    thread::send -async $serverthread {
	after 1000
	thread::unwind
    }
    set two [llength [thread::names]]
    after 1500 {set done 1}
    vwait done
    ThreadReap
    list $len [llength [thread::names]] $two
} {1 1 2}

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

test thread-4.4 {Thread_Send preserve code} {
    ThreadReap
    set errorInfo ""
    set len [llength [thread::names]]
    set serverthread [thread::create]
    set x [catch {thread::send $serverthread {break}} msg]
    ThreadReap
    list $len $x $msg $errorInfo
} {1 3 {} {}}

test thread-4.5 {Thread_Send preserve errorCode} {
    ThreadReap
    set ::tcltest::mainThread [thread::names]
    set serverthread [thread::create]
    set x [catch {thread::send $serverthread {error ERR INFO CODE}} msg]
    ThreadReap
    list $x $msg $errorCode
} {1 ERR CODE}

test thread-4.6 {Thread_Send negative number for thread id} {
    list [catch {thread::send -59595959 script} err] $err
} {1 {invalid thread id}}

test thread-5.0 {Joining threads} {notFor83} {
    ThreadReap
    set serverthread [thread::create -joinable]
    thread::send -async $serverthread {after 1000 ; thread::unwind}
    set res [thread::join $serverthread]
    ThreadReap
    set res
} {0}

test thread-5.1 {Joining threads after the fact} {notFor83} {
    ThreadReap
    set serverthread [thread::create -joinable]
    thread::send -async $serverthread {thread::unwind}
    after 2000
    set res [thread::join $serverthread]
    ThreadReap
    set res
} {0}

test thread-5.2 {Try to join a detached thread} {notFor83} {
    ThreadReap
    set serverthread [thread::create]
    thread::send -async $serverthread {after 1000 ; thread::unwind}
    catch {set res [thread::join $serverthread]} msg
    ThreadReap
    lrange $msg 0 2
} {cannot join thread}

test thread-6.0 {Transfer of channels, channel lists} {notFor83} {
    set server [thread::create]
    set file   [open $dummy r]

    set res [regexp $file [file channels]]

    thread::transfer $server $file

    lappend res [regexp $file [file channels]]
    lappend res [regexp $file [thread::send $server {file channels}]]
    thread::send $server "close $file"
    ThreadReap
    set res
} {1 0 1}

test thread-6.1 {Transfer of channels, target dying} {notFor83} {
    set server [thread::create]
    set file   [open $dummy r]

    thread::send -async $server {after 3000 ; thread::unwind}
    catch {thread::transfer $server $file} msg
    close $file
    set msg
} {transfer failed: target thread died}

test thread-6.2 {Transfer of channels, clearing of fileevents} {notFor83} {
    proc _HandleIt_ {} {
	global gotEvents server file

	if {$gotEvents == 0} {
	    thread::transfer $server $file
	    # From now on no events should be delivered anymore,
	    # restricting the end value to 1
	}

	incr gotEvents
    }

    set server [thread::create]
    set file   [open $dummy r]
    set gotEvents 0

    fileevent $file readable _HandleIt_
    vwait gotEvents
    thread::send $server "close $file"
    ThreadReap
    set gotEvents
} {1}

test thread-6.3 {Transfer of channels, readable?} {notFor83} {
    set server [thread::create]
    set file   [open $dummy r]
    set res [regexp $file [file channels]]

    thread::transfer $server $file
    set res [string length [thread::send $server "read -nonewline $file"]]
    thread::send $server "close $file"
    ThreadReap
    set res
} [string length [::tcltest::viewFile dummyForTransfer]]

test thread-6.4 {Transfer of channels, closeable?} {notFor83} {
    set server [thread::create]
    set file   [open $dummy r]
    set res [regexp $file [file channels]]

    thread::transfer $server $file
    set res [thread::send $server "close $file"]
    ThreadReap
    set res
} {}


# cleanup
::tcltest::cleanupTests
return