home *** CD-ROM | disk | FTP | other *** search
/ Serving the Web / ServingTheWeb1995.disc1of1.iso / linux / slacksrce / tcl / tcl+tk+t / tclx7.3bl / tclx7 / tclX7.3b / src / tclXunixcmds.c < prev    next >
Encoding:
C/C++ Source or Header  |  1994-07-16  |  18.7 KB  |  739 lines
  1. /*
  2.  * tclXunixcmds.c --
  3.  *
  4.  * Tcl commands to access unix library calls.
  5.  *-----------------------------------------------------------------------------
  6.  * Copyright 1991-1994 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 4.0 1994/07/16 05:28:03 markd Rel $
  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  waitStatus;
  318.  
  319.     if (argc != 2) {
  320.         Tcl_AppendResult (interp, tclXWrongArgs, argv [0], " command",
  321.                           (char *) NULL);
  322.         return TCL_ERROR;
  323.     }
  324.  
  325.     waitStatus = system (argv [1]);
  326.     if (waitStatus == -1) {
  327.         interp->result = Tcl_PosixError (interp);
  328.         return TCL_ERROR;
  329.     }
  330.     if (WIFEXITED (waitStatus)) {
  331.         sprintf (interp->result, "%d", WEXITSTATUS (waitStatus));
  332.         return TCL_OK;
  333.     }
  334.  
  335.     /*
  336.      * Return status based on wait result.
  337.      */
  338.     if (WIFSIGNALED (waitStatus)) {
  339.         Tcl_SetErrorCode (interp, "SYSTEM", "SIG",
  340.                           Tcl_SignalId (WTERMSIG (waitStatus)), (char *) NULL);
  341.         Tcl_AppendResult (interp, "system command terminate with signal ",
  342.                           Tcl_SignalId (WTERMSIG (waitStatus)), (char *) NULL);
  343.         return TCL_ERROR;
  344.     }
  345.  
  346.     /*
  347.      * Should never get this status back unless the implementation is
  348.      * really brain-damaged.
  349.      */
  350.     if (WIFSTOPPED (waitStatus)) {
  351.         Tcl_AppendResult (interp, "system command child stopped",
  352.                           (char *) NULL);
  353.         return TCL_ERROR;
  354.     }
  355. }
  356.  
  357. /*
  358.  *-----------------------------------------------------------------------------
  359.  *
  360.  * Tcl_TimesCmd --
  361.  *     Implements the TCL times command:
  362.  *     times
  363.  *
  364.  * Results:
  365.  *  Standard TCL results.
  366.  *
  367.  *-----------------------------------------------------------------------------
  368.  */
  369. int
  370. Tcl_TimesCmd (clientData, interp, argc, argv)
  371.     ClientData  clientData;
  372.     Tcl_Interp *interp;
  373.     int         argc;
  374.     char      **argv;
  375. {
  376.     struct tms tm;
  377.  
  378.     if (argc != 1) {
  379.         Tcl_AppendResult (interp, tclXWrongArgs, argv[0], (char *) NULL);
  380.         return TCL_ERROR;
  381.     }
  382.  
  383.     times(&tm);
  384.  
  385.     sprintf (interp->result, "%ld %ld %ld %ld", 
  386.              Tcl_TicksToMS (tm.tms_utime),
  387.              Tcl_TicksToMS (tm.tms_stime),
  388.              Tcl_TicksToMS (tm.tms_cutime),
  389.              Tcl_TicksToMS (tm.tms_cstime));
  390.     return TCL_OK;
  391. }
  392.  
  393. /*
  394.  *-----------------------------------------------------------------------------
  395.  *
  396.  * Tcl_UmaskCmd --
  397.  *     Implements the TCL umask command:
  398.  *     umask ?octalmask?
  399.  *
  400.  * Results:
  401.  *  Standard TCL results, may return the UNIX system error message.
  402.  *
  403.  *-----------------------------------------------------------------------------
  404.  */
  405. int
  406. Tcl_UmaskCmd (clientData, interp, argc, argv)
  407.     ClientData  clientData;
  408.     Tcl_Interp *interp;
  409.     int         argc;
  410.     char      **argv;
  411. {
  412.     int mask;
  413.  
  414.     if ((argc < 1) || (argc > 2)) {
  415.         Tcl_AppendResult (interp, tclXWrongArgs, argv [0], " ?octalmask?",
  416.                           (char *) NULL);
  417.         return TCL_ERROR;
  418.     }
  419.  
  420.     if (argc == 1) {
  421.         mask = umask (0);
  422.         umask ((unsigned short) mask);
  423.         sprintf (interp->result, "%o", mask);
  424.     } else {
  425.         if (!Tcl_StrToInt (argv [1], 8, &mask)) {
  426.             Tcl_AppendResult (interp, "Expected octal number got: ", argv [1],
  427.                               (char *) NULL);
  428.             return TCL_ERROR;
  429.         }
  430.  
  431.         umask ((unsigned short) mask);
  432.     }
  433.  
  434.     return TCL_OK;
  435. }
  436.  
  437. /*
  438.  *-----------------------------------------------------------------------------
  439.  *
  440.  * Tcl_LinkCmd --
  441.  *     Implements the TCL link command:
  442.  *         link ?-sym? srcpath destpath
  443.  *
  444.  * Results:
  445.  *  Standard TCL results, may return the UNIX system error message.
  446.  *
  447.  *-----------------------------------------------------------------------------
  448.  */
  449. int
  450. Tcl_LinkCmd (clientData, interp, argc, argv)
  451.     ClientData  clientData;
  452.     Tcl_Interp *interp;
  453.     int         argc;
  454.     char      **argv;
  455. {
  456.     char        *srcPath,    *destPath;
  457.     Tcl_DString  srcPathBuf,  destPathBuf;
  458.  
  459.     Tcl_DStringInit (&srcPathBuf);
  460.     Tcl_DStringInit (&destPathBuf);
  461.  
  462.     if ((argc < 3) || (argc > 4)) {
  463.         Tcl_AppendResult (interp, tclXWrongArgs, argv [0], 
  464.                           " ?-sym? srcpath destpath", (char *) NULL);
  465.         return TCL_ERROR;
  466.     }
  467.     if (argc == 4) {
  468.         if (!STREQU (argv [1], "-sym")) {
  469.             Tcl_AppendResult (interp, "invalid option, expected: \"-sym\", ",
  470.                               "got: ", argv [1], (char *) NULL);
  471.             return TCL_ERROR;
  472.         }
  473. #ifndef S_IFLNK
  474.         Tcl_AppendResult (interp, "symbolic links are not supported on this",
  475.                           " system", (char *) NULL);
  476.         return TCL_ERROR;
  477. #endif
  478.     }
  479.  
  480.     srcPath = Tcl_TildeSubst (interp, argv [argc - 2], &srcPathBuf);
  481.     if (srcPath == NULL)
  482.         goto errorExit;
  483.  
  484.     destPath = Tcl_TildeSubst (interp, argv [argc - 1], &destPathBuf);
  485.     if (destPath == NULL)
  486.         goto errorExit;
  487.  
  488.     if (argc == 4) {
  489. #ifdef S_IFLNK
  490.         if (symlink (srcPath, destPath) != 0)
  491.            goto unixError;
  492. #endif
  493.     } else {
  494.         if (link (srcPath, destPath) != 0)
  495.            goto unixError;
  496.     }
  497.  
  498.     Tcl_DStringFree (&srcPathBuf);
  499.     Tcl_DStringFree (&destPathBuf);
  500.     return TCL_OK;
  501.  
  502.   unixError:
  503.     interp->result = Tcl_PosixError (interp);
  504.  
  505.   errorExit:
  506.     Tcl_DStringFree (&srcPathBuf);
  507.     Tcl_DStringFree (&destPathBuf);
  508.     return TCL_ERROR;
  509. }
  510.  
  511. /*
  512.  *-----------------------------------------------------------------------------
  513.  *
  514.  * Tcl_UnlinkCmd --
  515.  *     Implements the TCL unlink command:
  516.  *         unlink ?-nocomplain? fileList
  517.  *
  518.  * Results:
  519.  *  Standard TCL results, may return the UNIX system error message.
  520.  *
  521.  *-----------------------------------------------------------------------------
  522.  */
  523. int
  524. Tcl_UnlinkCmd (clientData, interp, argc, argv)
  525.     ClientData  clientData;
  526.     Tcl_Interp *interp;
  527.     int         argc;
  528.     char      **argv;
  529. {
  530.     int           idx, fileArgc;
  531.     char        **fileArgv, *fileName;
  532.     int           noComplain;
  533.     Tcl_DString   tildeBuf;
  534.  
  535.     Tcl_DStringInit (&tildeBuf);
  536.     
  537.     if ((argc < 2) || (argc > 3))
  538.         goto badArgs;
  539.  
  540.     if (argc == 3) {
  541.         if (!STREQU (argv [1], "-nocomplain"))
  542.             goto badArgs;
  543.         noComplain = TRUE;
  544.     } else {
  545.         noComplain = FALSE;
  546.     }
  547.  
  548.     if (Tcl_SplitList (interp, argv [argc - 1], &fileArgc,
  549.                        &fileArgv) != TCL_OK)
  550.         return TCL_ERROR;
  551.  
  552.     for (idx = 0; idx < fileArgc; idx++) {
  553.         fileName = Tcl_TildeSubst (interp, fileArgv [idx], &tildeBuf);
  554.         if (fileName == NULL) {
  555.             if (!noComplain)
  556.                 goto errorExit;
  557.             Tcl_DStringFree (&tildeBuf);
  558.             continue;
  559.         }
  560.         if ((unlink (fileName) != 0) && !noComplain) {
  561.             Tcl_AppendResult (interp, fileArgv [idx], ": ",
  562.                               Tcl_PosixError (interp), (char *) NULL);
  563.             goto errorExit;
  564.         }
  565.         Tcl_DStringFree (&tildeBuf);
  566.     }
  567.  
  568.     ckfree ((char *) fileArgv);
  569.     return TCL_OK;
  570.  
  571.   errorExit:
  572.     Tcl_DStringFree (&tildeBuf);
  573.     ckfree ((char *) fileArgv);
  574.     return TCL_ERROR;
  575.  
  576.   badArgs:
  577.     Tcl_AppendResult (interp, tclXWrongArgs, argv [0], 
  578.                       " ?-nocomplain? filelist", (char *) NULL);
  579.     return TCL_ERROR;
  580. }
  581.  
  582. /*
  583.  *-----------------------------------------------------------------------------
  584.  *
  585.  * Tcl_MkdirCmd --
  586.  *     Implements the TCL Mkdir command:
  587.  *         mkdir ?-path? dirList
  588.  *
  589.  * Results:
  590.  *  Standard TCL results, may return the UNIX system error message.
  591.  *
  592.  *-----------------------------------------------------------------------------
  593.  */
  594. int
  595. Tcl_MkdirCmd (clientData, interp, argc, argv)
  596.     ClientData  clientData;
  597.     Tcl_Interp *interp;
  598.     int         argc;
  599.     char      **argv;
  600. {
  601.     int           idx, dirArgc, result;
  602.     char        **dirArgv, *dirName, *scanPtr;
  603.     struct stat   statBuf;
  604.     Tcl_DString   tildeBuf;
  605.  
  606.     Tcl_DStringInit (&tildeBuf);
  607.  
  608.     if ((argc < 2) || (argc > 3))
  609.         goto usageError;
  610.     if ((argc == 3) && !STREQU (argv [1], "-path"))
  611.         goto usageError;
  612.  
  613.     if (Tcl_SplitList (interp, argv [argc - 1], &dirArgc, &dirArgv) != TCL_OK)
  614.         return TCL_ERROR;
  615.  
  616.     /*
  617.      * Make all the directories, optionally making directories along the path.
  618.      */
  619.  
  620.     for (idx = 0; idx < dirArgc; idx++) {
  621.         dirName = Tcl_TildeSubst (interp, dirArgv [idx], &tildeBuf);
  622.         if (dirName == NULL)
  623.            goto errorExit;
  624.  
  625.         /*
  626.          * Make leading directories, if requested.
  627.          */
  628.         if (argc == 3) {
  629.             scanPtr = dirName;
  630.             result = 0;  /* Start out ok, for dirs that are skipped */
  631.  
  632.             while (*scanPtr != '\0') {
  633.                 scanPtr = strchr (scanPtr+1, '/');
  634.                 if ((scanPtr == NULL) || (*(scanPtr+1) == '\0'))
  635.                     break;
  636.                 *scanPtr = '\0';
  637.                 if (stat (dirName, &statBuf) < 0)
  638.                     result = mkdir (dirName, S_IFDIR | 0777);
  639.                 *scanPtr = '/';
  640.                 if (result < 0)
  641.                    goto mkdirError;
  642.             }
  643.         }
  644.         /*
  645.          * Make final directory in the path.
  646.          */
  647.         if (mkdir (dirName, S_IFDIR | 0777) != 0)
  648.            goto mkdirError;
  649.  
  650.         Tcl_DStringFree (&tildeBuf);
  651.     }
  652.  
  653.     ckfree ((char *) dirArgv);
  654.     return TCL_OK;
  655.  
  656.   mkdirError:
  657.     Tcl_AppendResult (interp, dirArgv [idx], ": ", Tcl_PosixError (interp),
  658.                       (char *) NULL);
  659.   errorExit:
  660.     Tcl_DStringFree (&tildeBuf);
  661.     ckfree ((char *) dirArgv);
  662.     return TCL_ERROR;
  663.  
  664.   usageError:
  665.     Tcl_AppendResult (interp, tclXWrongArgs, argv [0], 
  666.                       " ?-path? dirlist", (char *) NULL);
  667.     return TCL_ERROR;
  668. }
  669.  
  670. /*
  671.  *-----------------------------------------------------------------------------
  672.  *
  673.  * Tcl_RmdirCmd --
  674.  *     Implements the TCL Rmdir command:
  675.  *         rmdir ?-nocomplain?  dirList
  676.  *
  677.  * Results:
  678.  *  Standard TCL results, may return the UNIX system error message.
  679.  *
  680.  *-----------------------------------------------------------------------------
  681.  */
  682. int
  683. Tcl_RmdirCmd (clientData, interp, argc, argv)
  684.     ClientData  clientData;
  685.     Tcl_Interp *interp;
  686.     int         argc;
  687.     char      **argv;
  688. {
  689.     int          idx, dirArgc;
  690.     char       **dirArgv, *dirName;
  691.     int          noComplain;
  692.     Tcl_DString  tildeBuf;
  693.  
  694.     Tcl_DStringInit (&tildeBuf);
  695.     
  696.     if ((argc < 2) || (argc > 3))
  697.         goto badArgs;
  698.  
  699.     if (argc == 3) {
  700.         if (!STREQU (argv [1], "-nocomplain"))
  701.             goto badArgs;
  702.         noComplain = TRUE;
  703.     } else {
  704.         noComplain = FALSE;
  705.     }
  706.  
  707.     if (Tcl_SplitList (interp, argv [argc - 1], &dirArgc, &dirArgv) != TCL_OK)
  708.         return TCL_ERROR;
  709.  
  710.     for (idx = 0; idx < dirArgc; idx++) {
  711.         dirName = Tcl_TildeSubst (interp, dirArgv [idx], &tildeBuf);
  712.         if (dirName == NULL) {
  713.             if (!noComplain)
  714.                 goto errorExit;
  715.             Tcl_DStringFree (&tildeBuf);
  716.             continue;
  717.         }
  718.         if ((rmdir (dirName) != 0) && !noComplain) {
  719.            Tcl_AppendResult (interp, dirArgv [idx], ": ",
  720.                              Tcl_PosixError (interp), (char *) NULL);
  721.            goto errorExit;
  722.         }
  723.         Tcl_DStringFree (&tildeBuf);
  724.     }
  725.  
  726.     ckfree ((char *) dirArgv);
  727.     return TCL_OK;
  728.  
  729.   errorExit:
  730.     Tcl_DStringFree (&tildeBuf);
  731.     ckfree ((char *) dirArgv);
  732.     return TCL_ERROR;;
  733.  
  734.   badArgs:
  735.     Tcl_AppendResult (interp, tclXWrongArgs, argv [0], 
  736.                       " ?-nocomplain? dirlist", (char *) NULL);
  737.     return TCL_ERROR;
  738. }
  739.