home *** CD-ROM | disk | FTP | other *** search
/ InfoMagic Source Code 1993 July / THE_SOURCE_CODE_CD_ROM.iso / languages / tcl / tclX6.5c / src / tclXunixcmds.c < prev    next >
Encoding:
C/C++ Source or Header  |  1992-12-19  |  13.5 KB  |  527 lines
  1. /*
  2.  * tclXunixcmds.c --
  3.  *
  4.  * Tcl commands to access unix library calls.
  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: tclXunixcmds.c,v 2.0 1992/10/16 04:51:18 markd Rel $
  16.  *-----------------------------------------------------------------------------
  17.  */
  18.  
  19. #include "tclExtdInt.h"
  20.  
  21. /*
  22.  * A million microsecondss per seconds.
  23.  */
  24. #define TCL_USECS_PER_SEC (1000L * 1000L)
  25.  
  26. extern
  27. double floor ();
  28.  
  29. extern
  30. double ceil ();
  31.  
  32. /*
  33.  *-----------------------------------------------------------------------------
  34.  *
  35.  * Tcl_AlarmCmd --
  36.  *     Implements the TCL Alarm command:
  37.  *         alarm seconds
  38.  *
  39.  * Results:
  40.  *      Standard TCL results, may return the UNIX system error message.
  41.  *
  42.  *-----------------------------------------------------------------------------
  43.  */
  44. int
  45. Tcl_AlarmCmd (clientData, interp, argc, argv)
  46.     ClientData  clientData;
  47.     Tcl_Interp *interp;
  48.     int         argc;
  49.     char      **argv;
  50. {
  51. #ifdef TCL_NO_ITIMER
  52.     double            seconds;
  53.     unsigned          useconds;
  54.  
  55.     if (argc != 2) {
  56.         Tcl_AppendResult (interp, tclXWrongArgs, argv [0], " seconds", 
  57.                           (char *) NULL);
  58.         return TCL_ERROR;
  59.     }
  60.  
  61.     if (Tcl_GetDouble (interp, argv[1], &seconds) != TCL_OK)
  62.         return TCL_ERROR;
  63.  
  64.     useconds = ceil (seconds);
  65.     sprintf (interp->result, "%d", alarm (useconds));
  66.  
  67.     return TCL_OK;
  68. #else
  69.  
  70.     double            seconds, secFloor;
  71.     struct itimerval  timer, oldTimer;
  72.  
  73.     if (argc != 2) {
  74.         Tcl_AppendResult (interp, tclXWrongArgs, argv [0], " seconds", 
  75.                           (char *) NULL);
  76.         return TCL_ERROR;
  77.     }
  78.  
  79.     if (Tcl_GetDouble (interp, argv[1], &seconds) != TCL_OK)
  80.         return TCL_ERROR;
  81.  
  82.     secFloor =  floor (seconds);
  83.  
  84.     timer.it_value.tv_sec     = secFloor;
  85.     timer.it_value.tv_usec    = (long) ((seconds - secFloor) *
  86.                                         (double) TCL_USECS_PER_SEC);
  87.     timer.it_interval.tv_sec  = 0;
  88.     timer.it_interval.tv_usec = 0;  
  89.  
  90.  
  91.     if (setitimer (ITIMER_REAL, &timer, &oldTimer) < 0) {
  92.         interp->result = Tcl_UnixError (interp);
  93.         return TCL_ERROR;
  94.     }
  95.     seconds  = oldTimer.it_value.tv_sec;
  96.     seconds += ((double) oldTimer.it_value.tv_usec) /
  97.                ((double) TCL_USECS_PER_SEC);
  98.     sprintf (interp->result, "%g", seconds);
  99.  
  100.     return TCL_OK;
  101. #endif
  102.  
  103. }
  104.  
  105. /*
  106.  *-----------------------------------------------------------------------------
  107.  *
  108.  * Tcl_SleepCmd --
  109.  *     Implements the TCL sleep command:
  110.  *         sleep seconds
  111.  *
  112.  * Results:
  113.  *      Standard TCL results, may return the UNIX system error message.
  114.  *
  115.  *-----------------------------------------------------------------------------
  116.  */
  117. int
  118. Tcl_SleepCmd (clientData, interp, argc, argv)
  119.     ClientData  clientData;
  120.     Tcl_Interp *interp;
  121.     int         argc;
  122.     char      **argv;
  123. {
  124.     unsigned time;
  125.  
  126.     if (argc != 2) {
  127.         Tcl_AppendResult (interp, tclXWrongArgs, argv [0], " seconds", 
  128.                           (char *) NULL);
  129.         return TCL_ERROR;
  130.     }
  131.  
  132.     if (Tcl_GetUnsigned (interp, argv[1], &time) != TCL_OK)
  133.         return TCL_ERROR;
  134.  
  135.     sleep (time);
  136.     return TCL_OK;
  137.  
  138. }
  139.  
  140. /*
  141.  *-----------------------------------------------------------------------------
  142.  *
  143.  * Tcl_SystemCmd --
  144.  *     Implements the TCL system command:
  145.  *     system command
  146.  *
  147.  * Results:
  148.  *  Standard TCL results, may return the UNIX system error message.
  149.  *
  150.  *-----------------------------------------------------------------------------
  151.  */
  152. int
  153. Tcl_SystemCmd (clientData, interp, argc, argv)
  154.     ClientData  clientData;
  155.     Tcl_Interp *interp;
  156.     int         argc;
  157.     char      **argv;
  158. {
  159.     int exitCode;
  160.  
  161.     if (argc != 2) {
  162.         Tcl_AppendResult (interp, tclXWrongArgs, argv [0], " command",
  163.                           (char *) NULL);
  164.         return TCL_ERROR;
  165.     }
  166.  
  167.     exitCode = Tcl_System (interp, argv[1]);
  168.     if (exitCode == -1)
  169.         return TCL_ERROR;
  170.     sprintf (interp->result, "%d", exitCode);
  171.     return TCL_OK;
  172. }
  173.  
  174. /*
  175.  *-----------------------------------------------------------------------------
  176.  *
  177.  * Tcl_TimesCmd --
  178.  *     Implements the TCL times command:
  179.  *     times
  180.  *
  181.  * Results:
  182.  *  Standard TCL results.
  183.  *
  184.  *-----------------------------------------------------------------------------
  185.  */
  186. int
  187. Tcl_TimesCmd (clientData, interp, argc, argv)
  188.     ClientData  clientData;
  189.     Tcl_Interp *interp;
  190.     int         argc;
  191.     char      **argv;
  192. {
  193.     struct tms tm;
  194.  
  195.     if (argc != 1) {
  196.         Tcl_AppendResult (interp, tclXWrongArgs, argv[0], (char *) NULL);
  197.         return TCL_ERROR;
  198.     }
  199.  
  200.     times(&tm);
  201.  
  202.     sprintf(interp->result, "%ld %ld %ld %ld", 
  203.             tm.tms_utime  * MS_PER_TICK, 
  204.             tm.tms_stime  * MS_PER_TICK, 
  205.             tm.tms_cutime * MS_PER_TICK, 
  206.             tm.tms_cstime * MS_PER_TICK);
  207.     return TCL_OK;
  208. }
  209.  
  210. /*
  211.  *-----------------------------------------------------------------------------
  212.  *
  213.  * Tcl_UmaskCmd --
  214.  *     Implements the TCL umask command:
  215.  *     umask [octalmask]
  216.  *
  217.  * Results:
  218.  *  Standard TCL results, may return the UNIX system error message.
  219.  *
  220.  *-----------------------------------------------------------------------------
  221.  */
  222. int
  223. Tcl_UmaskCmd (clientData, interp, argc, argv)
  224.     ClientData  clientData;
  225.     Tcl_Interp *interp;
  226.     int         argc;
  227.     char      **argv;
  228. {
  229.     int mask;
  230.  
  231.     if ((argc < 1) || (argc > 2)) {
  232.         Tcl_AppendResult (interp, tclXWrongArgs, argv [0], " octalmask",
  233.                           (char *) NULL);
  234.         return TCL_ERROR;
  235.     }
  236.  
  237.     if (argc == 1) {
  238.         mask = umask (0);
  239.         umask ((unsigned short) mask);
  240.         sprintf (interp->result, "%o", mask);
  241.     } else {
  242.         if (!Tcl_StrToInt (argv [1], 8, &mask)) {
  243.             Tcl_AppendResult (interp, "Expected octal number got: ", argv [1],
  244.                               (char *) NULL);
  245.             return TCL_ERROR;
  246.         }
  247.  
  248.         umask ((unsigned short) mask);
  249.     }
  250.  
  251.     return TCL_OK;
  252. }
  253.  
  254. /*
  255.  *-----------------------------------------------------------------------------
  256.  *
  257.  * Tcl_LinkCmd --
  258.  *     Implements the TCL link command:
  259.  *         link [-sym] srcpath destpath
  260.  *
  261.  * Results:
  262.  *  Standard TCL results, may return the UNIX system error message.
  263.  *
  264.  *-----------------------------------------------------------------------------
  265.  */
  266. int
  267. Tcl_LinkCmd (clientData, interp, argc, argv)
  268.     ClientData  clientData;
  269.     Tcl_Interp *interp;
  270.     int         argc;
  271.     char      **argv;
  272. {
  273.     char *tmppath, *srcpath, *destpath;
  274.  
  275.     if ((argc < 3) || (argc > 4)) {
  276.         Tcl_AppendResult (interp, tclXWrongArgs, argv [0], 
  277.                           " [-sym] srcpath destpath", (char *) NULL);
  278.         return TCL_ERROR;
  279.     }
  280.     if (argc == 4) {
  281.         if (!STREQU (argv [1], "-sym")) {
  282.             Tcl_AppendResult (interp, "invalid option, expected: \"-sym\", ",
  283.                               "got: ", argv [1], (char *) NULL);
  284.             return TCL_ERROR;
  285.         }
  286. #ifndef S_IFLNK
  287.         Tcl_AppendResult (interp, "symbolic links are not supported on this",
  288.                           " system", (char *) NULL);
  289.         return TCL_ERROR;
  290. #endif
  291.     }
  292.  
  293.     tmppath = Tcl_TildeSubst (interp, argv [argc - 2]);
  294.     if (tmppath == NULL)
  295.         return TCL_ERROR;
  296.     srcpath = ckalloc (strlen (tmppath) + 1);
  297.     strcpy (srcpath, tmppath);
  298.  
  299.     destpath = Tcl_TildeSubst (interp, argv [argc - 1]);
  300.     if (destpath == NULL)
  301.         goto errorExit;
  302.  
  303.     if (argc == 4) {
  304. #ifdef S_IFLNK
  305.         if (symlink (srcpath, destpath) != 0)
  306.            goto unixError;
  307. #endif
  308.     } else {
  309.         if (link (srcpath, destpath) != 0)
  310.            goto unixError;
  311.     }
  312.     ckfree (srcpath);
  313.     return TCL_OK;
  314.  
  315. unixError:
  316.     interp->result = Tcl_UnixError (interp);
  317.  
  318. errorExit:
  319.     ckfree (srcpath);
  320.     return TCL_ERROR;
  321. }
  322.  
  323. /*
  324.  *-----------------------------------------------------------------------------
  325.  *
  326.  * Tcl_UnlinkCmd --
  327.  *     Implements the TCL unlink command:
  328.  *         unlink [-nocomplain] fileList
  329.  *
  330.  * Results:
  331.  *  Standard TCL results, may return the UNIX system error message.
  332.  *
  333.  *-----------------------------------------------------------------------------
  334.  */
  335. int
  336. Tcl_UnlinkCmd (clientData, interp, argc, argv)
  337.     ClientData  clientData;
  338.     Tcl_Interp *interp;
  339.     int         argc;
  340.     char      **argv;
  341. {
  342.     int    idx, fileArgc;
  343.     char **fileArgv, *fileName;
  344.     int    noComplain;
  345.     
  346.     if ((argc < 2) || (argc > 3))
  347.         goto badArgs;
  348.  
  349.     if (argc == 3) {
  350.         if (!STREQU (argv [1], "-nocomplain"))
  351.             goto badArgs;
  352.         noComplain = TRUE;
  353.     } else {
  354.         noComplain = FALSE;
  355.     }
  356.  
  357.     if (Tcl_SplitList (interp, argv [argc - 1], &fileArgc,
  358.                        &fileArgv) != TCL_OK)
  359.         return TCL_ERROR;
  360.  
  361.     for (idx = 0; idx < fileArgc; idx++) {
  362.         fileName = Tcl_TildeSubst (interp, fileArgv [idx]);
  363.         if (fileName == NULL) {
  364.             if (!noComplain)
  365.                 goto errorExit;
  366.             continue;
  367.         }
  368.         if ((unlink (fileName) != 0) && !noComplain) {
  369.             Tcl_AppendResult (interp, fileArgv [idx], ": ",
  370.                               Tcl_UnixError (interp), (char *) NULL);
  371.             goto errorExit;
  372.         }
  373.     }
  374.  
  375.     ckfree ((char *) fileArgv);
  376.     return TCL_OK;
  377.  
  378. errorExit:
  379.     ckfree ((char *) fileArgv);
  380.     return TCL_ERROR;
  381.  
  382. badArgs:
  383.     Tcl_AppendResult (interp, tclXWrongArgs, argv [0], 
  384.                       " [-nocomplain] filelist", (char *) NULL);
  385.     return TCL_ERROR;
  386. }
  387.  
  388. /*
  389.  *-----------------------------------------------------------------------------
  390.  *
  391.  * Tcl_MkdirCmd --
  392.  *     Implements the TCL Mkdir command:
  393.  *         mkdir [-path] dirList
  394.  *
  395.  * Results:
  396.  *  Standard TCL results, may return the UNIX system error message.
  397.  *
  398.  *-----------------------------------------------------------------------------
  399.  */
  400. int
  401. Tcl_MkdirCmd (clientData, interp, argc, argv)
  402.     ClientData  clientData;
  403.     Tcl_Interp *interp;
  404.     int         argc;
  405.     char      **argv;
  406. {
  407.     int           idx, dirArgc, result;
  408.     char        **dirArgv, *scanPtr;
  409.     struct stat   statBuf;
  410.  
  411.     if ((argc < 2) || (argc > 3))
  412.         goto usageError;
  413.     if ((argc == 3) && !STREQU (argv [1], "-path"))
  414.         goto usageError;
  415.  
  416.     if (Tcl_SplitList (interp, argv [argc - 1], &dirArgc, &dirArgv) != TCL_OK)
  417.         return TCL_ERROR;
  418.     /*
  419.      * Make all the directories, optionally making directories along the path.
  420.      */
  421.  
  422.     for (idx = 0; idx < dirArgc; idx++) {
  423.         /*
  424.          * Make leading directories, if requested.
  425.          */
  426.         if (argc == 3) {
  427.             scanPtr = dirArgv [idx];
  428.             result = 0;  /* Start out ok, for dirs that are skipped */
  429.  
  430.             while (*scanPtr != '\0') {
  431.                 scanPtr = strchr (scanPtr+1, '/');
  432.                 if ((scanPtr == NULL) || (*(scanPtr+1) == '\0'))
  433.                     break;
  434.                 *scanPtr = '\0';
  435.                 if (stat (dirArgv [idx], &statBuf) < 0)
  436.                     result = mkdir (dirArgv [idx], S_IFDIR | 0777);
  437.                 *scanPtr = '/';
  438.                 if (result < 0)
  439.                    goto mkdirError;
  440.             }
  441.         }
  442.         /*
  443.          * Make final directory in the path.
  444.          */
  445.         if (mkdir (dirArgv [idx], S_IFDIR | 0777) != 0)
  446.            goto mkdirError;
  447.     }
  448.  
  449.     ckfree ((char *) dirArgv);
  450.     return TCL_OK;
  451.  
  452. mkdirError:
  453.     Tcl_AppendResult (interp, dirArgv [idx], ": ", Tcl_UnixError (interp),
  454.                       (char *) NULL);
  455.     ckfree ((char *) dirArgv);
  456.     return TCL_ERROR;
  457.  
  458. usageError:
  459.     Tcl_AppendResult (interp, tclXWrongArgs, argv [0], 
  460.                       " [-path] dirlist", (char *) NULL);
  461.     return TCL_ERROR;
  462. }
  463.  
  464. /*
  465.  *-----------------------------------------------------------------------------
  466.  *
  467.  * Tcl_RmdirCmd --
  468.  *     Implements the TCL Rmdir command:
  469.  *         rmdir [-nocomplain]  dirList
  470.  *
  471.  * Results:
  472.  *  Standard TCL results, may return the UNIX system error message.
  473.  *
  474.  *-----------------------------------------------------------------------------
  475.  */
  476. int
  477. Tcl_RmdirCmd (clientData, interp, argc, argv)
  478.     ClientData  clientData;
  479.     Tcl_Interp *interp;
  480.     int         argc;
  481.     char      **argv;
  482. {
  483.     int    idx, dirArgc;
  484.     char **dirArgv, *dirName;
  485.     int    noComplain;
  486.     
  487.     if ((argc < 2) || (argc > 3))
  488.         goto badArgs;
  489.  
  490.     if (argc == 3) {
  491.         if (!STREQU (argv [1], "-nocomplain"))
  492.             goto badArgs;
  493.         noComplain = TRUE;
  494.     } else {
  495.         noComplain = FALSE;
  496.     }
  497.  
  498.     if (Tcl_SplitList (interp, argv [argc - 1], &dirArgc, &dirArgv) != TCL_OK)
  499.         return TCL_ERROR;
  500.  
  501.     for (idx = 0; idx < dirArgc; idx++) {
  502.         dirName = Tcl_TildeSubst (interp, dirArgv [idx]);
  503.         if (dirName == NULL) {
  504.             if (!noComplain)
  505.                 goto errorExit;
  506.             continue;
  507.         }
  508.         if ((rmdir (dirName) != 0) && !noComplain) {
  509.            Tcl_AppendResult (interp, dirArgv [idx], ": ",
  510.                              Tcl_UnixError (interp), (char *) NULL);
  511.            goto errorExit;
  512.         }
  513.     }
  514.  
  515.     ckfree ((char *) dirArgv);
  516.     return TCL_OK;
  517.  
  518. errorExit:
  519.     ckfree ((char *) dirArgv);
  520.     return TCL_ERROR;;
  521.  
  522. badArgs:
  523.     Tcl_AppendResult (interp, tclXWrongArgs, argv [0], 
  524.                       " [-nocomplain] dirlist", (char *) NULL);
  525.     return TCL_ERROR;
  526. }
  527.