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
31 static int
32 TclX_ExeclObjCmd _ANSI_ARGS_((ClientData clientData,
33 Tcl_Interp *interp,
34 int objc,
35 Tcl_Obj *CONST objv[]));
36
37 static int
38 TclX_ForkObjCmd _ANSI_ARGS_((ClientData clientData,
39 Tcl_Interp *interp,
40 int objc,
41 Tcl_Obj *CONST objv[]));
42
43 static int
44 TclX_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 */
56 static int
TclX_ForkObjCmd(clientData,interp,objc,objv)57 TclX_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 */
75 static int
TclX_ExeclObjCmd(clientData,interp,objc,objv)76 TclX_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 */
164 static int
TclX_WaitObjCmd(clientData,interp,objc,objv)165 TclX_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 */
293 void
TclX_ProcessInit(interp)294 TclX_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