home *** CD-ROM | disk | FTP | other *** search
/ Mac-Source 1994 July / Mac-Source_July_1994.iso / Other Langs / Tickle-4.0 (tcl) / tcl / extend / src.unused / tclXunixcmds.c < prev   
Encoding:
C/C++ Source or Header  |  1993-10-26  |  14.4 KB  |  558 lines  |  [TEXT/MPS ]

  1. /*
  2.  * tclXunixcmds.c --
  3.  *
  4.  * Tcl commands to access unix library calls.
  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: tclXunixcmds.c,v 2.6 1993/07/30 15:05:15 markd Exp $
  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. #ifndef HAVE_SETITIMER
  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_PosixError (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 = system (argv [1]);
  168.     if (exitCode == -1) {
  169.         interp->result = Tcl_PosixError (interp);
  170.         return TCL_ERROR;
  171.     }
  172.     sprintf (interp->result, "%d", exitCode);
  173.     return TCL_OK;
  174. }
  175.  
  176. /*
  177.  *-----------------------------------------------------------------------------
  178.  *
  179.  * Tcl_TimesCmd --
  180.  *     Implements the TCL times command:
  181.  *     times
  182.  *
  183.  * Results:
  184.  *  Standard TCL results.
  185.  *
  186.  *-----------------------------------------------------------------------------
  187.  */
  188. int
  189. Tcl_TimesCmd (clientData, interp, argc, argv)
  190.     ClientData  clientData;
  191.     Tcl_Interp *interp;
  192.     int         argc;
  193.     char      **argv;
  194. {
  195.     struct tms tm;
  196.  
  197.     if (argc != 1) {
  198.         Tcl_AppendResult (interp, tclXWrongArgs, argv[0], (char *) NULL);
  199.         return TCL_ERROR;
  200.     }
  201.  
  202.     times(&tm);
  203.  
  204.     sprintf(interp->result, "%ld %ld %ld %ld", 
  205.             tm.tms_utime  * MS_PER_TICK, 
  206.             tm.tms_stime  * MS_PER_TICK, 
  207.             tm.tms_cutime * MS_PER_TICK, 
  208.             tm.tms_cstime * MS_PER_TICK);
  209.     return TCL_OK;
  210. }
  211.  
  212. /*
  213.  *-----------------------------------------------------------------------------
  214.  *
  215.  * Tcl_UmaskCmd --
  216.  *     Implements the TCL umask command:
  217.  *     umask ?octalmask?
  218.  *
  219.  * Results:
  220.  *  Standard TCL results, may return the UNIX system error message.
  221.  *
  222.  *-----------------------------------------------------------------------------
  223.  */
  224. int
  225. Tcl_UmaskCmd (clientData, interp, argc, argv)
  226.     ClientData  clientData;
  227.     Tcl_Interp *interp;
  228.     int         argc;
  229.     char      **argv;
  230. {
  231.     int mask;
  232.  
  233.     if ((argc < 1) || (argc > 2)) {
  234.         Tcl_AppendResult (interp, tclXWrongArgs, argv [0], " ?octalmask?",
  235.                           (char *) NULL);
  236.         return TCL_ERROR;
  237.     }
  238.  
  239.     if (argc == 1) {
  240.         mask = umask (0);
  241.         umask ((unsigned short) mask);
  242.         sprintf (interp->result, "%o", mask);
  243.     } else {
  244.         if (!Tcl_StrToInt (argv [1], 8, &mask)) {
  245.             Tcl_AppendResult (interp, "Expected octal number got: ", argv [1],
  246.                               (char *) NULL);
  247.             return TCL_ERROR;
  248.         }
  249.  
  250.         umask ((unsigned short) mask);
  251.     }
  252.  
  253.     return TCL_OK;
  254. }
  255.  
  256. /*
  257.  *-----------------------------------------------------------------------------
  258.  *
  259.  * Tcl_LinkCmd --
  260.  *     Implements the TCL link command:
  261.  *         link ?-sym? srcpath destpath
  262.  *
  263.  * Results:
  264.  *  Standard TCL results, may return the UNIX system error message.
  265.  *
  266.  *-----------------------------------------------------------------------------
  267.  */
  268. int
  269. Tcl_LinkCmd (clientData, interp, argc, argv)
  270.     ClientData  clientData;
  271.     Tcl_Interp *interp;
  272.     int         argc;
  273.     char      **argv;
  274. {
  275.     char        *srcPath,    *destPath;
  276.     Tcl_DString  srcPathBuf,  destPathBuf;
  277.  
  278.     Tcl_DStringInit (&srcPathBuf);
  279.     Tcl_DStringInit (&destPathBuf);
  280.  
  281.     if ((argc < 3) || (argc > 4)) {
  282.         Tcl_AppendResult (interp, tclXWrongArgs, argv [0], 
  283.                           " ?-sym? srcpath destpath", (char *) NULL);
  284.         return TCL_ERROR;
  285.     }
  286.     if (argc == 4) {
  287.         if (!STREQU (argv [1], "-sym")) {
  288.             Tcl_AppendResult (interp, "invalid option, expected: \"-sym\", ",
  289.                               "got: ", argv [1], (char *) NULL);
  290.             return TCL_ERROR;
  291.         }
  292. #ifndef S_IFLNK
  293.         Tcl_AppendResult (interp, "symbolic links are not supported on this",
  294.                           " system", (char *) NULL);
  295.         return TCL_ERROR;
  296. #endif
  297.     }
  298.  
  299.     srcPath = Tcl_TildeSubst (interp, argv [argc - 2], &srcPathBuf);
  300.     if (srcPath == NULL)
  301.         goto errorExit;
  302.  
  303.     destPath = Tcl_TildeSubst (interp, argv [argc - 1], &destPathBuf);
  304.     if (destPath == NULL)
  305.         goto errorExit;
  306.  
  307.     if (argc == 4) {
  308. #ifdef S_IFLNK
  309.         if (symlink (srcPath, destPath) != 0)
  310.            goto unixError;
  311. #endif
  312.     } else {
  313.         if (link (srcPath, destPath) != 0)
  314.            goto unixError;
  315.     }
  316.  
  317.     Tcl_DStringFree (&srcPathBuf);
  318.     Tcl_DStringFree (&destPathBuf);
  319.     return TCL_OK;
  320.  
  321.   unixError:
  322.     interp->result = Tcl_PosixError (interp);
  323.  
  324.   errorExit:
  325.     Tcl_DStringFree (&srcPathBuf);
  326.     Tcl_DStringFree (&destPathBuf);
  327.     return TCL_ERROR;
  328. }
  329.  
  330. /*
  331.  *-----------------------------------------------------------------------------
  332.  *
  333.  * Tcl_UnlinkCmd --
  334.  *     Implements the TCL unlink command:
  335.  *         unlink ?-nocomplain? fileList
  336.  *
  337.  * Results:
  338.  *  Standard TCL results, may return the UNIX system error message.
  339.  *
  340.  *-----------------------------------------------------------------------------
  341.  */
  342. int
  343. Tcl_UnlinkCmd (clientData, interp, argc, argv)
  344.     ClientData  clientData;
  345.     Tcl_Interp *interp;
  346.     int         argc;
  347.     char      **argv;
  348. {
  349.     int           idx, fileArgc;
  350.     char        **fileArgv, *fileName;
  351.     int           noComplain;
  352.     Tcl_DString   tildeBuf;
  353.  
  354.     Tcl_DStringInit (&tildeBuf);
  355.     
  356.     if ((argc < 2) || (argc > 3))
  357.         goto badArgs;
  358.  
  359.     if (argc == 3) {
  360.         if (!STREQU (argv [1], "-nocomplain"))
  361.             goto badArgs;
  362.         noComplain = TRUE;
  363.     } else {
  364.         noComplain = FALSE;
  365.     }
  366.  
  367.     if (Tcl_SplitList (interp, argv [argc - 1], &fileArgc,
  368.                        &fileArgv) != TCL_OK)
  369.         return TCL_ERROR;
  370.  
  371.     for (idx = 0; idx < fileArgc; idx++) {
  372.         fileName = Tcl_TildeSubst (interp, fileArgv [idx], &tildeBuf);
  373.         if (fileName == NULL) {
  374.             if (!noComplain)
  375.                 goto errorExit;
  376.             Tcl_DStringFree (&tildeBuf);
  377.             continue;
  378.         }
  379.         if ((unlink (fileName) != 0) && !noComplain) {
  380.             Tcl_AppendResult (interp, fileArgv [idx], ": ",
  381.                               Tcl_PosixError (interp), (char *) NULL);
  382.             goto errorExit;
  383.         }
  384.         Tcl_DStringFree (&tildeBuf);
  385.     }
  386.  
  387.     ckfree ((char *) fileArgv);
  388.     return TCL_OK;
  389.  
  390.   errorExit:
  391.     Tcl_DStringFree (&tildeBuf);
  392.     ckfree ((char *) fileArgv);
  393.     return TCL_ERROR;
  394.  
  395.   badArgs:
  396.     Tcl_AppendResult (interp, tclXWrongArgs, argv [0], 
  397.                       " ?-nocomplain? filelist", (char *) NULL);
  398.     return TCL_ERROR;
  399. }
  400.  
  401. /*
  402.  *-----------------------------------------------------------------------------
  403.  *
  404.  * Tcl_MkdirCmd --
  405.  *     Implements the TCL Mkdir command:
  406.  *         mkdir ?-path? dirList
  407.  *
  408.  * Results:
  409.  *  Standard TCL results, may return the UNIX system error message.
  410.  *
  411.  *-----------------------------------------------------------------------------
  412.  */
  413. int
  414. Tcl_MkdirCmd (clientData, interp, argc, argv)
  415.     ClientData  clientData;
  416.     Tcl_Interp *interp;
  417.     int         argc;
  418.     char      **argv;
  419. {
  420.     int           idx, dirArgc, result;
  421.     char        **dirArgv, *dirName, *scanPtr;
  422.     struct stat   statBuf;
  423.     Tcl_DString   tildeBuf;
  424.  
  425.     Tcl_DStringInit (&tildeBuf);
  426.  
  427.     if ((argc < 2) || (argc > 3))
  428.         goto usageError;
  429.     if ((argc == 3) && !STREQU (argv [1], "-path"))
  430.         goto usageError;
  431.  
  432.     if (Tcl_SplitList (interp, argv [argc - 1], &dirArgc, &dirArgv) != TCL_OK)
  433.         return TCL_ERROR;
  434.  
  435.     /*
  436.      * Make all the directories, optionally making directories along the path.
  437.      */
  438.  
  439.     for (idx = 0; idx < dirArgc; idx++) {
  440.         dirName = Tcl_TildeSubst (interp, dirArgv [idx], &tildeBuf);
  441.         if (dirName == NULL)
  442.            goto errorExit;
  443.  
  444.         /*
  445.          * Make leading directories, if requested.
  446.          */
  447.         if (argc == 3) {
  448.             scanPtr = dirName;
  449.             result = 0;  /* Start out ok, for dirs that are skipped */
  450.  
  451.             while (*scanPtr != '\0') {
  452.                 scanPtr = strchr (scanPtr+1, '/');
  453.                 if ((scanPtr == NULL) || (*(scanPtr+1) == '\0'))
  454.                     break;
  455.                 *scanPtr = '\0';
  456.                 if (stat (dirArgv [idx], &statBuf) < 0)
  457.                     result = mkdir (dirArgv [idx], S_IFDIR | 0777);
  458.                 *scanPtr = '/';
  459.                 if (result < 0)
  460.                    goto mkdirError;
  461.             }
  462.         }
  463.         /*
  464.          * Make final directory in the path.
  465.          */
  466.         if (mkdir (dirName, S_IFDIR | 0777) != 0)
  467.            goto mkdirError;
  468.  
  469.         Tcl_DStringFree (&tildeBuf);
  470.     }
  471.  
  472.     ckfree ((char *) dirArgv);
  473.     return TCL_OK;
  474.  
  475.   mkdirError:
  476.     Tcl_AppendResult (interp, dirArgv [idx], ": ", Tcl_PosixError (interp),
  477.                       (char *) NULL);
  478.   errorExit:
  479.     Tcl_DStringFree (&tildeBuf);
  480.     ckfree ((char *) dirArgv);
  481.     return TCL_ERROR;
  482.  
  483.   usageError:
  484.     Tcl_AppendResult (interp, tclXWrongArgs, argv [0], 
  485.                       " ?-path? dirlist", (char *) NULL);
  486.     return TCL_ERROR;
  487. }
  488.  
  489. /*
  490.  *-----------------------------------------------------------------------------
  491.  *
  492.  * Tcl_RmdirCmd --
  493.  *     Implements the TCL Rmdir command:
  494.  *         rmdir ?-nocomplain?  dirList
  495.  *
  496.  * Results:
  497.  *  Standard TCL results, may return the UNIX system error message.
  498.  *
  499.  *-----------------------------------------------------------------------------
  500.  */
  501. int
  502. Tcl_RmdirCmd (clientData, interp, argc, argv)
  503.     ClientData  clientData;
  504.     Tcl_Interp *interp;
  505.     int         argc;
  506.     char      **argv;
  507. {
  508.     int          idx, dirArgc;
  509.     char       **dirArgv, *dirName;
  510.     int          noComplain;
  511.     Tcl_DString  tildeBuf;
  512.  
  513.     Tcl_DStringInit (&tildeBuf);
  514.     
  515.     if ((argc < 2) || (argc > 3))
  516.         goto badArgs;
  517.  
  518.     if (argc == 3) {
  519.         if (!STREQU (argv [1], "-nocomplain"))
  520.             goto badArgs;
  521.         noComplain = TRUE;
  522.     } else {
  523.         noComplain = FALSE;
  524.     }
  525.  
  526.     if (Tcl_SplitList (interp, argv [argc - 1], &dirArgc, &dirArgv) != TCL_OK)
  527.         return TCL_ERROR;
  528.  
  529.     for (idx = 0; idx < dirArgc; idx++) {
  530.         dirName = Tcl_TildeSubst (interp, dirArgv [idx], &tildeBuf);
  531.         if (dirName == NULL) {
  532.             if (!noComplain)
  533.                 goto errorExit;
  534.             Tcl_DStringFree (&tildeBuf);
  535.             continue;
  536.         }
  537.         if ((rmdir (dirName) != 0) && !noComplain) {
  538.            Tcl_AppendResult (interp, dirArgv [idx], ": ",
  539.                              Tcl_PosixError (interp), (char *) NULL);
  540.            goto errorExit;
  541.         }
  542.         Tcl_DStringFree (&tildeBuf);
  543.     }
  544.  
  545.     ckfree ((char *) dirArgv);
  546.     return TCL_OK;
  547.  
  548.   errorExit:
  549.     Tcl_DStringFree (&tildeBuf);
  550.     ckfree ((char *) dirArgv);
  551.     return TCL_ERROR;;
  552.  
  553.   badArgs:
  554.     Tcl_AppendResult (interp, tclXWrongArgs, argv [0], 
  555.                       " ?-nocomplain? dirlist", (char *) NULL);
  556.     return TCL_ERROR;
  557. }
  558.