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 / tclXunixcmds.c < prev    next >
Encoding:
C/C++ Source or Header  |  1994-01-25  |  18.8 KB  |  741 lines
  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 3.3 1994/01/25 01:07:01 markd Exp $
  16.  *-----------------------------------------------------------------------------
  17.  */
  18.  
  19. #include "tclExtdInt.h"
  20.  
  21. #ifdef HAVE_GETPRIORITY
  22. #include <sys/resource.h>
  23. #endif
  24.  
  25. /*
  26.  * A million microsecondss per seconds.
  27.  */
  28. #define TCL_USECS_PER_SEC (1000L * 1000L)
  29.  
  30. /*
  31.  * Cheat a little to avoid configure checking for floor and ceil being
  32.  * This breaks with GNU libc headers...really should check with autoconf.
  33.  */
  34.  
  35. #ifndef __GNU_LIBRARY__
  36. extern
  37. double floor ();
  38.  
  39. extern
  40. double ceil ();
  41. #endif
  42.  
  43.  
  44. /*
  45.  *-----------------------------------------------------------------------------
  46.  *
  47.  * Tcl_AlarmCmd --
  48.  *     Implements the TCL Alarm command:
  49.  *         alarm seconds
  50.  *
  51.  * Results:
  52.  *      Standard TCL results, may return the UNIX system error message.
  53.  *
  54.  *-----------------------------------------------------------------------------
  55.  */
  56. int
  57. Tcl_AlarmCmd (clientData, interp, argc, argv)
  58.     ClientData  clientData;
  59.     Tcl_Interp *interp;
  60.     int         argc;
  61.     char      **argv;
  62. {
  63. #ifndef HAVE_SETITIMER
  64.     double            seconds;
  65.     unsigned          useconds;
  66.  
  67.     if (argc != 2) {
  68.         Tcl_AppendResult (interp, tclXWrongArgs, argv [0], " seconds", 
  69.                           (char *) NULL);
  70.         return TCL_ERROR;
  71.     }
  72.  
  73.     if (Tcl_GetDouble (interp, argv[1], &seconds) != TCL_OK)
  74.         return TCL_ERROR;
  75.  
  76.     useconds = ceil (seconds);
  77.     sprintf (interp->result, "%d", alarm (useconds));
  78.  
  79.     return TCL_OK;
  80. #else
  81.  
  82.     double            seconds, secFloor;
  83.     struct itimerval  timer, oldTimer;
  84.  
  85.     if (argc != 2) {
  86.         Tcl_AppendResult (interp, tclXWrongArgs, argv [0], " seconds", 
  87.                           (char *) NULL);
  88.         return TCL_ERROR;
  89.     }
  90.  
  91.     if (Tcl_GetDouble (interp, argv[1], &seconds) != TCL_OK)
  92.         return TCL_ERROR;
  93.  
  94.     secFloor = floor (seconds);
  95.  
  96.     timer.it_value.tv_sec     = secFloor;
  97.     timer.it_value.tv_usec    = (long) ((seconds - secFloor) *
  98.                                         (double) TCL_USECS_PER_SEC);
  99.     timer.it_interval.tv_sec  = 0;
  100.     timer.it_interval.tv_usec = 0;  
  101.  
  102.  
  103.     if (setitimer (ITIMER_REAL, &timer, &oldTimer) < 0) {
  104.         interp->result = Tcl_PosixError (interp);
  105.         return TCL_ERROR;
  106.     }
  107.     seconds  = oldTimer.it_value.tv_sec;
  108.     seconds += ((double) oldTimer.it_value.tv_usec) /
  109.                ((double) TCL_USECS_PER_SEC);
  110.     sprintf (interp->result, "%g", seconds);
  111.  
  112.     return TCL_OK;
  113. #endif
  114.  
  115. }
  116.  
  117. /*
  118.  *-----------------------------------------------------------------------------
  119.  *
  120.  * Tcl_ChrootCmd --
  121.  *     Implements the TCL chroot command:
  122.  *         chroot path
  123.  *
  124.  * Results:
  125.  *      Standard TCL results, may return the UNIX system error message.
  126.  *
  127.  *-----------------------------------------------------------------------------
  128.  */
  129. int
  130. Tcl_ChrootCmd (clientData, interp, argc, argv)
  131.     ClientData  clientData;
  132.     Tcl_Interp *interp;
  133.     int         argc;
  134.     char      **argv;
  135. {
  136.     if (argc != 2) {
  137.         Tcl_AppendResult (interp, tclXWrongArgs, argv [0], " path", 
  138.                           (char *) NULL);
  139.         return TCL_ERROR;
  140.     }
  141.  
  142.     if (chroot (argv[1]) < 0) {
  143.         interp->result = Tcl_PosixError (interp);
  144.         return TCL_ERROR;
  145.     }
  146.     return TCL_OK;
  147. }
  148.  
  149. /*
  150.  *-----------------------------------------------------------------------------
  151.  *
  152.  * Tcl_NiceCmd --
  153.  *     Implements the TCL nice command:
  154.  *         nice ?priorityincr?
  155.  *
  156.  * Results:
  157.  *      Standard TCL results, may return the UNIX system error message.
  158.  *
  159.  *-----------------------------------------------------------------------------
  160.  */
  161. int
  162. Tcl_NiceCmd (clientData, interp, argc, argv)
  163.     ClientData  clientData;
  164.     Tcl_Interp *interp;
  165.     int         argc;
  166.     char      **argv;
  167. {
  168.     int priorityIncr, priority;
  169.  
  170.     if (argc > 2) {
  171.         Tcl_AppendResult (interp, tclXWrongArgs, argv [0], " ?priorityincr?",
  172.                           (char *) NULL);
  173.         return TCL_ERROR;
  174.     }
  175.  
  176.     /*
  177.      * Return the current priority if an increment is not supplied.
  178.      */
  179.     if (argc == 1) {
  180. #ifdef HAVE_GETPRIORITY
  181.         priority = getpriority (PRIO_PROCESS, 0);
  182. #else
  183.         priority = nice (0);
  184. #endif
  185.         sprintf (interp->result, "%d", priority);
  186.         return TCL_OK;
  187.     }
  188.  
  189.     /*
  190.      * Increment the priority.
  191.      */
  192.     if (Tcl_GetInt (interp, argv[1], &priorityIncr) != TCL_OK)
  193.         return TCL_ERROR;
  194.  
  195.     errno = 0;  /* In case old priority is -1 */
  196.  
  197.     priority = nice (priorityIncr);
  198.     if ((priority  == -1) && (errno != 0)) {
  199.         interp->result = Tcl_PosixError (interp);
  200.         return TCL_ERROR;
  201.     }
  202.  
  203. #ifdef HAVE_GETPRIORITY
  204.     priority = getpriority (PRIO_PROCESS, 0);
  205. #endif
  206.  
  207.     sprintf (interp->result, "%d", priority);
  208.     return TCL_OK;
  209. }
  210.  
  211. /*
  212.  *-----------------------------------------------------------------------------
  213.  *
  214.  * Tcl_SleepCmd --
  215.  *     Implements the TCL sleep command:
  216.  *         sleep seconds
  217.  *
  218.  * Results:
  219.  *      Standard TCL results, may return the UNIX system error message.
  220.  *
  221.  *-----------------------------------------------------------------------------
  222.  */
  223. int
  224. Tcl_SleepCmd (clientData, interp, argc, argv)
  225.     ClientData  clientData;
  226.     Tcl_Interp *interp;
  227.     int         argc;
  228.     char      **argv;
  229. {
  230.     unsigned time;
  231.  
  232.     if (argc != 2) {
  233.         Tcl_AppendResult (interp, tclXWrongArgs, argv [0], " seconds", 
  234.                           (char *) NULL);
  235.         return TCL_ERROR;
  236.     }
  237.  
  238.     if (Tcl_GetUnsigned (interp, argv[1], &time) != TCL_OK)
  239.         return TCL_ERROR;
  240.  
  241.     sleep (time);
  242.     return TCL_OK;
  243.  
  244. }
  245.  
  246. /*
  247.  *-----------------------------------------------------------------------------
  248.  *
  249.  * Tcl_SyncCmd --
  250.  *     Implements the TCL sync command:
  251.  *         sync
  252.  *
  253.  * Results:
  254.  *      Standard TCL results.
  255.  *
  256.  *-----------------------------------------------------------------------------
  257.  */
  258. int
  259. Tcl_SyncCmd (clientData, interp, argc, argv)
  260.     ClientData  clientData;
  261.     Tcl_Interp *interp;
  262.     int         argc;
  263.     char      **argv;
  264. {
  265.     unsigned time;
  266.     FILE *filePtr;
  267.  
  268.     if ((argc < 1) || (argc > 2)) {
  269.         Tcl_AppendResult (interp, tclXWrongArgs, argv [0], " ?filehandle?",
  270.                           (char *) NULL);
  271.         return TCL_ERROR;
  272.     }
  273.  
  274.     if (argc == 1) {
  275.     sync ();
  276.     return TCL_OK;
  277.     }
  278.  
  279.     if (Tcl_GetOpenFile (interp, argv[1], 
  280.              TCL_FILE_WRITABLE,
  281.              TRUE,   /* check access */
  282.              &filePtr) != TCL_OK)
  283.     return TCL_ERROR;
  284.  
  285.     fflush (filePtr);
  286.  
  287. #ifdef HAVE_FSYNC
  288.     if (fsync (fileno (filePtr)) < 0) {
  289.         interp->result = Tcl_PosixError (interp);
  290.         return TCL_ERROR;
  291.     }
  292. #else
  293.     sync ();
  294. #endif
  295.     return TCL_OK;
  296. }
  297.  
  298. /*
  299.  *-----------------------------------------------------------------------------
  300.  *
  301.  * Tcl_SystemCmd --
  302.  *     Implements the TCL system command:
  303.  *     system command
  304.  *
  305.  * Results:
  306.  *  Standard TCL results, may return the UNIX system error message.
  307.  *
  308.  *-----------------------------------------------------------------------------
  309.  */
  310. int
  311. Tcl_SystemCmd (clientData, interp, argc, argv)
  312.     ClientData  clientData;
  313.     Tcl_Interp *interp;
  314.     int         argc;
  315.     char      **argv;
  316. {
  317.     int               sysStatus;
  318.     WAIT_STATUS_TYPE  waitStatus;
  319.  
  320.     if (argc != 2) {
  321.         Tcl_AppendResult (interp, tclXWrongArgs, argv [0], " command",
  322.                           (char *) NULL);
  323.         return TCL_ERROR;
  324.     }
  325.  
  326.     sysStatus = system (argv [1]);
  327.     if (sysStatus == -1) {
  328.         interp->result = Tcl_PosixError (interp);
  329.         return TCL_ERROR;
  330.     }
  331.     waitStatus = *((WAIT_STATUS_TYPE *) &sysStatus);
  332.     if (WIFEXITED (waitStatus)) {
  333.         sprintf (interp->result, "%d", WEXITSTATUS (waitStatus));
  334.         return TCL_OK;
  335.     }
  336.  
  337.     /*
  338.      * Return status based on wait result.
  339.      */
  340.     if (WIFSIGNALED (waitStatus)) {
  341.         Tcl_SetErrorCode (interp, "SYSTEM", "SIG",
  342.                           Tcl_SignalId (WTERMSIG (waitStatus)), (char *) NULL);
  343.         Tcl_AppendResult (interp, "system command terminate with signal ",
  344.                           Tcl_SignalId (WTERMSIG (waitStatus)), (char *) NULL);
  345.         return TCL_ERROR;
  346.     }
  347.  
  348.     /*
  349.      * Should never get this status back unless the implementation is
  350.      * really brain-damaged.
  351.      */
  352.     if (WIFSTOPPED (waitStatus)) {
  353.         Tcl_AppendResult (interp, "system command child stopped",
  354.                           (char *) NULL);
  355.         return TCL_ERROR;
  356.     }
  357. }
  358.  
  359. /*
  360.  *-----------------------------------------------------------------------------
  361.  *
  362.  * Tcl_TimesCmd --
  363.  *     Implements the TCL times command:
  364.  *     times
  365.  *
  366.  * Results:
  367.  *  Standard TCL results.
  368.  *
  369.  *-----------------------------------------------------------------------------
  370.  */
  371. int
  372. Tcl_TimesCmd (clientData, interp, argc, argv)
  373.     ClientData  clientData;
  374.     Tcl_Interp *interp;
  375.     int         argc;
  376.     char      **argv;
  377. {
  378.     struct tms tm;
  379.  
  380.     if (argc != 1) {
  381.         Tcl_AppendResult (interp, tclXWrongArgs, argv[0], (char *) NULL);
  382.         return TCL_ERROR;
  383.     }
  384.  
  385.     times(&tm);
  386.  
  387.     sprintf (interp->result, "%ld %ld %ld %ld", 
  388.              TICKS_TO_MS (tm.tms_utime),
  389.              TICKS_TO_MS (tm.tms_stime),
  390.              TICKS_TO_MS (tm.tms_cutime),
  391.              TICKS_TO_MS (tm.tms_cstime));
  392.     return TCL_OK;
  393. }
  394.  
  395. /*
  396.  *-----------------------------------------------------------------------------
  397.  *
  398.  * Tcl_UmaskCmd --
  399.  *     Implements the TCL umask command:
  400.  *     umask ?octalmask?
  401.  *
  402.  * Results:
  403.  *  Standard TCL results, may return the UNIX system error message.
  404.  *
  405.  *-----------------------------------------------------------------------------
  406.  */
  407. int
  408. Tcl_UmaskCmd (clientData, interp, argc, argv)
  409.     ClientData  clientData;
  410.     Tcl_Interp *interp;
  411.     int         argc;
  412.     char      **argv;
  413. {
  414.     int mask;
  415.  
  416.     if ((argc < 1) || (argc > 2)) {
  417.         Tcl_AppendResult (interp, tclXWrongArgs, argv [0], " ?octalmask?",
  418.                           (char *) NULL);
  419.         return TCL_ERROR;
  420.     }
  421.  
  422.     if (argc == 1) {
  423.         mask = umask (0);
  424.         umask ((unsigned short) mask);
  425.         sprintf (interp->result, "%o", mask);
  426.     } else {
  427.         if (!Tcl_StrToInt (argv [1], 8, &mask)) {
  428.             Tcl_AppendResult (interp, "Expected octal number got: ", argv [1],
  429.                               (char *) NULL);
  430.             return TCL_ERROR;
  431.         }
  432.  
  433.         umask ((unsigned short) mask);
  434.     }
  435.  
  436.     return TCL_OK;
  437. }
  438.  
  439. /*
  440.  *-----------------------------------------------------------------------------
  441.  *
  442.  * Tcl_LinkCmd --
  443.  *     Implements the TCL link command:
  444.  *         link ?-sym? srcpath destpath
  445.  *
  446.  * Results:
  447.  *  Standard TCL results, may return the UNIX system error message.
  448.  *
  449.  *-----------------------------------------------------------------------------
  450.  */
  451. int
  452. Tcl_LinkCmd (clientData, interp, argc, argv)
  453.     ClientData  clientData;
  454.     Tcl_Interp *interp;
  455.     int         argc;
  456.     char      **argv;
  457. {
  458.     char        *srcPath,    *destPath;
  459.     Tcl_DString  srcPathBuf,  destPathBuf;
  460.  
  461.     Tcl_DStringInit (&srcPathBuf);
  462.     Tcl_DStringInit (&destPathBuf);
  463.  
  464.     if ((argc < 3) || (argc > 4)) {
  465.         Tcl_AppendResult (interp, tclXWrongArgs, argv [0], 
  466.                           " ?-sym? srcpath destpath", (char *) NULL);
  467.         return TCL_ERROR;
  468.     }
  469.     if (argc == 4) {
  470.         if (!STREQU (argv [1], "-sym")) {
  471.             Tcl_AppendResult (interp, "invalid option, expected: \"-sym\", ",
  472.                               "got: ", argv [1], (char *) NULL);
  473.             return TCL_ERROR;
  474.         }
  475. #ifndef S_IFLNK
  476.         Tcl_AppendResult (interp, "symbolic links are not supported on this",
  477.                           " system", (char *) NULL);
  478.         return TCL_ERROR;
  479. #endif
  480.     }
  481.  
  482.     srcPath = Tcl_TildeSubst (interp, argv [argc - 2], &srcPathBuf);
  483.     if (srcPath == NULL)
  484.         goto errorExit;
  485.  
  486.     destPath = Tcl_TildeSubst (interp, argv [argc - 1], &destPathBuf);
  487.     if (destPath == NULL)
  488.         goto errorExit;
  489.  
  490.     if (argc == 4) {
  491. #ifdef S_IFLNK
  492.         if (symlink (srcPath, destPath) != 0)
  493.            goto unixError;
  494. #endif
  495.     } else {
  496.         if (link (srcPath, destPath) != 0)
  497.            goto unixError;
  498.     }
  499.  
  500.     Tcl_DStringFree (&srcPathBuf);
  501.     Tcl_DStringFree (&destPathBuf);
  502.     return TCL_OK;
  503.  
  504.   unixError:
  505.     interp->result = Tcl_PosixError (interp);
  506.  
  507.   errorExit:
  508.     Tcl_DStringFree (&srcPathBuf);
  509.     Tcl_DStringFree (&destPathBuf);
  510.     return TCL_ERROR;
  511. }
  512.  
  513. /*
  514.  *-----------------------------------------------------------------------------
  515.  *
  516.  * Tcl_UnlinkCmd --
  517.  *     Implements the TCL unlink command:
  518.  *         unlink ?-nocomplain? fileList
  519.  *
  520.  * Results:
  521.  *  Standard TCL results, may return the UNIX system error message.
  522.  *
  523.  *-----------------------------------------------------------------------------
  524.  */
  525. int
  526. Tcl_UnlinkCmd (clientData, interp, argc, argv)
  527.     ClientData  clientData;
  528.     Tcl_Interp *interp;
  529.     int         argc;
  530.     char      **argv;
  531. {
  532.     int           idx, fileArgc;
  533.     char        **fileArgv, *fileName;
  534.     int           noComplain;
  535.     Tcl_DString   tildeBuf;
  536.  
  537.     Tcl_DStringInit (&tildeBuf);
  538.     
  539.     if ((argc < 2) || (argc > 3))
  540.         goto badArgs;
  541.  
  542.     if (argc == 3) {
  543.         if (!STREQU (argv [1], "-nocomplain"))
  544.             goto badArgs;
  545.         noComplain = TRUE;
  546.     } else {
  547.         noComplain = FALSE;
  548.     }
  549.  
  550.     if (Tcl_SplitList (interp, argv [argc - 1], &fileArgc,
  551.                        &fileArgv) != TCL_OK)
  552.         return TCL_ERROR;
  553.  
  554.     for (idx = 0; idx < fileArgc; idx++) {
  555.         fileName = Tcl_TildeSubst (interp, fileArgv [idx], &tildeBuf);
  556.         if (fileName == NULL) {
  557.             if (!noComplain)
  558.                 goto errorExit;
  559.             Tcl_DStringFree (&tildeBuf);
  560.             continue;
  561.         }
  562.         if ((unlink (fileName) != 0) && !noComplain) {
  563.             Tcl_AppendResult (interp, fileArgv [idx], ": ",
  564.                               Tcl_PosixError (interp), (char *) NULL);
  565.             goto errorExit;
  566.         }
  567.         Tcl_DStringFree (&tildeBuf);
  568.     }
  569.  
  570.     ckfree ((char *) fileArgv);
  571.     return TCL_OK;
  572.  
  573.   errorExit:
  574.     Tcl_DStringFree (&tildeBuf);
  575.     ckfree ((char *) fileArgv);
  576.     return TCL_ERROR;
  577.  
  578.   badArgs:
  579.     Tcl_AppendResult (interp, tclXWrongArgs, argv [0], 
  580.                       " ?-nocomplain? filelist", (char *) NULL);
  581.     return TCL_ERROR;
  582. }
  583.  
  584. /*
  585.  *-----------------------------------------------------------------------------
  586.  *
  587.  * Tcl_MkdirCmd --
  588.  *     Implements the TCL Mkdir command:
  589.  *         mkdir ?-path? dirList
  590.  *
  591.  * Results:
  592.  *  Standard TCL results, may return the UNIX system error message.
  593.  *
  594.  *-----------------------------------------------------------------------------
  595.  */
  596. int
  597. Tcl_MkdirCmd (clientData, interp, argc, argv)
  598.     ClientData  clientData;
  599.     Tcl_Interp *interp;
  600.     int         argc;
  601.     char      **argv;
  602. {
  603.     int           idx, dirArgc, result;
  604.     char        **dirArgv, *dirName, *scanPtr;
  605.     struct stat   statBuf;
  606.     Tcl_DString   tildeBuf;
  607.  
  608.     Tcl_DStringInit (&tildeBuf);
  609.  
  610.     if ((argc < 2) || (argc > 3))
  611.         goto usageError;
  612.     if ((argc == 3) && !STREQU (argv [1], "-path"))
  613.         goto usageError;
  614.  
  615.     if (Tcl_SplitList (interp, argv [argc - 1], &dirArgc, &dirArgv) != TCL_OK)
  616.         return TCL_ERROR;
  617.  
  618.     /*
  619.      * Make all the directories, optionally making directories along the path.
  620.      */
  621.  
  622.     for (idx = 0; idx < dirArgc; idx++) {
  623.         dirName = Tcl_TildeSubst (interp, dirArgv [idx], &tildeBuf);
  624.         if (dirName == NULL)
  625.            goto errorExit;
  626.  
  627.         /*
  628.          * Make leading directories, if requested.
  629.          */
  630.         if (argc == 3) {
  631.             scanPtr = dirName;
  632.             result = 0;  /* Start out ok, for dirs that are skipped */
  633.  
  634.             while (*scanPtr != '\0') {
  635.                 scanPtr = strchr (scanPtr+1, '/');
  636.                 if ((scanPtr == NULL) || (*(scanPtr+1) == '\0'))
  637.                     break;
  638.                 *scanPtr = '\0';
  639.                 if (stat (dirName, &statBuf) < 0)
  640.                     result = mkdir (dirName, S_IFDIR | 0777);
  641.                 *scanPtr = '/';
  642.                 if (result < 0)
  643.                    goto mkdirError;
  644.             }
  645.         }
  646.         /*
  647.          * Make final directory in the path.
  648.          */
  649.         if (mkdir (dirName, S_IFDIR | 0777) != 0)
  650.            goto mkdirError;
  651.  
  652.         Tcl_DStringFree (&tildeBuf);
  653.     }
  654.  
  655.     ckfree ((char *) dirArgv);
  656.     return TCL_OK;
  657.  
  658.   mkdirError:
  659.     Tcl_AppendResult (interp, dirArgv [idx], ": ", Tcl_PosixError (interp),
  660.                       (char *) NULL);
  661.   errorExit:
  662.     Tcl_DStringFree (&tildeBuf);
  663.     ckfree ((char *) dirArgv);
  664.     return TCL_ERROR;
  665.  
  666.   usageError:
  667.     Tcl_AppendResult (interp, tclXWrongArgs, argv [0], 
  668.                       " ?-path? dirlist", (char *) NULL);
  669.     return TCL_ERROR;
  670. }
  671.  
  672. /*
  673.  *-----------------------------------------------------------------------------
  674.  *
  675.  * Tcl_RmdirCmd --
  676.  *     Implements the TCL Rmdir command:
  677.  *         rmdir ?-nocomplain?  dirList
  678.  *
  679.  * Results:
  680.  *  Standard TCL results, may return the UNIX system error message.
  681.  *
  682.  *-----------------------------------------------------------------------------
  683.  */
  684. int
  685. Tcl_RmdirCmd (clientData, interp, argc, argv)
  686.     ClientData  clientData;
  687.     Tcl_Interp *interp;
  688.     int         argc;
  689.     char      **argv;
  690. {
  691.     int          idx, dirArgc;
  692.     char       **dirArgv, *dirName;
  693.     int          noComplain;
  694.     Tcl_DString  tildeBuf;
  695.  
  696.     Tcl_DStringInit (&tildeBuf);
  697.     
  698.     if ((argc < 2) || (argc > 3))
  699.         goto badArgs;
  700.  
  701.     if (argc == 3) {
  702.         if (!STREQU (argv [1], "-nocomplain"))
  703.             goto badArgs;
  704.         noComplain = TRUE;
  705.     } else {
  706.         noComplain = FALSE;
  707.     }
  708.  
  709.     if (Tcl_SplitList (interp, argv [argc - 1], &dirArgc, &dirArgv) != TCL_OK)
  710.         return TCL_ERROR;
  711.  
  712.     for (idx = 0; idx < dirArgc; idx++) {
  713.         dirName = Tcl_TildeSubst (interp, dirArgv [idx], &tildeBuf);
  714.         if (dirName == NULL) {
  715.             if (!noComplain)
  716.                 goto errorExit;
  717.             Tcl_DStringFree (&tildeBuf);
  718.             continue;
  719.         }
  720.         if ((rmdir (dirName) != 0) && !noComplain) {
  721.            Tcl_AppendResult (interp, dirArgv [idx], ": ",
  722.                              Tcl_PosixError (interp), (char *) NULL);
  723.            goto errorExit;
  724.         }
  725.         Tcl_DStringFree (&tildeBuf);
  726.     }
  727.  
  728.     ckfree ((char *) dirArgv);
  729.     return TCL_OK;
  730.  
  731.   errorExit:
  732.     Tcl_DStringFree (&tildeBuf);
  733.     ckfree ((char *) dirArgv);
  734.     return TCL_ERROR;;
  735.  
  736.   badArgs:
  737.     Tcl_AppendResult (interp, tclXWrongArgs, argv [0], 
  738.                       " ?-nocomplain? dirlist", (char *) NULL);
  739.     return TCL_ERROR;
  740. }
  741.