diff options
| -rw-r--r-- | ChangeLog | 15 | ||||
| -rw-r--r-- | generic/tclPipe.c | 12 | ||||
| -rw-r--r-- | tests/winPipe.test | 30 | ||||
| -rw-r--r-- | win/tclWinPipe.c | 57 | ||||
| -rw-r--r-- | win/tclWinTest.c | 115 |
5 files changed, 219 insertions, 10 deletions
@@ -1,3 +1,18 @@ +2002-12-16 David Gravereaux <davygrvy@pobox.com> + + * generic/tclPipe.c (TclCleanupChildren): + * tests/winPipe.c: + * win/tclWinPipe.c (Tcl_WaitPid): + * win/tclWinTest.c: Gave Tcl_WaitPid the ability to return a + Win32 exception code translated into a posix style SIG*. This + allows [close] to report "CHILDKILLED" without the meaning + getting lost in a truncated exit code. In TclCleanupChildren(), + TclpGetPid() had to get moved to before Tcl_WaitPid() as the + the handle is removed from the list taking away the ability + to get the process id after the wait is done. This shouldn't + effect the unix implimentaion unless waitpid is called with + a pid of zero, meaning "any". I don't think it is.. + 2002-12-13 Don Porter <dgp@users.sourceforge.net> * unix/configure.in: Updated configure of CVS snapshots to reflect diff --git a/generic/tclPipe.c b/generic/tclPipe.c index 5365047..7d1334d 100644 --- a/generic/tclPipe.c +++ b/generic/tclPipe.c @@ -10,7 +10,7 @@ * See the file "license.terms" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. * - * RCS: @(#) $Id: tclPipe.c,v 1.6 2002/02/15 14:28:49 dkf Exp $ + * RCS: @(#) $Id: tclPipe.c,v 1.7 2002/12/17 02:47:39 davygrvy Exp $ */ #include "tclInt.h" @@ -280,9 +280,17 @@ TclCleanupChildren(interp, numPids, pidPtr, errorChan) Tcl_Pid pid; WAIT_STATUS_TYPE waitStatus; CONST char *msg; + unsigned long resolvedPid; abnormalExit = 0; for (i = 0; i < numPids; i++) { + /* + * We need to get the resolved pid before we wait on it as + * the windows implimentation of Tcl_WaitPid deletes the + * information such that any following calls to TclpGetPid + * fail. + */ + resolvedPid = TclpGetPid(pidPtr[i]); pid = Tcl_WaitPid(pidPtr[i], (int *) &waitStatus, 0); if (pid == (Tcl_Pid) -1) { result = TCL_ERROR; @@ -315,7 +323,7 @@ TclCleanupChildren(interp, numPids, pidPtr, errorChan) char msg1[TCL_INTEGER_SPACE], msg2[TCL_INTEGER_SPACE]; result = TCL_ERROR; - TclFormatInt(msg1, (long) TclpGetPid(pid)); + TclFormatInt(msg1, (long) resolvedPid); if (WIFEXITED(waitStatus)) { if (interp != (Tcl_Interp *) NULL) { TclFormatInt(msg2, WEXITSTATUS(waitStatus)); diff --git a/tests/winPipe.test b/tests/winPipe.test index 28b2708..26a7e33 100644 --- a/tests/winPipe.test +++ b/tests/winPipe.test @@ -12,7 +12,7 @@ # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. # -# RCS: @(#) $Id: winPipe.test,v 1.21 2002/07/18 16:39:50 vincentdarley Exp $ +# RCS: @(#) $Id: winPipe.test,v 1.22 2002/12/17 02:47:39 davygrvy Exp $ package require tcltest namespace import -force ::tcltest::* @@ -198,6 +198,34 @@ test winpipe-4.1 {Tcl_WaitPid} {pcOnly nt exec cat32} { vwait x list $result $x [contents $path(stderr)] } "{$big} 1 stderr32" +test winpipe-4.2 {Tcl_WaitPid: return of exception codes, SIGFPE} {pcOnly exec} { + set f [open "|[tcltest::interpreter]" w+] + set pid [pid $f] + puts $f "testexcept float_underflow" + set status [catch {close $f}] + list $status [expr {$pid == [lindex $::errorCode 1]}] [lindex $::errorCode 2] +} {1 1 SIGFPE} +test winpipe-4.3 {Tcl_WaitPid: return of exception codes, SIGSEGV} {pcOnly exec} { + set f [open "|[tcltest::interpreter]" w+] + set pid [pid $f] + puts $f "testexcept access_violation" + set status [catch {close $f}] + list $status [expr {$pid == [lindex $::errorCode 1]}] [lindex $::errorCode 2] +} {1 1 SIGSEGV} +test winpipe-4.4 {Tcl_WaitPid: return of exception codes, SIGILL} {pcOnly exec} { + set f [open "|[tcltest::interpreter]" w+] + set pid [pid $f] + puts $f "testexcept illegal_instruction" + set status [catch {close $f}] + list $status [expr {$pid == [lindex $::errorCode 1]}] [lindex $::errorCode 2] +} {1 1 SIGILL} +test winpipe-4.5 {Tcl_WaitPid: return of exception codes, SIGINT} {pcOnly exec} { + set f [open "|[tcltest::interpreter]" w+] + set pid [pid $f] + puts $f "testexcept ctrl+c" + set status [catch {close $f}] + list $status [expr {$pid == [lindex $::errorCode 1]}] [lindex $::errorCode 2] +} {1 1 SIGINT} set path(nothing) [makeFile {} nothing] close [open $path(nothing) w] diff --git a/win/tclWinPipe.c b/win/tclWinPipe.c index 64ecf6d..a8071c0 100644 --- a/win/tclWinPipe.c +++ b/win/tclWinPipe.c @@ -9,7 +9,7 @@ * See the file "license.terms" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. * - * RCS: @(#) $Id: tclWinPipe.c,v 1.31 2002/12/05 00:15:01 davygrvy Exp $ + * RCS: @(#) $Id: tclWinPipe.c,v 1.32 2002/12/17 02:47:39 davygrvy Exp $ */ #include "tclWinInt.h" @@ -2452,7 +2452,7 @@ Tcl_WaitPid( ProcInfo *infoPtr, **prevPtrPtr; DWORD flags; Tcl_Pid result; - DWORD ret; + DWORD ret, exitCode; PipeInit(); @@ -2507,9 +2507,56 @@ Tcl_WaitPid( } else { result = 0; } - } else if (ret != WAIT_FAILED) { - GetExitCodeProcess(infoPtr->hProcess, (DWORD*)statPtr); - *statPtr = ((*statPtr << 8) & 0xff00); + } else if (ret == WAIT_OBJECT_0) { + GetExitCodeProcess(infoPtr->hProcess, &exitCode); + if (exitCode & 0xC0000000) { + /* + * A fatal exception occured. + */ + switch (exitCode) { + case EXCEPTION_FLT_DENORMAL_OPERAND: + case EXCEPTION_FLT_DIVIDE_BY_ZERO: + case EXCEPTION_FLT_INEXACT_RESULT: + case EXCEPTION_FLT_INVALID_OPERATION: + case EXCEPTION_FLT_OVERFLOW: + case EXCEPTION_FLT_STACK_CHECK: + case EXCEPTION_FLT_UNDERFLOW: + case EXCEPTION_INT_DIVIDE_BY_ZERO: + case EXCEPTION_INT_OVERFLOW: + *statPtr = SIGFPE; + break; + + case EXCEPTION_PRIV_INSTRUCTION: + case EXCEPTION_ILLEGAL_INSTRUCTION: + *statPtr = SIGILL; + break; + + case EXCEPTION_ACCESS_VIOLATION: + case EXCEPTION_DATATYPE_MISALIGNMENT: + case EXCEPTION_ARRAY_BOUNDS_EXCEEDED: + case EXCEPTION_STACK_OVERFLOW: + case EXCEPTION_NONCONTINUABLE_EXCEPTION: + case EXCEPTION_INVALID_DISPOSITION: + case EXCEPTION_GUARD_PAGE: + case EXCEPTION_INVALID_HANDLE: + *statPtr = SIGSEGV; + break; + + case CONTROL_C_EXIT: + *statPtr = SIGINT; + break; + + default: + *statPtr = SIGABRT; + break; + } + } else { + /* + * Non exception, normal, exit code. Note that the exit code + * is truncated to a byte range. + */ + *statPtr = ((exitCode << 8) & 0xff00); + } result = pid; } else { errno = ECHILD; diff --git a/win/tclWinTest.c b/win/tclWinTest.c index bda1f11..51b72e7 100644 --- a/win/tclWinTest.c +++ b/win/tclWinTest.c @@ -8,7 +8,7 @@ * See the file "license.terms" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. * - * RCS: @(#) $Id: tclWinTest.c,v 1.7 2002/08/05 03:24:41 dgp Exp $ + * RCS: @(#) $Id: tclWinTest.c,v 1.8 2002/12/17 02:47:39 davygrvy Exp $ */ #define USE_COMPAT_CONST @@ -27,6 +27,8 @@ static int TestwinclockCmd _ANSI_ARGS_(( ClientData dummy, Tcl_Interp* interp, int objc, Tcl_Obj *CONST objv[] )); +static Tcl_ObjCmdProc TestExceptionCmd; + /* *---------------------------------------------------------------------- @@ -34,7 +36,7 @@ static int TestwinclockCmd _ANSI_ARGS_(( ClientData dummy, * TclplatformtestInit -- * * Defines commands that test platform specific functionality for - * Unix platforms. + * Windows platforms. * * Results: * A standard Tcl result. @@ -59,6 +61,7 @@ TclplatformtestInit(interp) (ClientData) 0, (Tcl_CmdDeleteProc *) NULL); Tcl_CreateObjCommand(interp, "testwinclock", TestwinclockCmd, (ClientData) 0, (Tcl_CmdDeleteProc *) NULL); + Tcl_CreateObjCommand(interp, "testexcept", TestExceptionCmd, NULL, NULL); return TCL_OK; } @@ -266,3 +269,111 @@ TestwinclockCmd( ClientData dummy, return TCL_OK; } + +/* + *---------------------------------------------------------------------- + * + * TestExceptionCmd -- + * + * Causes this process to end with the named exception. Used for + * testing Tcl_WaitPid(). + * + * Usage: + * testexcept <type> + * + * Parameters: + * Type of exception. + * + * Results: + * None, this process closes now and doesn't return. + * + * Side effects: + * This Tcl process closes, hard... Bang! + * + *---------------------------------------------------------------------- + */ + +static int +TestExceptionCmd( + ClientData dummy, /* Unused */ + Tcl_Interp* interp, /* Tcl interpreter */ + int objc, /* Argument count */ + Tcl_Obj *CONST objv[]) /* Argument vector */ +{ + static char *cmds[] = { + "access_violation", + "datatype_misalignment", + "array_bounds", + "float_denormal", + "float_divbyzero", + "float_inexact", + "float_invalidop", + "float_overflow", + "float_stack", + "float_underflow", + "int_divbyzero", + "int_overflow", + "private_instruction", + "inpageerror", + "illegal_instruction", + "noncontinue", + "stack_overflow", + "invalid_disp", + "guard_page", + "invalid_handle", + "ctrl+c", + NULL + }; + static DWORD exceptions[] = { + EXCEPTION_ACCESS_VIOLATION, + EXCEPTION_DATATYPE_MISALIGNMENT, + EXCEPTION_ARRAY_BOUNDS_EXCEEDED, + EXCEPTION_FLT_DENORMAL_OPERAND, + EXCEPTION_FLT_DIVIDE_BY_ZERO, + EXCEPTION_FLT_INEXACT_RESULT, + EXCEPTION_FLT_INVALID_OPERATION, + EXCEPTION_FLT_OVERFLOW, + EXCEPTION_FLT_STACK_CHECK, + EXCEPTION_FLT_UNDERFLOW, + EXCEPTION_INT_DIVIDE_BY_ZERO, + EXCEPTION_INT_OVERFLOW, + EXCEPTION_PRIV_INSTRUCTION, + EXCEPTION_IN_PAGE_ERROR, + EXCEPTION_ILLEGAL_INSTRUCTION, + EXCEPTION_NONCONTINUABLE_EXCEPTION, + EXCEPTION_STACK_OVERFLOW, + EXCEPTION_INVALID_DISPOSITION, + EXCEPTION_GUARD_PAGE, + EXCEPTION_INVALID_HANDLE, + CONTROL_C_EXIT + }; + int cmd; + + if ( objc != 2 ) { + Tcl_WrongNumArgs(interp, 0, objv, "<type-of-exception>"); + return TCL_ERROR; + } + if (Tcl_GetIndexFromObj(interp, objv[1], cmds, "command", 0, + &cmd) != TCL_OK) { + return TCL_ERROR; + } + + /* + * Make sure the GPF dialog doesn't popup. + */ + + SetErrorMode(SEM_FAILCRITICALERRORS | SEM_NOGPFAULTERRORBOX); + + /* + * As Tcl does not handle structured exceptions, this falls all the way + * back up the instruction stack to the C run-time portion that called + * main() where the process will now be terminated with this exception + * code by the default handler the C run-time provides. + */ + + /* SMASH! */ + RaiseException(exceptions[cmd], EXCEPTION_NONCONTINUABLE, 0, NULL); + + /* NOTREACHED */ + return TCL_OK; +} |