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