git.zerfleddert.de Git - micropolis/blob - src/tclx/src/tclxproc.c

   1 /*
   2  * tclXprocess.c --
   3  *
   4  * Tcl command to create and manage processes.
   5  *-----------------------------------------------------------------------------
   6  * Copyright 1992 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 2.2 1992/10/30 03:53:30 markd Exp $
  16  *-----------------------------------------------------------------------------
  17  */
  18
  19 #include "tclxint.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 \f
  32 /*
  33  *-----------------------------------------------------------------------------
  34  *
  35  * Tcl_ExeclCmd --
  36  *     Implements the TCL execl command:
  37  *     execl prog [argList]
  38  *
  39  * Results:
  40  *  Standard TCL results, may return the UNIX system error message.
  41  *
  42  *-----------------------------------------------------------------------------
  43  */
  44 int
  45 Tcl_ExeclCmd (clientData, interp, argc, argv)
  46     ClientData  clientData;
  47     Tcl_Interp *interp;
  48     int         argc;
  49     char      **argv;
  50 {
  51 #define STATIC_ARG_SIZE   12
  52     char  *staticArgv [STATIC_ARG_SIZE];
  53     char **argInList = NULL;
  54     char **argList   = staticArgv;
  55     int    argInCnt, idx;
  56
  57     if ((argc < 2) || (argc > 3)) {
  58         Tcl_AppendResult (interp, tclXWrongArgs, argv [0],
  59                           " prog [argList]", (char *) NULL);
  60         return TCL_ERROR;
  61     }
  62
  63     /*
  64      * If arg list is supplied, split it and build up the arguments to pass.
  65      * otherwise, just supply argv[0].  Must be NULL terminated.
  66      */
  67     if (argc > 2) {
  68         if (Tcl_SplitList (interp, argv [2], &argInCnt, &argInList) != TCL_OK)
  69             return TCL_ERROR;
  70
  71         if (argInCnt > STATIC_ARG_SIZE - 2)
  72             argList = (char **) ckalloc ((argInCnt + 1) * sizeof (char **));
  73
  74         for (idx = 0; idx < argInCnt; idx++)
  75             argList [idx + 1] = argInList [idx];
  76
  77         argList [argInCnt + 1] = NULL;
  78     } else {
  79         argList [1] = NULL;
  80     }
  81
  82     argList [0] = argv [1];  /* Program name */
  83
  84     if (execvp (argv[1], argList) < 0) {
  85         if (argInList != NULL)
  86             ckfree (argInList);
  87         if (argList != staticArgv)
  88             ckfree (argList);
  89
  90         interp->result = Tcl_UnixError (interp);
  91         return TCL_ERROR;
  92     }
  93
  94 }
  95 \f
  96 /*
  97  *-----------------------------------------------------------------------------
  98  *
  99  * Tcl_ForkCmd --
 100  *     Implements the TCL fork command:
 101  *     fork
 102  *
 103  * Results:
 104  *  Standard TCL results, may return the UNIX system error message.
 105  *
 106  *-----------------------------------------------------------------------------
 107  */
 108 int
 109 Tcl_ForkCmd (clientData, interp, argc, argv)
 110     ClientData  clientData;
 111     Tcl_Interp *interp;
 112     int         argc;
 113     char      **argv;
 114 {
 115     int pid;
 116
 117     if (argc != 1) {
 118         Tcl_AppendResult (interp, tclXWrongArgs, argv [0], (char *) NULL);
 119         return TCL_ERROR;
 120     }
 121
 122     pid = Tcl_Fork ();
 123     if (pid < 0) {
 124         interp->result = Tcl_UnixError (interp);
 125         return TCL_ERROR;
 126     }
 127
 128     sprintf(interp->result, "%d", pid);
 129     return TCL_OK;
 130 }
 131 #ifndef TCL_HAVE_WAITPID
 132 \f
 133 /*
 134  *-----------------------------------------------------------------------------
 135  *
 136  * Tcl_WaitCmd --
 137  *   Implements the TCL wait command:
 138  *     wait pid
 139  *
 140  * This version is for Tcl 6.4 that does not have the waitpid changes (which
 141  * have not yet been released).
 142  *
 143  * Results:
 144  *   Standard TCL results, may return the UNIX system error message.
 145  *
 146  *-----------------------------------------------------------------------------
 147  */
 148 int
 149 Tcl_WaitCmd (clientData, interp, argc, argv)
 150     ClientData  clientData;
 151     Tcl_Interp *interp;
 152     int         argc;
 153     char      **argv;
 154 {
 155     WAIT_STATUS_TYPE  status;
 156     int               pid, returnedPid;
 157
 158
 159     if (argc != 2) {
 160         Tcl_AppendResult (interp, tclXWrongArgs, argv [0], " pid",
 161                           (char *) NULL);
 162         return TCL_ERROR;
 163     }
 164
 165     if (Tcl_GetInt (interp, argv [1], &pid) != TCL_OK)
 166         return TCL_ERROR;
 167
 168     returnedPid = Tcl_WaitPids (1, &pid, (WAIT_STATUS_TYPE *) &status);
 169
 170     if (returnedPid < 0) {
 171         interp->result = Tcl_UnixError (interp);
 172         return TCL_ERROR;
 173     }
 174
 175     if (WIFEXITED (status))
 176         sprintf (interp->result, "%d %s %d", returnedPid, "EXIT",
 177                  WEXITSTATUS (status));
 178     else if (WIFSIGNALED (status))
 179         sprintf (interp->result, "%d %s %s", returnedPid, "SIG",
 180                  Tcl_SignalId (WTERMSIG (status)));
 181     else if (WIFSTOPPED (status))
 182         sprintf (interp->result, "%d %s %s", returnedPid, "STOP",
 183                  Tcl_SignalId (WSTOPSIG (status)));
 184
 185     return TCL_OK;
 186
 187 }
 188 #else
 189 \f
 190 /*
 191  *-----------------------------------------------------------------------------
 192  *
 193  * Tcl_WaitCmd --
 194  *   Implements the TCL wait command:
 195  *     wait [-nohang] [-untraced] [-pgroup] [pid]
 196  *
 197  * Results:
 198  *   Standard TCL results, may return the UNIX system error message.
 199  *
 200  *-----------------------------------------------------------------------------
 201  */
 202 int
 203 Tcl_WaitCmd (clientData, interp, argc, argv)
 204     ClientData  clientData;
 205     Tcl_Interp *interp;
 206     int         argc;
 207     char      **argv;
 208 {
 209     int      pid, returnedPid, status, idx;
 210     int      options = 0, pgroup = FALSE;
 211
 212     for (idx = 1; idx < argc; idx++) {
 213         if (argv [idx][0] != '-')
 214             break;
 215         if (STREQU ("-nohang", argv [idx])) {
 216             if (options & WNOHANG)
 217                 goto usage;
 218             options |= WNOHANG;
 219             continue;
 220         }
 221         if (STREQU ("-untraced", argv [idx])) {
 222             if (options & WUNTRACED)
 223                 goto usage;
 224             options |= WUNTRACED;
 225             continue;
 226         }
 227         if (STREQU ("-pgroup", argv [idx])) {
 228             if (pgroup)
 229                 goto usage;
 230             pgroup = TRUE;
 231             continue;
 232         }
 233         goto usage;  /* None match */
 234     }
 235     /*
 236      * Check for more than one non-minus argument.  If ok, convert pid,
 237      * if supplied.
 238      */
 239     if (idx < argc - 1)
 240         goto usage;
 241     if (idx < argc) {
 242         if (Tcl_GetInt (interp, argv [idx], &pid) != TCL_OK)
 243             return TCL_ERROR;
 244         if (pid <= 0) {
 245             Tcl_AppendResult (interp, "pid or process group must be greater ",
 246                               "than zero", (char *) NULL);
 247             return TCL_ERROR;
 248         }
 249     } else {
 250         pid = -1;  /* pid not supplied */
 251     }
 252
 253 #if !TCL_HAVE_WAITPID
 254     /*
 255      * Versions that don't have real waitpid have limited functionality.
 256      */
 257     if ((options != 0) || pgroup) {
 258         Tcl_AppendResult (interp, "The \"-nohang\", \"-untraced\" and ",
 259                           "\"-pgroup\" options are not available on this ",
 260                           "system", (char *) NULL);
 261         return TCL_ERROR;
 262     }
 263 #endif
 264
 265     if (pgroup) {
 266         if (pid > 0)
 267             pid = -pgroup;
 268         else
 269             pid = 0;
 270     }
 271
 272     returnedPid = waitpid (pid, &status, options);
 273
 274     if (returnedPid < 0) {
 275         interp->result = Tcl_UnixError (interp);
 276         return TCL_ERROR;
 277     }
 278
 279     if (WIFEXITED (status))
 280         sprintf (interp->result, "%d %s %d", returnedPid, "EXIT",
 281                  WEXITSTATUS (status));
 282     else if (WIFSIGNALED (status))
 283         sprintf (interp->result, "%d %s %s", returnedPid, "SIG",
 284                  Tcl_SignalId (WTERMSIG (status)));
 285     else if (WIFSTOPPED (status))
 286         sprintf (interp->result, "%d %s %s", returnedPid, "STOP",
 287                  Tcl_SignalId (WSTOPSIG (status)));
 288
 289     return TCL_OK;
 290
 291 usage:
 292     Tcl_AppendResult (interp, tclXWrongArgs, argv [0], " ",
 293                       "[-nohang] [-untraced] [-pgroup] [pid]",
 294                       (char *) NULL);
 295     return TCL_ERROR;
 296 }
 297 #endif