Attachment "tip240.8_5a3.patch" to
ticket [1315115fff]
added by
stevebold
2005-10-07 14:56:42.
*** ../tcl8.5a3.original/generic/tclBasic.c Thu Oct 06 12:48:50 2005
--- generic/tclBasic.c Thu Oct 06 14:17:03 2005
***************
*** 529,534 ****
--- 529,552 ----
(Tcl_CmdDeleteProc*) NULL);
/*
+ * Register the process commands. These *do* go through
+ * Tcl_CreateObjCommand, since they aren't in the global namespace.
+ */
+
+ Tcl_CreateObjCommand( interp, "::tcl::process::invoke",
+ TclProcessInvokeObjCmd, (ClientData) NULL,
+ (Tcl_CmdDeleteProc*) NULL );
+ Tcl_CreateObjCommand( interp, "::tcl::process::pipe",
+ TclProcessPipeObjCmd, (ClientData) NULL,
+ (Tcl_CmdDeleteProc*) NULL );
+ Tcl_CreateObjCommand( interp, "::tcl::process::status",
+ TclProcessStatusObjCmd, (ClientData) 0,
+ (Tcl_CmdDeleteProc*) NULL );
+ Tcl_CreateObjCommand( interp, "::tcl::process::wait",
+ TclProcessStatusObjCmd, (ClientData) 1,
+ (Tcl_CmdDeleteProc*) NULL );
+
+ /*
* Register the built-in functions
*/
*** ../tcl8.5a3.original/generic/tclIOCmd.c Thu Oct 06 12:48:48 2005
--- generic/tclIOCmd.c Thu Oct 06 14:17:04 2005
***************
*** 853,858 ****
--- 853,1154 ----
}
/*
+ *----------------------------------------------------------------------
+ *
+ * getInvokeFile --
+ *
+ * Obtains the file corresponding to a channel name.
+ *
+ * Results:
+ * A standard Tcl result.
+ *
+ * Side effects:
+ * None.
+ *
+ *----------------------------------------------------------------------
+ */
+
+ static int
+ getInvokeFile(
+ Tcl_Interp *interp, /* Current interpreter */
+ const char *chanName, /* Channel to find */
+ int direction, /* Expected direction of channel */
+ TclFile *file /* Set to file corresponding to channel */
+ )
+ {
+ Tcl_Channel chan;
+ if (strlen(chanName) == 0) {
+ /* Caller wants the channel disconnected.
+ */
+ *file = NULL;
+ return TCL_OK;
+ }
+
+ chan = Tcl_GetChannel(interp, chanName,NULL);
+ if (chan == NULL) {
+ *file = NULL;
+
+ /*
+ * Error message already set.
+ */
+ return TCL_ERROR;
+ }
+
+ *file = TclpMakeFile(chan,direction);
+ if (*file == NULL) {
+ Tcl_AppendResult(interp, "channel \"", chanName,"\" is not open for ",
+ (direction == TCL_READABLE ? "read" : "write"), (char *) NULL);
+ return TCL_ERROR;
+ }
+ return TCL_OK;
+ }
+
+ /*
+ *----------------------------------------------------------------------
+ *
+ * TclProcessInvokeObjCmd --
+ *
+ * This procedure is invoked to process the "process invoke" Tcl command.
+ * See the user documentation for details on what it does.
+ *
+ * Results:
+ * A standard Tcl result.
+ *
+ * Side effects:
+ * See the user documentation.
+ *----------------------------------------------------------------------
+ */
+
+ /* ARGSUSED */
+ int
+ TclProcessInvokeObjCmd(dummy, interp, objc, objv)
+ ClientData dummy; /* Not used. */
+ Tcl_Interp *interp; /* Current interpreter. */
+ int objc; /* Number of arguments. */
+ Tcl_Obj *CONST objv[]; /* Argument objects. */
+ {
+ /*
+ * This procedure generates an argv array for the string arguments. It
+ * starts out with stack-allocated space but uses dynamically-allocated
+ * storage if needed.
+ */
+
+ #define NUM_ARGS 20
+ CONST char *argStorage[NUM_ARGS];
+ CONST char **argv = argStorage;
+ int i;
+ Tcl_Pid pid;
+
+ /* default result till we get to the end.
+ */
+ int result = TCL_ERROR;
+ int argc;
+ Tcl_Obj *argObj;
+
+ Tcl_Obj* cmdLine;
+ char* inChanName;
+ char* outChanName;
+ char* errChanName;
+ TclFile inFile = NULL,outFile = NULL,errFile = NULL;
+ Tcl_DString programNameBuf;
+
+ /* Must initialize programNameBuf before any error condition does 'goto cleanup.
+ */
+ Tcl_DStringInit(&programNameBuf);
+
+ if (objc != 5) {
+ Tcl_WrongNumArgs(interp, 1, objv, "cmdLine stdin stdout stderr");
+ goto cleanup;
+ }
+ cmdLine = objv[1];
+ inChanName = Tcl_GetString(objv[2]);
+ outChanName = Tcl_GetString(objv[3]);
+ errChanName = Tcl_GetString(objv[4]);
+ if (Tcl_ListObjLength(interp,cmdLine,&argc) != TCL_OK) {
+ /* Caller didn't pass us a valid list.
+ */
+ goto cleanup;
+ }
+
+ if (getInvokeFile(interp,inChanName,TCL_READABLE,&inFile) != TCL_OK) goto cleanup;
+ if (getInvokeFile(interp,outChanName,TCL_WRITABLE,&outFile) != TCL_OK) goto cleanup;
+ if (getInvokeFile(interp,errChanName,TCL_WRITABLE,&errFile) != TCL_OK) goto cleanup;
+
+ /*
+ * Create the string argument array "argv". Make sure argv is large
+ * enough to hold the argc arguments plus 1 extra for the zero
+ * end-of-argv word.
+ */
+ if ((argc + 1) > sizeof(argv) / sizeof(argv[0])) {
+ argv = (CONST char **) ckalloc((unsigned)(argc + 1) * sizeof(char *));
+ }
+
+ if (argc == 0) {
+ Tcl_SetObjResult(interp,
+ Tcl_NewStringObj("Cannot invoke empty command line",-1));
+ goto cleanup;
+ }
+
+ /* Convert the Tcl list cmdLine to a C array, we already know it's a valid
+ * non-empty list.
+ */
+
+ /* Program name must be in native format for Win 9x compatibility.
+ */
+ Tcl_ListObjIndex(interp,cmdLine,0,&argObj);
+ argv[0] = Tcl_TranslateFileName(interp, TclGetString(argObj),
+ &programNameBuf);
+
+ /* Command line arguments are passed unchanged.
+ */
+ for (i = 1; i != argc; i++) {
+ Tcl_ListObjIndex(interp,cmdLine,i,&argObj);
+ argv[i] = Tcl_GetString(argObj);
+ }
+ argv[argc] = NULL;
+
+ result = TclpCreateProcess(interp, argc, argv,
+ inFile, outFile, errFile, &pid);
+
+ cleanup:
+ Tcl_DStringFree(&programNameBuf);
+ if (inFile) TclpReleaseFile(inFile);
+ if (outFile) TclpReleaseFile(outFile);
+ if (errFile) TclpReleaseFile(errFile);
+
+ /*
+ * Free the argv array if malloc'ed storage was used.
+ */
+ if (argv != argStorage) {
+ ckfree((char *)argv);
+ }
+
+ if (result == TCL_OK) {
+ /* Convert pid into something we can pass back to our calling script.
+ */
+ unsigned long pidValue = TclpGetPid(pid);
+ long signedPidValue = (long)pidValue;
+ Tcl_SetObjResult(interp, Tcl_NewLongObj(signedPidValue));
+ }
+
+ return result;
+ }
+
+ /*
+ *----------------------------------------------------------------------
+ *
+ * TclProcessPipeObjCmd --
+ *
+ * This procedure is invoked to process the "process pipe" Tcl command.
+ * See the user documentation for details on what it does.
+ *
+ * Results:
+ * A standard Tcl result.
+ *
+ * Side effects:
+ * See the user documentation.
+ *----------------------------------------------------------------------
+ */
+
+ /* ARGSUSED */
+ int
+ TclProcessPipeObjCmd(dummy, interp, objc, objv)
+ ClientData dummy; /* Not used. */
+ Tcl_Interp *interp; /* Current interpreter. */
+ int objc; /* Number of arguments. */
+ Tcl_Obj *CONST objv[]; /* Argument objects. */
+ {
+ Tcl_Channel inChan,outChan;
+ TclFile readPipe,writePipe;
+ Tcl_Obj *channelNames[2];
+ Tcl_Obj *result;
+
+ if (objc != 1) {
+ Tcl_WrongNumArgs(interp, 1, objv, "");
+ return TCL_ERROR;
+ }
+
+ TclpCreatePipe(&readPipe,&writePipe);
+
+ inChan = TclpCreateCommandChannel(readPipe,NULL,NULL,0,NULL);
+ Tcl_RegisterChannel(interp,inChan);
+ channelNames[0] = Tcl_NewStringObj(Tcl_GetChannelName(inChan),-1);
+
+ outChan = TclpCreateCommandChannel(NULL,writePipe,NULL,0,NULL);
+ Tcl_RegisterChannel(interp,outChan);
+ channelNames[1] = Tcl_NewStringObj(Tcl_GetChannelName(outChan),-1);
+
+ result = Tcl_NewListObj(2,channelNames);
+ Tcl_SetObjResult(interp,result);
+ return TCL_OK;
+ }
+
+ /*
+ *----------------------------------------------------------------------
+ *
+ * TclProcessStatusObjCmd --
+ *
+ * This procedure is invoked to process the "process status" and "process wait"
+ * Tcl commands. See the user documentation for details on what it does.
+ *
+ * Results:
+ * A standard Tcl result.
+ *
+ * Side effects:
+ * See the user documentation.
+ *----------------------------------------------------------------------
+ */
+
+ int
+ TclProcessStatusObjCmd(clientData, interp, objc, objv)
+ ClientData clientData; /* Controls blocking behaviour */
+ Tcl_Interp *interp; /* Current interpreter. */
+ int objc; /* Number of arguments. */
+ Tcl_Obj *CONST objv[]; /* Argument objects. */
+ {
+ long signedPidValue;
+ unsigned long pidValue;
+ Tcl_Pid pid;
+ int exitCode;
+ int completed;
+ CONST char* status;
+ Tcl_Obj *argv[2];
+
+ /*
+ * we create two commands bound to this function, clientData
+ * decides whether we want blocking behaviour
+ */
+ int waitOptions = (int)clientData ? 0 : WNOHANG;
+
+ if (objc != 2) {
+ Tcl_WrongNumArgs(interp, 1, objv, "pid");
+ return TCL_ERROR;
+ }
+
+ if (Tcl_GetLongFromObj(interp,objv[1],&signedPidValue) != TCL_OK) {
+ return TCL_ERROR;
+ }
+ pidValue = (unsigned long)signedPidValue;
+ pid = TclpGetPidHandle(pidValue);
+
+ if (TclpGetProcessStatus(pid,waitOptions,&completed,&exitCode) == TCL_ERROR) {
+ Tcl_SetObjResult(interp,Tcl_NewStringObj("No such process",-1));
+ return TCL_ERROR;
+ }
+
+ if (completed) {
+ status = "completed";
+ } else {
+ status = "running";
+ }
+ argv[0] = Tcl_NewStringObj(status,-1);
+ argv[1] = Tcl_NewIntObj(exitCode);
+ Tcl_SetObjResult(interp,Tcl_NewListObj(2,argv));
+ return TCL_OK;
+ }
+
+
+ /*
*---------------------------------------------------------------------------
*
* Tcl_FblockedObjCmd --
*** ../tcl8.5a3.original/unix/tclUnixPipe.c Thu Oct 06 12:48:16 2005
--- unix/tclUnixPipe.c Thu Oct 06 14:17:11 2005
***************
*** 600,609 ****
*
* SetupStdFile --
*
! * Set up stdio file handles for the child process, using the
! * current standard channels if no other files are specified.
! * If no standard channel is defined, or if no file is associated
! * with the channel, then the corresponding standard fd is closed.
*
* Results:
* Returns 1 on success, or 0 on failure.
--- 600,607 ----
*
* SetupStdFile --
*
! * Set up stdio file handles for the child process, if no file is associated
! * with the handle, then the corresponding standard fd is closed.
*
* Results:
* Returns 1 on success, or 0 on failure.
***************
*** 619,625 ****
TclFile file; /* File to dup, or NULL. */
int type; /* One of TCL_STDIN, TCL_STDOUT, TCL_STDERR */
{
! Tcl_Channel channel;
int fd;
int targetFd = 0; /* Initializations here needed only to */
int direction = 0; /* prevent warnings about using uninitialized
--- 617,623 ----
TclFile file; /* File to dup, or NULL. */
int type; /* One of TCL_STDIN, TCL_STDOUT, TCL_STDERR */
{
! /* Tcl_Channel channel; */
int fd;
int targetFd = 0; /* Initializations here needed only to */
int direction = 0; /* prevent warnings about using uninitialized
***************
*** 640,651 ****
break;
}
! if (!file) {
! channel = Tcl_GetStdChannel(type);
! if (channel) {
! file = TclpMakeFile(channel, direction);
! }
! }
if (file) {
fd = GetFd(file);
if (fd != targetFd) {
--- 638,663 ----
break;
}
! /* TIP 240 change:
! * removed logic for treating NULL files as indication to use the parent
! * standard channels.
! *
! * The only existing TclpCreateProcess() client is TclCreatePipeline() and
! * it always specifies the files to connect to. The new client is
! * TclProcessInvoke() and when it asks for unconnected child streams,
! * it wants unconnected child streams.
! *
! * This change also makes TclpCreateProcess() consistent with the Windows
! * implementation.
! *
! * if (!file) {
! * channel = Tcl_GetStdChannel(type);
! * if (channel) {
! * file = TclpMakeFile(channel, direction);
! * }
! * }
! */
!
if (file) {
fd = GetFd(file);
if (fd != targetFd) {
***************
*** 1156,1161 ****
--- 1168,1215 ----
}
return TCL_ERROR;
}
+
+ /*
+ *----------------------------------------------------------------------
+ *
+ * TclpGetProcessStatus --
+ *
+ * Tests a child process to see if it's running or completed.
+ * This is similar to Tcl_WaitPid() but provides a platform
+ * independent way of detecting the error case when the pid
+ * doesn't correspond to a child process.
+ *
+ * Results:
+ * A standard Tcl result.
+ *
+ * Side effects:
+ * If the process has completed, this will remove it's zombie
+ * process. Subsequent calls will be unable to access the exit code.
+ *----------------------------------------------------------------------
+ */
+
+ int
+ TclpGetProcessStatus(
+ Tcl_Pid pid, /* Child process to test */
+ int waitOptions, /* How long to wait before */
+ int *completed, /* Set to 1 if the process is completed or to 0
+ * if stil running
+ */
+ int *exitCode /* Set to the child process's exit status if
+ * complete or to 0 if still running.
+ */
+ )
+ {
+ Tcl_Pid waitResult = Tcl_WaitPid(pid,exitCode,waitOptions);
+ *completed = (waitResult != NULL);
+
+ if (waitResult == (Tcl_Pid)-1) {
+ return TCL_ERROR;
+ }
+
+ return TCL_OK;
+ }
+
/*
*----------------------------------------------------------------------
*** ../tcl8.5a3.original/win/tclWinPipe.c Thu Oct 06 12:48:14 2005
--- win/tclWinPipe.c Thu Oct 06 14:17:12 2005
***************
*** 889,894 ****
--- 889,932 ----
/*
*--------------------------------------------------------------------------
*
+ * TclpGetPidHandle --
+ *
+ * Given a process id for a child process, returns the corresponding HANDLE.
+ *
+ * Results:
+ * Returns the handle for the child process. If the id was not
+ * known by Tcl, either because the pid was not created by Tcl or the
+ * child process has already been reaped, NULL is returned.
+ *
+ * Side effects:
+ * None.
+ *
+ *--------------------------------------------------------------------------
+ */
+
+ Tcl_Pid
+ TclpGetPidHandle(
+ unsigned long pidValue)
+ {
+ ProcInfo *infoPtr;
+
+ PipeInit();
+
+ Tcl_MutexLock(&pipeMutex);
+ for (infoPtr = procList; infoPtr != NULL; infoPtr = infoPtr->nextPtr) {
+ if (infoPtr->dwProcessId == pidValue) {
+ Tcl_MutexUnlock(&pipeMutex);
+ return infoPtr->hProcess;
+ }
+ }
+ Tcl_MutexUnlock(&pipeMutex);
+ return NULL;
+ }
+
+
+ /*
+ *--------------------------------------------------------------------------
+ *
* TclpGetPid --
*
* Given a HANDLE to a child process, return the process id for that
***************
*** 2491,2496 ****
--- 2529,2580 ----
/*
*----------------------------------------------------------------------
*
+ * TclpGetProcessStatus --
+ *
+ * Tests a child process to see if it's running or completed.
+ * This is similar to Tcl_WaitPid() but provides a platform
+ * independent way of detecting the error case when the pid
+ * doesn't correspond to a child process.
+ *
+ * Results:
+ * A standard Tcl result.
+ *
+ * Side effects:
+ * If the process has completed, this will remove it's zombie
+ * process. Subsequent calls will be unable to access the exit code.
+ *----------------------------------------------------------------------
+ */
+
+ int
+ TclpGetProcessStatus(
+ Tcl_Pid pid, /* Child process to test */
+ int waitOptions, /* How long to wait before */
+ int *completed, /* Set to 1 if the process is completed or to 0
+ * if stil running
+ */
+ int *exitCode /* Set to the child process's exit status if
+ * complete or to 0 if still running.
+ */
+ )
+ {
+ Tcl_Pid waitResult;
+
+ if (pid == NULL) {
+ *completed = 1;
+ *exitCode = 0;
+ return TCL_ERROR;
+ }
+
+ waitResult = Tcl_WaitPid(pid,exitCode,waitOptions);
+
+ *completed = (waitResult != NULL);
+ return TCL_OK;
+ }
+
+
+ /*
+ *----------------------------------------------------------------------
+ *
* Tcl_WaitPid --
*
* Emulates the waitpid system call.
*** ../tcl8.5a3.original/generic/tclInt.h Thu Oct 06 12:48:52 2005
--- generic/tclInt.h Thu Oct 06 14:35:47 2005
***************
*** 2102,2107 ****
--- 2102,2112 ----
Tcl_FSUnloadFileProc **unloadProcPtr));
MODULE_SCOPE int TclpUtime _ANSI_ARGS_((Tcl_Obj *pathPtr,
struct utimbuf *tval));
+ MODULE_SCOPE Tcl_Pid TclpGetPidHandle _ANSI_ARGS_((unsigned long pidValue));
+ MODULE_SCOPE int TclpGetProcessStatus _ANSI_ARGS_((
+ Tcl_Pid pid,int waitOptions,
+ int *completed,int *exitCode));
+
#ifdef TCL_LOAD_FROM_MEMORY
MODULE_SCOPE void* TclpLoadMemoryGetBuffer _ANSI_ARGS_((
Tcl_Interp *interp, int size));
***************
*** 2309,2314 ****
--- 2314,2328 ----
MODULE_SCOPE int Tcl_PidObjCmd _ANSI_ARGS_((ClientData clientData,
Tcl_Interp *interp, int objc,
Tcl_Obj *CONST objv[]));
+ MODULE_SCOPE int TclProcessInvokeObjCmd _ANSI_ARGS_ ((ClientData clientData,
+ Tcl_Interp *interp, int objc,
+ Tcl_Obj *CONST objv[]));
+ MODULE_SCOPE int TclProcessPipeObjCmd _ANSI_ARGS_ ((ClientData clientData,
+ Tcl_Interp *interp, int objc,
+ Tcl_Obj *CONST objv[]));
+ MODULE_SCOPE int TclProcessStatusObjCmd _ANSI_ARGS_ ((ClientData clientData,
+ Tcl_Interp *interp, int objc,
+ Tcl_Obj *CONST objv[]));
MODULE_SCOPE int Tcl_PutsObjCmd _ANSI_ARGS_((ClientData clientData,
Tcl_Interp *interp, int objc,
Tcl_Obj *CONST objv[]));
*** ../tcl8.5a3.original/unix/tclUnixPort.h Thu Oct 06 12:48:16 2005
--- unix/tclUnixPort.h Thu Oct 06 14:17:11 2005
***************
*** 525,530 ****
--- 525,531 ----
* address platform-specific issues.
*/
+ #define TclpGetPidHandle(pidValue) ((Tcl_Pid) (pidValue))
#define TclpGetPid(pid) ((unsigned long) (pid))
#define TclpReleaseFile(file) /* Nothing. */
*** ../tcl8.5a3.original/library/init.tcl Thu Oct 06 12:48:28 2005
--- library/init.tcl Thu Oct 06 13:59:24 2005
***************
*** 155,160 ****
--- 155,172 ----
}
}
+ # Set up the 'process' ensemble
+
+ if { ![interp issafe] } {
+
+ namespace eval ::tcl::process {
+ namespace ensemble create -command ::process \
+ -subcommands {
+ invoke pipe status wait
+ }
+ }
+ }
+
# Conditionalize for presence of exec.
if {[llength [info commands exec]] == 0} {
