1/* 2 * tclXprocess.c -- 3 * 4 * Tcl command to create and manage processes. 5 *----------------------------------------------------------------------------- 6 * Copyright 1991-1999 Karl Lehenbauer and Mark Diekhans. 7 * 8 * Permission to use, copy, modify, and distribute this software and its 9 * documentation for any purpose and without fee is hereby granted, provided 10 * that the above copyright notice appear in all copies. Karl Lehenbauer and 11 * Mark Diekhans make no representations about the suitability of this 12 * software for any purpose. It is provided "as is" without express or 13 * implied warranty. 14 *----------------------------------------------------------------------------- 15 * $Id: tclXprocess.c,v 1.1 2001/10/24 23:31:48 hobbs Exp $ 16 *----------------------------------------------------------------------------- 17 */ 18 19#include "tclExtdInt.h" 20 21/* 22 * These are needed for wait command even if waitpid is not available. 23 */ 24#ifndef WNOHANG 25# define WNOHANG 1 26#endif 27#ifndef WUNTRACED 28# define WUNTRACED 2 29#endif 30 31static int 32TclX_ExeclObjCmd _ANSI_ARGS_((ClientData clientData, 33 Tcl_Interp *interp, 34 int objc, 35 Tcl_Obj *CONST objv[])); 36 37static int 38TclX_ForkObjCmd _ANSI_ARGS_((ClientData clientData, 39 Tcl_Interp *interp, 40 int objc, 41 Tcl_Obj *CONST objv[])); 42 43static int 44TclX_WaitObjCmd _ANSI_ARGS_((ClientData clientData, 45 Tcl_Interp *interp, 46 int objc, 47 Tcl_Obj *CONST objv[])); 48 49 50/*----------------------------------------------------------------------------- 51 * TclX_ForkObjCmd -- 52 * Implements the TclX fork command: 53 * fork 54 *----------------------------------------------------------------------------- 55 */ 56static int 57TclX_ForkObjCmd (clientData, interp, objc, objv) 58 ClientData clientData; 59 Tcl_Interp *interp; 60 int objc; 61 Tcl_Obj *CONST objv[]; 62{ 63 if (objc != 1) 64 return TclX_WrongArgs (interp, objv [0], ""); 65 66 return TclXOSfork (interp, objv [0]); 67} 68 69/*----------------------------------------------------------------------------- 70 * TclX_ExeclObjCmd -- 71 * Implements the TCL execl command: 72 * execl ?-argv0 ? prog ?argList? 73 *----------------------------------------------------------------------------- 74 */ 75static int 76TclX_ExeclObjCmd (clientData, interp, objc, objv) 77 ClientData clientData; 78 Tcl_Interp *interp; 79 int objc; 80 Tcl_Obj *CONST objv[]; 81{ 82#define STATIC_ARG_SIZE 12 83 char *staticArgv [STATIC_ARG_SIZE]; 84 char **argList = staticArgv; 85 int nextArg = 1; 86 char *argStr; 87 int argObjc; 88 Tcl_Obj **argObjv; 89 char *path, *argv0 = NULL; 90 int idx, status; 91 Tcl_DString pathBuf; 92 93 status = TCL_ERROR; /* assume the worst */ 94 95 if (objc < 2) 96 goto wrongArgs; 97 98 argStr = Tcl_GetStringFromObj (objv [nextArg], NULL); 99 if (STREQU (argStr, "-argv0")) { 100 nextArg++; 101 if (nextArg == objc) 102 goto wrongArgs; 103 argv0 = Tcl_GetStringFromObj (objv [nextArg++], NULL); 104 } 105 if ((nextArg == objc) || (nextArg < objc - 2)) 106 goto wrongArgs; 107 108 /* 109 * Get path or command name. 110 */ 111 Tcl_DStringInit (&pathBuf); 112 path = Tcl_TranslateFileName (interp, 113 Tcl_GetStringFromObj (objv [nextArg++], 114 NULL), 115 &pathBuf); 116 if (path == NULL) 117 goto exitPoint; 118 119 /* 120 * If arg list is supplied, split it and build up the arguments to pass. 121 * otherwise, just supply argv[0]. Must be NULL terminated. 122 */ 123 if (nextArg == objc) { 124 argList [1] = NULL; 125 } else { 126 if (Tcl_ListObjGetElements (interp, objv [nextArg++], 127 &argObjc, &argObjv) != TCL_OK) 128 goto exitPoint; 129 130 if (argObjc > STATIC_ARG_SIZE - 2) 131 argList = (char **) ckalloc ((argObjc + 1) * sizeof (char **)); 132 133 for (idx = 0; idx < argObjc; idx++) { 134 argList [idx + 1] = Tcl_GetStringFromObj (argObjv [idx], NULL); 135 } 136 argList [argObjc + 1] = NULL; 137 } 138 139 if (argv0 != NULL) { 140 argList [0] = argv0; 141 } else { 142 argList [0] = path; /* Program name */ 143 } 144 145 status = TclXOSexecl (interp, path, argList); 146 147 exitPoint: 148 if (argList != staticArgv) 149 ckfree ((char *) argList); 150 Tcl_DStringFree (&pathBuf); 151 return status; 152 153 wrongArgs: 154 TclX_WrongArgs (interp, objv [0], "?-argv0 argv0? prog ?argList?"); 155 return TCL_ERROR; 156} 157 158/*----------------------------------------------------------------------------- 159 * TclX_WaitObjCmd -- 160 * Implements the TCL wait command: 161 * wait ?-nohang? ?-untraced? ?-pgroup? ?pid? 162 *----------------------------------------------------------------------------- 163 */ 164static int 165TclX_WaitObjCmd (clientData, interp, objc, objv) 166 ClientData clientData; 167 Tcl_Interp *interp; 168 int objc; 169 Tcl_Obj *CONST objv[]; 170{ 171 int idx, options = 0, pgroup = FALSE; 172 char *argStr; 173 pid_t returnedPid, pid; 174 int tmpPid, status; 175 Tcl_Obj *resultList [3]; 176 177 for (idx = 1; idx < objc; idx++) { 178 argStr = Tcl_GetStringFromObj (objv [idx], NULL); 179 if (argStr [0] != '-') 180 break; 181 if (STREQU (argStr, "-nohang")) { 182 if (options & WNOHANG) 183 goto usage; 184 options |= WNOHANG; 185 continue; 186 } 187 if (STREQU (argStr, "-untraced")) { 188 if (options & WUNTRACED) 189 goto usage; 190 options |= WUNTRACED; 191 continue; 192 } 193 if (STREQU (argStr, "-pgroup")) { 194 if (pgroup) 195 goto usage; 196 pgroup = TRUE; 197 continue; 198 } 199 goto usage; /* None match */ 200 } 201 /* 202 * Check for more than one non-minus argument. If ok, convert pid, 203 * if supplied. 204 */ 205 if (idx < objc - 1) 206 goto usage; 207 if (idx < objc) { 208 if (Tcl_GetIntFromObj (interp, objv [idx], &tmpPid) != TCL_OK) { 209 Tcl_ResetResult (interp); 210 goto invalidPid; 211 } 212 if (tmpPid <= 0) 213 goto negativePid; 214 pid = tmpPid; 215 if (pid != tmpPid) 216 goto invalidPid; 217 } else { 218 pid = -1; /* pid or pgroup not supplied */ 219 } 220 221 /* 222 * Versions that don't have real waitpid have limited functionality. 223 */ 224#ifdef NO_WAITPID 225 if ((options != 0) || pgroup) { 226 TclX_AppendObjResult (interp, "The \"-nohang\", \"-untraced\" and ", 227 "\"-pgroup\" options are not available on this ", 228 "system", (char *) NULL); 229 return TCL_ERROR; 230 } 231#endif 232 233 if (pgroup) { 234 if (pid > 0) 235 pid = -pid; 236 else 237 pid = 0; 238 } 239 240 returnedPid = (pid_t) TCLX_WAITPID (pid, (int *) (&status), options); 241 242 if (returnedPid < 0) { 243 TclX_AppendObjResult (interp, "wait for process failed: ", 244 Tcl_PosixError (interp), (char *) NULL); 245 return TCL_ERROR; 246 } 247 248 /* 249 * If no process was available, return an empty status. Otherwise return 250 * a list contain the PID and why it stopped. 251 */ 252 if (returnedPid == 0) 253 return TCL_OK; 254 255 resultList [0] = Tcl_NewIntObj (returnedPid); 256 if (WIFEXITED (status)) { 257 resultList [1] = Tcl_NewStringObj ("EXIT", -1); 258 resultList [2] = Tcl_NewIntObj (WEXITSTATUS (status)); 259 } else if (WIFSIGNALED (status)) { 260 resultList [1] = Tcl_NewStringObj ("SIG", -1); 261 resultList [2] = Tcl_NewStringObj (Tcl_SignalId (WTERMSIG (status)), 262 -1); 263 } else if (WIFSTOPPED (status)) { 264 resultList [1] = Tcl_NewStringObj ("STOP", -1); 265 resultList [2] = Tcl_NewStringObj (Tcl_SignalId (WSTOPSIG (status)), 266 -1); 267 } 268 Tcl_SetListObj (Tcl_GetObjResult (interp), 3, resultList); 269 return TCL_OK; 270 271 usage: 272 TclX_WrongArgs (interp, objv [0], "?-nohang? ?-untraced? ?-pgroup? ?pid?"); 273 return TCL_ERROR; 274 275 invalidPid: 276 TclX_AppendObjResult (interp, "invalid pid or process group id \"", 277 Tcl_GetStringFromObj (objv [idx], NULL), 278 "\"", (char *) NULL); 279 return TCL_ERROR; 280 281 negativePid: 282 TclX_AppendObjResult (interp, "pid or process group id must be greater ", 283 "than zero", (char *) NULL); 284 return TCL_ERROR; 285} 286 287 288/*----------------------------------------------------------------------------- 289 * TclX_ProcessInit -- 290 * Initialize process commands. 291 *----------------------------------------------------------------------------- 292 */ 293void 294TclX_ProcessInit (interp) 295 Tcl_Interp *interp; 296{ 297 Tcl_CreateObjCommand (interp, 298 "execl", 299 TclX_ExeclObjCmd, 300 (ClientData) NULL, 301 (Tcl_CmdDeleteProc*) NULL); 302 303 /* Avoid conflict with "expect". 304 */ 305 306 TclX_CreateObjCommand (interp, 307 "fork", 308 TclX_ForkObjCmd, 309 (ClientData) NULL, 310 (Tcl_CmdDeleteProc*) NULL, 0); 311 312 TclX_CreateObjCommand (interp, 313 "wait", 314 TclX_WaitObjCmd, 315 (ClientData) NULL, 316 (Tcl_CmdDeleteProc*) NULL, 0); 317} 318