Tcl Source Code

# of this file, and for a DISCLAIMER OF ALL WARRANTIES.

if {"::tcltest" ni [namespace children]} {
    package require tcltest 2.5
    namespace import -force ::tcltest::*
}

testConstraint noappverifier [expr {
        [llength [info commands testappverifierpresent]] == 0
        || ![testappverifierpresent]}]

test exit-1.1 {normal, quick exit} -constraints noappverifier -body {
    set f [open "|[interpreter] << \"exec [interpreter] << {set ::env(TCL_FINALIZE_ON_EXIT) 0;exit}\"" r]
    set aft [after 1000 {set done "Quick exit hangs !!!"}]
    fileevent $f readable {after cancel $aft;set done OK}
    vwait done
    if {$done != "OK"} {
	fconfigure $f -blocking 0
	close $f
    } else {
	if {[catch {close $f} err]} {
	    set done "Quick exit misbehaves: $err"
	}
    }
    set done
} -result OK

test exit-1.2 {full-finalized exit} -constraints noappverifier -body {
    set f [open "|[interpreter] << \"exec [interpreter] << {set ::env(TCL_FINALIZE_ON_EXIT) 1;exit}\"" r]
    set aft [after 1000 {set done "Full-finalized exit hangs !!!"}]
    fileevent $f readable {after cancel $aft;set done OK}
    vwait done
    if {$done != "OK"} {
	fconfigure $f -blocking 0
	close $f
    } else {
	if {[catch {close $f} err]} {
	    set done "Full-finalized exit misbehaves: $err"
	}
    }
    set done
} -result OK


# cleanup
::tcltest::cleanupTests
return

# this file, and for a DISCLAIMER OF ALL WARRANTIES.

if {"::tcltest" ni [namespace children]} {
    package require tcltest 2.5
    namespace import -force ::tcltest::*
}

testConstraint noappverifier [expr {
        [llength [info commands testappverifierpresent]] == 0
        || ![testappverifierpresent]}]

namespace eval ::tcl::test::io {

    if {"::tcltest" ni [namespace children]} {
	package require tcltest 2.5
	namespace import -force ::tcltest::*
    }

