home *** CD-ROM | disk | FTP | other *** search
/ Complete Linux / Complete Linux.iso / docs / devel / tcl / tclx7_31.z / tclx7_31 / tcldev / tclX7.3a-p1 / src / tclXprocess.c < prev    next >
Encoding:
C/C++ Source or Header  |  1993-11-19  |  7.8 KB  |  292 lines
  1. /*
  2.  * tclXprocess.c --
  3.  *
  4.  * Tcl command to create and manage processes.
  5.  *-----------------------------------------------------------------------------
  6.  * Copyright 1991-1993 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 3.0 1993/11/19 06:59:07 markd Rel $
  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.  
  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.     char          *path;
  56.     char          *argv0       = NULL;
  57.     int            nextArg     = 1;
  58.     int            argInCnt, idx;
  59.     Tcl_DString    tildeBuf;
  60.  
  61.     if (argc < 2)
  62.         goto wrongArgs;
  63.  
  64.     if (STREQU ("-argv0", argv [1])) {
  65.         if (argc < 4)
  66.             goto wrongArgs;
  67.         argv0 = argv [2];
  68.         nextArg = 3;
  69.     }
  70.     if ((argc - nextArg) > 2)
  71.         goto wrongArgs;
  72.  
  73.     Tcl_DStringInit (&tildeBuf);
  74.  
  75.     /*
  76.      * If arg list is supplied, split it and build up the arguments to pass.
  77.      * otherwise, just supply argv[0].  Must be NULL terminated.
  78.      */
  79.     if (argc - 1 > nextArg) {
  80.         if (Tcl_SplitList (interp, argv [nextArg + 1],
  81.                            &argInCnt, &argInList) != TCL_OK)
  82.             goto errorExit;
  83.  
  84.         if (argInCnt > STATIC_ARG_SIZE - 2)
  85.             argList = (char **) ckalloc ((argInCnt + 1) * sizeof (char **));
  86.             
  87.         for (idx = 0; idx < argInCnt; idx++)
  88.             argList [idx + 1] = argInList [idx];
  89.  
  90.         argList [argInCnt + 1] = NULL;
  91.     } else {
  92.         argList [1] = NULL;
  93.     }
  94.  
  95.     path = argv [nextArg];
  96.     if (path [0] == '~') {
  97.         path = Tcl_TildeSubst (interp, path, &tildeBuf);
  98.         if (path == NULL)
  99.             goto errorExit;
  100.     }
  101.  
  102.     if (argv0 != NULL) {
  103.         argList [0] = argv0;
  104.     } else {
  105.     argList [0] = argv [nextArg];  /* Program name */
  106.     }
  107.  
  108.     execvp (path, argList);
  109.  
  110.     /*
  111.      * Can only make it here on an error.
  112.      */
  113.     interp->result = Tcl_PosixError (interp);
  114.  
  115.     if (argInList != NULL)
  116.         ckfree (argInList);
  117.     if (argList != staticArgv)
  118.         ckfree (argList);
  119.  
  120.   errorExit:
  121.     Tcl_DStringFree (&tildeBuf);
  122.     return TCL_ERROR;
  123.  
  124.   wrongArgs:
  125.     Tcl_AppendResult (interp, tclXWrongArgs, argv [0], 
  126.                       " ?-argv0 argv0? prog ?argList?",
  127.                       (char *) NULL);
  128.     return TCL_ERROR;
  129. }
  130.  
  131. /*
  132.  *-----------------------------------------------------------------------------
  133.  *
  134.  * Tcl_ForkCmd --
  135.  *     Implements the TCL fork command:
  136.  *     fork
  137.  *
  138.  * Results:
  139.  *  Standard TCL results, may return the UNIX system error message.
  140.  *
  141.  *-----------------------------------------------------------------------------
  142.  */
  143. int
  144. Tcl_ForkCmd (clientData, interp, argc, argv)
  145.     ClientData  clientData;
  146.     Tcl_Interp *interp;
  147.     int         argc;
  148.     char      **argv;
  149. {
  150.     int pid;
  151.  
  152.     if (argc != 1) {
  153.         Tcl_AppendResult (interp, tclXWrongArgs, argv [0], (char *) NULL);
  154.         return TCL_ERROR;
  155.     }
  156.  
  157.     pid = fork ();
  158.     if (pid < 0) {
  159.         interp->result = Tcl_PosixError (interp);
  160.         return TCL_ERROR;
  161.     }
  162.  
  163.     sprintf(interp->result, "%d", pid);
  164.     return TCL_OK;
  165. }
  166.  
  167. /*
  168.  *-----------------------------------------------------------------------------
  169.  *
  170.  * Tcl_WaitCmd --
  171.  *   Implements the TCL wait command:
  172.  *     wait ?-nohang? ?-untraced? ?-pgroup? ?pid?
  173.  *
  174.  * Results:
  175.  *   Standard TCL results, may return the UNIX system error message.
  176.  *
  177.  *-----------------------------------------------------------------------------
  178.  */
  179. int
  180. Tcl_WaitCmd (clientData, interp, argc, argv)
  181.     ClientData  clientData;
  182.     Tcl_Interp *interp;
  183.     int         argc;
  184.     char      **argv;
  185. {
  186.     WAIT_STATUS_TYPE  status;
  187.     int               idx, tmpPid, options = 0, pgroup = FALSE;
  188.     pid_t             pid, returnedPid;
  189.     
  190.     for (idx = 1; idx < argc; idx++) {
  191.         if (argv [idx][0] != '-')
  192.             break;
  193.         if (STREQU ("-nohang", argv [idx])) {
  194.             if (options & WNOHANG)
  195.                 goto usage;
  196.             options |= WNOHANG;
  197.             continue;
  198.         }
  199.         if (STREQU ("-untraced", argv [idx])) {
  200.             if (options & WUNTRACED)
  201.                 goto usage;
  202.             options |= WUNTRACED;
  203.             continue;
  204.         }
  205.         if (STREQU ("-pgroup", argv [idx])) {
  206.             if (pgroup)
  207.                 goto usage;
  208.             pgroup = TRUE;
  209.             continue;
  210.         }
  211.         goto usage;  /* None match */
  212.     }
  213.     /*
  214.      * Check for more than one non-minus argument.  If ok, convert pid,
  215.      * if supplied.
  216.      */
  217.     if (idx < argc - 1)
  218.         goto usage;  
  219.     if (idx < argc) {
  220.         if (!Tcl_StrToInt (argv [idx], 10, &tmpPid))
  221.             goto invalidPid;
  222.         if (tmpPid <= 0)
  223.             goto negativePid;
  224.         pid = (pid_t) tmpPid;
  225.         if ((int) pid != tmpPid)
  226.             goto invalidPid;
  227.     } else {
  228.         pid = -1;  /* pid or pgroup not supplied */
  229.     }
  230.  
  231.     /*
  232.      * Versions that don't have real waitpid have limited functionality.
  233.      */
  234. #if NO_WAITPID
  235.     if ((options != 0) || pgroup) {
  236.         Tcl_AppendResult (interp, "The \"-nohang\", \"-untraced\" and ",
  237.                           "\"-pgroup\" options are not available on this ",
  238.                           "system", (char *) NULL);
  239.         return TCL_ERROR;
  240.     }
  241. #endif
  242.  
  243.     if (pgroup) {
  244.         if (pid > 0)
  245.             pid = -pid;
  246.         else
  247.             pid = 0;
  248.     }
  249.  
  250.     returnedPid = waitpid (pid, &status, options);
  251.  
  252.     if (returnedPid < 0) {
  253.         interp->result = Tcl_PosixError (interp);
  254.         return TCL_ERROR;
  255.     }
  256.  
  257.     /*
  258.      * If no process was available, return an empty status.  Otherwise return
  259.      * a list contain the PID and why it stopped.
  260.      */
  261.     if (returnedPid == 0)
  262.         return TCL_OK;
  263.     
  264.     if (WIFEXITED (status))
  265.         sprintf (interp->result, "%d %s %d", returnedPid, "EXIT", 
  266.                  WEXITSTATUS (status));
  267.     else if (WIFSIGNALED (status))
  268.         sprintf (interp->result, "%d %s %s", returnedPid, "SIG", 
  269.                  Tcl_SignalId (WTERMSIG (status)));
  270.     else if (WIFSTOPPED (status))
  271.         sprintf (interp->result, "%d %s %s", returnedPid, "STOP", 
  272.                  Tcl_SignalId (WSTOPSIG (status)));
  273.  
  274.     return TCL_OK;
  275.  
  276. usage:
  277.     Tcl_AppendResult (interp, tclXWrongArgs, argv [0], " ", 
  278.                       "?-nohang? ?-untraced? ?-pgroup? ?pid?",
  279.                       (char *) NULL);
  280.     return TCL_ERROR;
  281.  
  282.   invalidPid:
  283.     Tcl_AppendResult (interp, "invalid pid or process group id \"",
  284.                       argv [idx], "\"", (char *) NULL);
  285.     return TCL_ERROR;
  286.  
  287.   negativePid:
  288.     Tcl_AppendResult (interp, "pid or process group id must be greater ",
  289.                       "than zero", (char *) NULL);
  290.     return TCL_ERROR;
  291. }
  292.