    list [chan gets $f line] $line [chan gets $f line] $line [chan gets $f line] $line
} -cleanup {
    chan close $f
} -result [list 8 "there一ok" 11 "丁more bytes" 4 "here"]
test chan-io-6.56 {Tcl_GetsObj: incomplete lines should disable file events} -setup {
    update
    variable x {}
} -constraints {stdio fileevent noappverifier} -body {
    set f [openpipe w+ $path(cat)]
    chan configure $f -buffering none
    chan puts -nonewline $f "foobar"
    chan configure $f -blocking 0
    after 500 [namespace code {
	lappend x timeout
    }]

    chan read $f
} -cleanup {
    chan close $f
} -result "abcd\ndef\nfgh"
test chan-io-13.6 {TranslateInputEOL: auto mode: saw cr in last segment} -setup {
    variable x {}
    variable y {}
} -constraints {stdio testchannel fileevent noappverifier} -body {
    # (chanPtr->flags & INPUT_SAW_CR)
    # This test may fail on slower machines.
    set f [openpipe w+ $path(cat)]
    chan configure $f -blocking 0 -buffering none -translation {auto lf}
    chan event $f read [namespace code {
	lappend x [chan read $f] [testchannel queuedcr $f]
    }]

    set cat [makeFile {
	fconfigure stdout -buffering line
	while {[gets stdin line] >= 0} {puts $line}
	puts DONE
	exit 0
    } cat.tcl]
    variable done
} -constraints noappverifier -body {
    set ff [openpipe r+ $cat]
    puts $ff Hey
    close $ff w
    set timer [after 1000 [namespace code {set done Failed}]]
    set acc {}
    fileevent $ff readable [namespace code {
	if {[gets $ff line] < 0} {

    if {[catch {
	    ::tcltest::loadTestedCommands
	}]} {
	# nothing to be done (registry loaded on demand)
    }
}

# Application Verifier hooks system calls in a way that locale
# detection fails. Disable tests that depend on that if
# it is running.
testConstraint noappverifier [expr {
        [llength [info commands testappverifierpresent]] == 0
        || ![testappverifierpresent]}]

package require msgcat 1.4

testConstraint detroit \
    [expr {![catch {clock format 0 -timezone :America/Detroit -format %z}]}]
testConstraint y2038 \
    [expr {[clock format 2158894800 -format %z -timezone :America/Detroit] eq {-0400}}]

    rename test_add_dst {}
} -result {}

# END testcases30


test clock-31.1 {system locale} \
    -constraints {win noappverifier} \
    -setup {
	namespace eval ::tcl::clock {
	    namespace import -force ::testClock::registry
	}
	set noreg [info exists ::tcl::clock::NoRegistry]
	if {$noreg} {unset ::tcl::clock::NoRegistry}
	::tcl::clock::ClearCaches

	if {$noreg} {set ::tcl::clock::NoRegistry {}}
	::tcl::clock::ClearCaches
    } \
    -result [clock format 0 -timezone :UTC -locale current \
		 -format {%d-%b-%Y}]

test clock-31.2 {system locale} \
    -constraints {win noappverifier} \
    -setup {
	namespace eval ::tcl::clock {
	    namespace import -force ::testClock::registry
	}
	set noreg [info exists ::tcl::clock::NoRegistry]
	if {$noreg} {unset ::tcl::clock::NoRegistry}
	::tcl::clock::ClearCaches

	if {$noreg} {set ::tcl::clock::NoRegistry {}}
	::tcl::clock::ClearCaches
    } \
    -result [clock format 0 -timezone :UTC -locale current \
		 -format {the %d' day of %B %Y}]

test clock-31.3 {system locale} \
    -constraints {win noappverifier} \
    -setup {
	namespace eval ::tcl::clock {
	    namespace import -force ::testClock::registry
	}
	set noreg [info exists ::tcl::clock::NoRegistry]
	if {$noreg} {unset ::tcl::clock::NoRegistry}
	::tcl::clock::ClearCaches

	if {$noreg} {set ::tcl::clock::NoRegistry {}}
	::tcl::clock::ClearCaches
    } \
    -result [clock format 0 -timezone :UTC -locale current \
		 -format {%l:%M:%S %p}]

test clock-31.4 {system locale} \
    -constraints {win noappverifier} \
    -setup {
	namespace eval ::tcl::clock {
	    namespace import -force ::testClock::registry
	}
	set noreg [info exists ::tcl::clock::NoRegistry]
	if {$noreg} {unset ::tcl::clock::NoRegistry}
	if { [info exists env(TZ)] } {

	if {$noreg} {set ::tcl::clock::NoRegistry {}}
	::tcl::clock::ClearCaches
    } \
    -result [clock format 0 -locale current -timezone EST5 \
		 -format {%d-%b-%Y}]

test clock-31.5 {system locale} \
    -constraints {win noappverifier} \
    -setup {
	namespace eval ::tcl::clock {
	    namespace import -force ::testClock::registry
	}
	set noreg [info exists ::tcl::clock::NoRegistry]
	if {$noreg} {unset ::tcl::clock::NoRegistry}
	if { [info exists env(TZ)] } {

	}
	::tcl::clock::ClearCaches
    } \
    -result [clock format 0 -locale current -timezone EST5 \
		 -format {the %d' day of %B %Y}]

test clock-31.6 {system locale} \
    -constraints {win noappverifier} \
    -setup {
	namespace eval ::tcl::clock {
	    namespace import -force ::testClock::registry
	}
	set noreg [info exists ::tcl::clock::NoRegistry]
	if {$noreg} {unset ::tcl::clock::NoRegistry}
	if { [info exists env(TZ)] } {

	    clock format -86400 -timezone :localtime -format %Y
	} result] $result
    } \
    -match regexp \
    -result {0 1969|1 {localtime failed \(clock value may be too large/small to represent\)}}

test clock-49.2 {regression test - missing time zone file (Bug 1237907)} \
    -constraints {win noappverifier} \
    -setup {
	# override the registry so that the test takes place in New York time
	namespace eval ::tcl::clock {
	    namespace import -force ::testClock::registry
	}
	set noreg [info exists ::tcl::clock::NoRegistry]
	if {$noreg} {unset ::tcl::clock::NoRegistry}

# this file, and for a DISCLAIMER OF ALL WARRANTIES.

if {"::tcltest" ni [namespace children]} {
    package require tcltest 2.5
    namespace import -force ::tcltest::*
}

testConstraint noappverifier [expr {
        [llength [info commands testappverifierpresent]] == 0
        || ![testappverifierpresent]}]

namespace eval ::tcl::test::cmdMZ {
    namespace import ::tcltest::cleanupTests
    namespace import ::tcltest::customMatch
    namespace import ::tcltest::makeFile
    namespace import ::tcltest::removeFile
    namespace import ::tcltest::temporaryDirectory
    namespace import ::tcltest::testConstraint

} {1 {missing close-brace}}
test cmdMZ-6.5a {Tcl_TimeRateObjCmd: result format and one iteration} {
    regexp {^\d+(?:\.\d+)? \ws/# 1 # \d+(?:\.\d+)? #/sec \d+(?:\.\d+)? net-ms$} [timerate {} 0]
} 1
test cmdMZ-6.5b {Tcl_TimeRateObjCmd: result format without iterations} {
    regexp {^0 \ws/# 0 # 0 #/sec 0 net-ms$} [timerate {} 0 0]
} 1
test cmdMZ-6.6 {
    Tcl_TimeRateObjCmd: slower commands take longer, but it
    remains almost the same time of measurement
} -constraints noappverifier -body {
    set m1 [timerate {_nrt_sleep 0.01} 50]
    set m2 [timerate {_nrt_sleep 1.00} 50]
    if {[testConstraint valgrind] && ([lindex $m1 0] >= 100 || [lindex $m1 2] <= 500)} {
	tcltest::Skip "too-slow-by-valgrind"
    }
    list [list \
	[expr {[lindex $m1 0] < [lindex $m2 0]}] \

proc cleanup1 {} {
    encodingrestore
    envrestore
}

# OANOCACHE comes from Application Verifier
variable keep {
    TCL_LIBRARY PATH LD_LIBRARY_PATH LIBPATH PURE_PROG_NAME DISPLAY
    SHLIB_PATH SYSTEMDRIVE SYSTEMROOT DYLD_LIBRARY_PATH DYLD_FRAMEWORK_PATH
    DYLD_NEW_LOCAL_SHARED_REGIONS DYLD_NO_FIX_PREBINDING MSYSTEM
    __CF_USER_TEXT_ENCODING SECURITYSESSIONID LANG WINDIR TERM
    CommonProgramFiles CommonProgramFiles(x86) OANOCACHE ProgramFiles
    ProgramFiles(x86) CommonProgramW6432 ProgramW6432
    PROCESSOR_ARCHITECTURE PROCESSOR_ARCHITEW6432 USERPROFILE
    WINECONFIGDIR WINEDATADIR WINEDLLDIR0 WINEHOMEDIR
    WINELOADER WINEUSERLOCALE WINEUSERNAME
}

variable printenvScript [makeFile [string map [list @keep@ [list $keep]] {

typedef struct TclPipeThreadInfo {
    HANDLE evControl;		/* Auto-reset event used by the main thread to
				 * signal when the pipe thread should attempt
				 * to do read/write operation. Additionally
				 * used as signal to stop (state set to -1) */
    volatile LONG state;	/* Indicates current state of the thread */
    void *clientData;		/* Referenced data of the main thread */

} TclPipeThreadInfo;

/* If pipe-workers will use some tcl subsystem, we can use Tcl_Alloc without
 * more overhead for finalize thread (should be executed anyway)
 *
 * #define _PTI_USE_CKALLOC 1
 */

    PTI_STATE_STOP = 2,		/* thread should stop work (owns TI structure) */
    PTI_STATE_END = 4,		/* thread should stop work (worker is busy) */
    PTI_STATE_DOWN = 8		/* worker is down */
};

MODULE_SCOPE
TclPipeThreadInfo *	TclPipeThreadCreateTI(TclPipeThreadInfo **pipeTIPtr,
			    void *clientData);
MODULE_SCOPE int	TclPipeThreadWaitForSignal(
			    TclPipeThreadInfo **pipeTIPtr);

static inline void
TclPipeThreadSignal(
    TclPipeThreadInfo **pipeTIPtr)
{

    if (readFile != NULL) {
	/*
	 * Start the background reader thread.
	 */

	infoPtr->readable = CreateEventW(NULL, TRUE, TRUE, NULL);
	infoPtr->readThread = CreateThread(NULL, 256, PipeReaderThread,
	    TclPipeThreadCreateTI(&infoPtr->readTI, infoPtr), 0, NULL);

	SetThreadPriority(infoPtr->readThread, THREAD_PRIORITY_HIGHEST);
	infoPtr->validMask |= TCL_READABLE;
    } else {
	infoPtr->readTI = NULL;
	infoPtr->readThread = 0;
    }
    if (writeFile != NULL) {
	/*
	 * Start the background writer thread.
	 */

	infoPtr->writable = CreateEventW(NULL, TRUE, TRUE, NULL);
	infoPtr->writeThread = CreateThread(NULL, 256, PipeWriterThread,
	    TclPipeThreadCreateTI(&infoPtr->writeTI, infoPtr), 0, NULL);

	SetThreadPriority(infoPtr->writeThread, THREAD_PRIORITY_HIGHEST);
	infoPtr->validMask |= TCL_WRITABLE;
    } else {
	infoPtr->writeTI = NULL;
	infoPtr->writeThread = 0;
    }

 *
 *----------------------------------------------------------------------
 */

TclPipeThreadInfo *
TclPipeThreadCreateTI(
    TclPipeThreadInfo **pipeTIPtr,
    void *clientData)

{
    TclPipeThreadInfo *pipeTI;
#ifndef _PTI_USE_CKALLOC
    pipeTI = (TclPipeThreadInfo *)malloc(sizeof(TclPipeThreadInfo));
#else
    pipeTI = (TclPipeThreadInfo *)Tcl_Alloc(sizeof(TclPipeThreadInfo));
#endif /* !_PTI_USE_CKALLOC */
    pipeTI->evControl = CreateEventW(NULL, FALSE, FALSE, NULL);
    pipeTI->state = PTI_STATE_IDLE;
    pipeTI->clientData = clientData;

    return (*pipeTIPtr = pipeTI);
}

/*
 *----------------------------------------------------------------------
 *
 * TclPipeThreadWaitForSignal --

int
TclPipeThreadWaitForSignal(
    TclPipeThreadInfo **pipeTIPtr)
{
    TclPipeThreadInfo *pipeTI = *pipeTIPtr;
    LONG state;
    DWORD waitResult;


    if (!pipeTI) {
	return 0;
    }



    /*
     * Wait for the main thread to signal before attempting to do the work.
     */

    /*
     * Reset work state of thread (idle/waiting)
     */

  end:
    /*
     * End of work, check the owner of the TI structure.
     */

    if (state != PTI_STATE_STOP) {
	*pipeTIPtr = NULL;





    }
    return 0;
}

/*
 *----------------------------------------------------------------------
 *

    HANDLE evControl;
    int state;

    if (!pipeTI) {
	return 1;
    }
    evControl = pipeTI->evControl;

    state = InterlockedCompareExchange(&pipeTI->state, PTI_STATE_STOP,
	    PTI_STATE_IDLE);
    switch (state) {
    case PTI_STATE_IDLE:
	/*
	 * Thread was idle/waiting, notify it goes teardown
	 */

    int state;

    if (!pipeTI) {
	return;
    }
    pipeTI = *pipeTIPtr;
    evControl = pipeTI->evControl;


    /*
     * Try to sane stop the pipe worker, corresponding its current state
     */

    state = InterlockedCompareExchange(&pipeTI->state, PTI_STATE_STOP,
	    PTI_STATE_IDLE);

		}
	    }
	}
    }

    *pipeTIPtr = NULL;
    if (pipeTI) {



	CloseHandle(pipeTI->evControl);
#ifndef _PTI_USE_CKALLOC
	free(pipeTI);
#else
	Tcl_Free(pipeTI);
#endif /* !_PTI_USE_CKALLOC */
    }

    if (!pipeTI) {
	return;
    }
    *pipeTIPtr = NULL;
    state = InterlockedExchange(&pipeTI->state, PTI_STATE_DOWN);
    if (state == PTI_STATE_STOP) {
	CloseHandle(pipeTI->evControl);



#ifndef _PTI_USE_CKALLOC
	free(pipeTI);
#else
	Tcl_Free(pipeTI);
	/* be sure all subsystems used are finalized */
	Tcl_FinalizeThread();
#endif /* !_PTI_USE_CKALLOC */

	/*
	 * Initially the channel is writable and the writeThread is idle.
	 */

	infoPtr->osWrite.hEvent = CreateEventW(NULL, TRUE, FALSE, NULL);
	infoPtr->evWritable = CreateEventW(NULL, TRUE, TRUE, NULL);
	infoPtr->writeThread = CreateThread(NULL, 256, SerialWriterThread,
		TclPipeThreadCreateTI(&infoPtr->writeTI, infoPtr), 0, NULL);

    }

    Tcl_SetChannelOption(NULL, infoPtr->channel, "-translation", "auto");

    return infoPtr->channel;
}


	    PostMessageW(tsdPtr->hwnd, SOCKET_TERMINATE, 0, 0);

	    /*
	     * Wait for the thread to exit. This ensures that we are
	     * completely cleaned up before we leave this function.
	     */

	    WaitForSingleObject(tsdPtr->socketThread, INFINITE);
	    tsdPtr->hwnd = NULL;
	}
	CloseHandle(tsdPtr->socketThread);
	tsdPtr->socketThread = NULL;
    }
    if (tsdPtr->readyEvent != NULL) {
	CloseHandle(tsdPtr->readyEvent);

	 * place to look for bugs.
	 */

	if (bind(sock, addrPtr->ai_addr,
		(socklen_t)addrPtr->ai_addrlen) == SOCKET_ERROR) {
	    Tcl_WinConvertError((DWORD) WSAGetLastError());
	    closesocket(sock);
	    sock = INVALID_SOCKET; /* Bug [40b1814b93] */
	    continue;
	}
	if (port == 0 && chosenport == 0) {
	    address sockname;
	    socklen_t namelen = sizeof(sockname);

	    /*

	if (backlog < 0) {
	    backlog = SOMAXCONN;
	}
	if (listen(sock, backlog) == SOCKET_ERROR) {
	    Tcl_WinConvertError((DWORD) WSAGetLastError());
	    closesocket(sock);
	    sock = INVALID_SOCKET; /* Bug [40b1814b93] */
	    continue;
	}

	if (statePtr == NULL) {
	    /*
	     * Add this socket to the global list of sockets.
	     */