home *** CD-ROM | disk | FTP | other *** search
/ OS/2 Shareware BBS: 10 Tools / 10-Tools.zip / tkisrc04.zip / tcl / os2 / tclOS2FileName.c < prev    next >
C/C++ Source or Header  |  1998-08-07  |  52KB  |  1,934 lines
  1. /* 
  2.  * tclFileName.c --
  3.  *
  4.  *    This file contains routines for converting file names betwen
  5.  *    native and network form.
  6.  *
  7.  * Copyright (c) 1995-1996 Sun Microsystems, Inc.
  8.  * Copyright (c) 1996-1997 Illya Vaes
  9.  *
  10.  * See the file "license.terms" for information on usage and redistribution
  11.  * of this file, and for a DISCLAIMER OF ALL WARRANTIES.
  12.  *
  13.  * SCCS: @(#) tclFileName.c 1.23 96/04/19 12:34:28
  14.  */
  15.  
  16. #include "tclInt.h"
  17. #include "tclPort.h"
  18. #include "../generic/tclRegexp.h" /* *MM* added ../generic/ */
  19.  
  20. /*
  21.  * This variable indicates whether the cleanup procedure has been
  22.  * registered for this file yet.
  23.  */
  24.  
  25. static int initialized = 0;
  26.  
  27. /*
  28.  * The following regular expression matches the root portion of a OS/2
  29.  * absolute or volume relative path.  It will match both UNC and drive relative
  30.  * paths.
  31.  */
  32.  
  33. #define OS2_ROOT_PATTERN "^(([a-zA-Z]:)|[/\\][/\\]+([^/\\]+)[/\\]+([^/\\]+)|([/\\]))([/\\])*"
  34.  
  35. /*
  36.  * The following regular expression matches the root portion of a Windows
  37.  * absolute or volume relative path.  It will match both UNC and drive relative
  38.  * paths.
  39.  */
  40.  
  41. #define WIN_ROOT_PATTERN "^(([a-zA-Z]:)|[/\\][/\\]+([^/\\]+)[/\\]+([^/\\]+)|([/\\]))([/\\])*"
  42.  
  43. /*
  44.  * The following regular expression matches the root portion of a Macintosh
  45.  * absolute path.  It will match degenerate Unix-style paths, tilde paths,
  46.  * Unix-style paths, and Mac paths.
  47.  */
  48.  
  49. #define MAC_ROOT_PATTERN "^((/+([.][.]?/+)*([.][.]?)?)|(~[^:/]*)(/[^:]*)?|(~[^:]*)(:.*)?|/+([.][.]?/+)*([^:/]+)(/[^:]*)?|([^:]+):.*)$"
  50.  
  51. /*
  52.  * The following variables are used to hold precompiled regular expressions
  53.  * for use in filename matching.
  54.  */
  55.  
  56. static regexp *os2RootPatternPtr = NULL;
  57. static regexp *winRootPatternPtr = NULL;
  58. static regexp *macRootPatternPtr = NULL;
  59.  
  60. /*
  61.  * The following variable is set in the TclPlatformInit call to one
  62.  * of: TCL_PLATFORM_UNIX, TCL_PLATFORM_MAC, TCL_PLATFORM_OS2 or
  63.  * TCL_PLATFORM_OS2.
  64.  */
  65.  
  66. TclPlatformType tclPlatform = TCL_PLATFORM_OS2;
  67.  
  68. /*
  69.  * Prototypes for local procedures defined in this file:
  70.  */
  71.  
  72. static char *        DoTildeSubst _ANSI_ARGS_((Tcl_Interp *interp,
  73.                 char *user, Tcl_DString *resultPtr));
  74. static char *        ExtractWinRoot _ANSI_ARGS_((char *path,
  75.                 Tcl_DString *resultPtr, int offset));
  76. static char *        ExtractOS2Root _ANSI_ARGS_((char *path,
  77.                 Tcl_DString *resultPtr, int offset));
  78. static void        FileNameCleanup _ANSI_ARGS_((ClientData clientData));
  79. static int        SkipToChar _ANSI_ARGS_((char **stringPtr,
  80.                 char *match));
  81. static char *        SplitMacPath _ANSI_ARGS_((char *path,
  82.                 Tcl_DString *bufPtr));
  83. static char *        SplitWinPath _ANSI_ARGS_((char *path,
  84.                 Tcl_DString *bufPtr));
  85. static char *        SplitOS2Path _ANSI_ARGS_((char *path,
  86.                 Tcl_DString *bufPtr));
  87. static char *        SplitUnixPath _ANSI_ARGS_((char *path,
  88.                 Tcl_DString *bufPtr));
  89.  
  90. /*
  91.  *----------------------------------------------------------------------
  92.  *
  93.  * FileNameCleanup --
  94.  *
  95.  *    This procedure is a Tcl_ExitProc used to clean up the static
  96.  *    data structures used in this file.
  97.  *
  98.  * Results:
  99.  *    None.
  100.  *
  101.  * Side effects:
  102.  *    Deallocates storage used by the procedures in this file.
  103.  *
  104.  *----------------------------------------------------------------------
  105.  */
  106.  
  107. static void
  108. FileNameCleanup(clientData)
  109.     ClientData clientData;    /* Not used. */
  110. {
  111.     if (os2RootPatternPtr != NULL) {
  112.     ckfree((char *)os2RootPatternPtr);
  113.     }
  114.     if (macRootPatternPtr != NULL) {
  115.     ckfree((char *)macRootPatternPtr);
  116.     }
  117. }
  118.  
  119. /*
  120.  *----------------------------------------------------------------------
  121.  *
  122.  * ExtractWinRoot --
  123.  *
  124.  *    Matches the root portion of a Windows path and appends it
  125.  *    to the specified Tcl_DString.
  126.  *    
  127.  * Results:
  128.  *    Returns the position in the path immediately after the root
  129.  *    including any trailing slashes.
  130.  *    Appends a cleaned up version of the root to the Tcl_DString
  131.  *    at the specified offest.
  132.  *
  133.  * Side effects:
  134.  *    Modifies the specified Tcl_DString.
  135.  *
  136.  *----------------------------------------------------------------------
  137.  */
  138.  
  139. static char *
  140. ExtractWinRoot(path, resultPtr, offset)
  141.     char *path;            /* Path to parse. */
  142.     Tcl_DString *resultPtr;    /* Buffer to hold result. */
  143.     int offset;            /* Offset in buffer where result should be
  144.                  * stored. */
  145. {
  146.     int length;
  147.  
  148.     /*
  149.      * Initialize the path name parser for Windows path names.
  150.      */
  151.  
  152.     if (winRootPatternPtr == NULL) {
  153.     winRootPatternPtr = TclRegComp(WIN_ROOT_PATTERN);
  154.     if (!initialized) {
  155.         Tcl_CreateExitHandler(FileNameCleanup, NULL);
  156.         initialized = 1;
  157.     }
  158.     }
  159.  
  160.     /*
  161.      * Match the root portion of a Windows path name.
  162.      */
  163.  
  164.     if (!TclRegExec(winRootPatternPtr, path, path)) {
  165.     return path;
  166.     }
  167.  
  168.     Tcl_DStringSetLength(resultPtr, offset);
  169.  
  170.     if (winRootPatternPtr->startp[2] != NULL) {
  171.     Tcl_DStringAppend(resultPtr, winRootPatternPtr->startp[2], 2);
  172.     if (winRootPatternPtr->startp[6] != NULL) {
  173.         Tcl_DStringAppend(resultPtr, "/", 1);
  174.     }
  175.     } else if (winRootPatternPtr->startp[4] != NULL) {
  176.     Tcl_DStringAppend(resultPtr, "//", 2);
  177.     length = winRootPatternPtr->endp[3]
  178.         - winRootPatternPtr->startp[3];
  179.     Tcl_DStringAppend(resultPtr, winRootPatternPtr->startp[3], length);
  180.     Tcl_DStringAppend(resultPtr, "/", 1);
  181.     length = winRootPatternPtr->endp[4]
  182.         - winRootPatternPtr->startp[4];
  183.     Tcl_DStringAppend(resultPtr, winRootPatternPtr->startp[4], length);
  184.     } else {
  185.     Tcl_DStringAppend(resultPtr, "/", 1);
  186.     }
  187.     return winRootPatternPtr->endp[0];
  188. }
  189.  
  190. /*
  191.  *----------------------------------------------------------------------
  192.  *
  193.  * ExtractOS2Root --
  194.  *
  195.  *    Matches the root portion of a OS/2 path and appends it
  196.  *    to the specified Tcl_DString.
  197.  *    
  198.  * Results:
  199.  *    Returns the position in the path immediately after the root
  200.  *    including any trailing slashes.
  201.  *    Appends a cleaned up version of the root to the Tcl_DString
  202.  *    at the specified offest.
  203.  *
  204.  * Side effects:
  205.  *    Modifies the specified Tcl_DString.
  206.  *
  207.  *----------------------------------------------------------------------
  208.  */
  209.  
  210. static char *
  211. ExtractOS2Root(path, resultPtr, offset)
  212.     char *path;            /* Path to parse. */
  213.     Tcl_DString *resultPtr;    /* Buffer to hold result. */
  214.     int offset;            /* Offset in buffer where result should be
  215.                  * stored. */
  216. {
  217.     int length;
  218.  
  219.     /*
  220.      * Initialize the path name parser for OS/2 path names.
  221.      */
  222.  
  223.     if (os2RootPatternPtr == NULL) {
  224.     os2RootPatternPtr = TclRegComp(OS2_ROOT_PATTERN);
  225.     if (!initialized) {
  226.         Tcl_CreateExitHandler(FileNameCleanup, NULL);
  227.         initialized = 1;
  228.     }
  229.     }
  230.  
  231.     /*
  232.      * Match the root portion of a OS/2 path name.
  233.      */
  234.  
  235.     if (!TclRegExec(os2RootPatternPtr, path, path)) {
  236.     return path;
  237.     }
  238.  
  239.     Tcl_DStringSetLength(resultPtr, offset);
  240.  
  241.     if (os2RootPatternPtr->startp[2] != NULL) {
  242.     Tcl_DStringAppend(resultPtr, os2RootPatternPtr->startp[2], 2);
  243.     if (os2RootPatternPtr->startp[6] != NULL) {
  244.         Tcl_DStringAppend(resultPtr, "/", 1);
  245.     }
  246.     } else if (os2RootPatternPtr->startp[4] != NULL) {
  247.     Tcl_DStringAppend(resultPtr, "//", 2);
  248.     length = os2RootPatternPtr->endp[3]
  249.         - os2RootPatternPtr->startp[3];
  250.     Tcl_DStringAppend(resultPtr, os2RootPatternPtr->startp[3], length);
  251.     Tcl_DStringAppend(resultPtr, "/", 1);
  252.     length = os2RootPatternPtr->endp[4]
  253.         - os2RootPatternPtr->startp[4];
  254.     Tcl_DStringAppend(resultPtr, os2RootPatternPtr->startp[4], length);
  255.     } else {
  256.     Tcl_DStringAppend(resultPtr, "/", 1);
  257.     }
  258.     return os2RootPatternPtr->endp[0];
  259. }
  260.  
  261. /*
  262.  *----------------------------------------------------------------------
  263.  *
  264.  * Tcl_GetPathType --
  265.  *
  266.  *    Determines whether a given path is relative to the current
  267.  *    directory, relative to the current volume, or absolute.
  268.  *
  269.  * Results:
  270.  *    Returns one of TCL_PATH_ABSOLUTE, TCL_PATH_RELATIVE, or
  271.  *    TCL_PATH_VOLUME_RELATIVE.
  272.  *
  273.  * Side effects:
  274.  *    None.
  275.  *
  276.  *----------------------------------------------------------------------
  277.  */
  278.  
  279. Tcl_PathType
  280. Tcl_GetPathType(path)
  281.     char *path;
  282. {
  283.     Tcl_PathType type = TCL_PATH_ABSOLUTE;
  284.  
  285. #ifdef DEBUG
  286.     printf("Tcl_GetPathType %s\n", path);
  287. #endif
  288.  
  289.     switch (tclPlatform) {
  290.        case TCL_PLATFORM_UNIX:
  291.         /*
  292.          * Paths that begin with / or ~ are absolute.
  293.          */
  294.  
  295.         if ((path[0] != '/') && (path[0] != '~')) {
  296.         type = TCL_PATH_RELATIVE;
  297.         }
  298.         break;
  299.  
  300.     case TCL_PLATFORM_MAC:
  301.         if (path[0] == ':') {
  302.         type = TCL_PATH_RELATIVE;
  303.         } else if (path[0] != '~') {
  304.  
  305.         /*
  306.          * Since we have eliminated the easy cases, use the
  307.          * root pattern to look for the other types.
  308.          */
  309.  
  310.         if (!macRootPatternPtr) {
  311.             macRootPatternPtr = TclRegComp(MAC_ROOT_PATTERN);
  312.             if (!initialized) {
  313.             Tcl_CreateExitHandler(FileNameCleanup, NULL);
  314.             initialized = 1;
  315.             }
  316.         }
  317.         if (!TclRegExec(macRootPatternPtr, path, path)
  318.             || (macRootPatternPtr->startp[2] != NULL)) {
  319.             type = TCL_PATH_RELATIVE;
  320.         }
  321.         }
  322.         break;
  323.     
  324.     case TCL_PLATFORM_OS2:
  325.         if (path[0] != '~') {
  326.  
  327.         /*
  328.          * Since we have eliminated the easy cases, check for
  329.          * drive relative paths using the regular expression.
  330.          */
  331.  
  332.         if (!os2RootPatternPtr) {
  333.             os2RootPatternPtr = TclRegComp(OS2_ROOT_PATTERN);
  334.             if (!initialized) {
  335.             Tcl_CreateExitHandler(FileNameCleanup, NULL);
  336.             initialized = 1;
  337.             }
  338.         }
  339.         if (TclRegExec(os2RootPatternPtr, path, path)) {
  340.             if (os2RootPatternPtr->startp[5]
  341.                 || (os2RootPatternPtr->startp[2]
  342.                     && !(os2RootPatternPtr->startp[6]))) {
  343.             type = TCL_PATH_VOLUME_RELATIVE;
  344. #ifdef DEBUG
  345.                         printf("    TCL_PATH_VOLUME_RELATIVE\n");
  346.             } else {
  347.                         printf("    (else) TCL_PATH_ABSOLUTE\n");
  348. #endif
  349.             }
  350.         } else {
  351.             type = TCL_PATH_RELATIVE;
  352. #ifdef DEBUG
  353.                     printf("    TCL_PATH_RELATIVE\n");
  354. #endif
  355.         }
  356.         }
  357.         break;
  358.     
  359.     case TCL_PLATFORM_WINDOWS:
  360.         if (path[0] != '~') {
  361.  
  362.         /*
  363.          * Since we have eliminated the easy cases, check for
  364.          * drive relative paths using the regular expression.
  365.          */
  366.  
  367.         if (!winRootPatternPtr) {
  368.             winRootPatternPtr = TclRegComp(WIN_ROOT_PATTERN);
  369.             if (!initialized) {
  370.             Tcl_CreateExitHandler(FileNameCleanup, NULL);
  371.             initialized = 1;
  372.             }
  373.         }
  374.         if (TclRegExec(winRootPatternPtr, path, path)) {
  375.             if (winRootPatternPtr->startp[5]
  376.                 || (winRootPatternPtr->startp[2]
  377.                     && !(winRootPatternPtr->startp[6]))) {
  378.             type = TCL_PATH_VOLUME_RELATIVE;
  379.             }
  380.         } else {
  381.             type = TCL_PATH_RELATIVE;
  382.         }
  383.         }
  384.         break;
  385.     }
  386.     return type;
  387. }
  388.  
  389. /*
  390.  *----------------------------------------------------------------------
  391.  *
  392.  * Tcl_SplitPath --
  393.  *
  394.  *    Split a path into a list of path components.  The first element
  395.  *    of the list will have the same path type as the original path.
  396.  *
  397.  * Results:
  398.  *    Returns a standard Tcl result.  The interpreter result contains
  399.  *    a list of path components.
  400.  *    *argvPtr will be filled in with the address of an array
  401.  *    whose elements point to the elements of path, in order.
  402.  *    *argcPtr will get filled in with the number of valid elements
  403.  *    in the array.  A single block of memory is dynamically allocated
  404.  *    to hold both the argv array and a copy of the path elements.
  405.  *    The caller must eventually free this memory by calling ckfree()
  406.  *    on *argvPtr.  Note:  *argvPtr and *argcPtr are only modified
  407.  *    if the procedure returns normally.
  408.  *
  409.  * Side effects:
  410.  *    Allocates memory.
  411.  *
  412.  *----------------------------------------------------------------------
  413.  */
  414.  
  415. void
  416. Tcl_SplitPath(path, argcPtr, argvPtr)
  417.     char *path;            /* Pointer to string containing a path. */
  418.     int *argcPtr;        /* Pointer to location to fill in with
  419.                  * the number of elements in the path. */
  420.     char ***argvPtr;        /* Pointer to place to store pointer to array
  421.                  * of pointers to path elements. */
  422. {
  423.     int i, size;
  424.     char *p;
  425.     Tcl_DString buffer;
  426.     Tcl_DStringInit(&buffer);
  427.  
  428. #ifdef DEBUG
  429.     printf("Tcl_SplitPath %s\n", path);
  430. #endif
  431.  
  432.     /*
  433.      * Perform platform specific splitting.  These routines will leave the
  434.      * result in the specified buffer.  Individual elements are terminated
  435.      * with a null character.
  436.      */
  437.  
  438.     p = NULL;            /* Needed only to prevent gcc warnings. */
  439.     switch (tclPlatform) {
  440.        case TCL_PLATFORM_UNIX:
  441.         p = SplitUnixPath(path, &buffer);
  442.         break;
  443.  
  444.         case TCL_PLATFORM_WINDOWS:
  445.             p = SplitWinPath(path, &buffer);
  446.             break;
  447.  
  448.     case TCL_PLATFORM_OS2:
  449.         p = SplitOS2Path(path, &buffer);
  450.         break;
  451.         
  452.     case TCL_PLATFORM_MAC:
  453.         p = SplitMacPath(path, &buffer);
  454.         break;
  455.     }
  456.  
  457.     /*
  458.      * Compute the number of elements in the result.
  459.      */
  460.  
  461.     size = Tcl_DStringLength(&buffer);
  462.     *argcPtr = 0;
  463.     for (i = 0; i < size; i++) {
  464.     if (p[i] == '\0') {
  465.         (*argcPtr)++;
  466.     }
  467.     }
  468.     
  469.     /*
  470.      * Allocate a buffer large enough to hold the contents of the
  471.      * DString plus the argv pointers and the terminating NULL pointer.
  472.      */
  473.  
  474.     *argvPtr = (char **) ckalloc((unsigned)
  475.         ((((*argcPtr) + 1) * sizeof(char *)) + size));
  476.  
  477.     /*
  478.      * Position p after the last argv pointer and copy the contents of
  479.      * the DString.
  480.      */
  481.  
  482.     p = (char *) &(*argvPtr)[(*argcPtr) + 1];
  483.     memcpy((VOID *) p, (VOID *) Tcl_DStringValue(&buffer), (size_t) size);
  484.  
  485.     /*
  486.      * Now set up the argv pointers.
  487.      */
  488.  
  489.     for (i = 0; i < *argcPtr; i++) {
  490.     (*argvPtr)[i] = p;
  491.     while ((*p++) != '\0') {}
  492.     }
  493.     (*argvPtr)[i] = NULL;
  494.  
  495.     Tcl_DStringFree(&buffer);
  496. }
  497.  
  498. /*
  499.  *----------------------------------------------------------------------
  500.  *
  501.  * SplitUnixPath --
  502.  *
  503.  *    This routine is used by Tcl_SplitPath to handle splitting
  504.  *    Unix paths.
  505.  *
  506.  * Results:
  507.  *    Stores a null separated array of strings in the specified
  508.  *    Tcl_DString.
  509.  *
  510.  * Side effects:
  511.  *    None.
  512.  *
  513.  *----------------------------------------------------------------------
  514.  */
  515.  
  516. static char *
  517. SplitUnixPath(path, bufPtr)
  518.     char *path;            /* Pointer to string containing a path. */
  519.     Tcl_DString *bufPtr;    /* Pointer to DString to use for the result. */
  520. {
  521.     int length;
  522.     char *p, *elementStart;
  523.  
  524.     /*
  525.      * Deal with the root directory as a special case.
  526.      */
  527.  
  528.     if (path[0] == '/') {
  529.     Tcl_DStringAppend(bufPtr, "/", 2);
  530.     p = path+1;
  531.     } else {
  532.     p = path;
  533.     }
  534.  
  535.     /*
  536.      * Split on slashes.  Embedded elements that start with tilde will be
  537.      * prefixed with "./" so they are not affected by tilde substitution.
  538.      */
  539.  
  540.     for (;;) {
  541.     elementStart = p;
  542.     while ((*p != '\0') && (*p != '/')) {
  543.         p++;
  544.     }
  545.     length = p - elementStart;
  546.     if (length > 0) {
  547.         if ((elementStart[0] == '~') && (elementStart != path)) {
  548.         Tcl_DStringAppend(bufPtr, "./", 2);
  549.         }
  550.         Tcl_DStringAppend(bufPtr, elementStart, length);
  551.         Tcl_DStringAppend(bufPtr, "", 1);
  552.     }
  553.     if (*p++ == '\0') {
  554.         break;
  555.     }
  556.     }
  557.     return Tcl_DStringValue(bufPtr);
  558. }
  559.  
  560. /*
  561.  *----------------------------------------------------------------------
  562.  *
  563.  * SplitWinPath --
  564.  *
  565.  *    This routine is used by Tcl_SplitPath to handle splitting
  566.  *    Windows paths.
  567.  *
  568.  * Results:
  569.  *    Stores a null separated array of strings in the specified
  570.  *    Tcl_DString.
  571.  *
  572.  * Side effects:
  573.  *    None.
  574.  *
  575.  *----------------------------------------------------------------------
  576.  */
  577.  
  578. static char *
  579. SplitWinPath(path, bufPtr)
  580.     char *path;            /* Pointer to string containing a path. */
  581.     Tcl_DString *bufPtr;    /* Pointer to DString to use for the result. */
  582. {
  583.     int length;
  584.     char *p, *elementStart;
  585.  
  586.     p = ExtractWinRoot(path, bufPtr, 0);
  587.  
  588.     /*
  589.      * Terminate the root portion, if we matched something.
  590.      */
  591.  
  592.     if (p != path) {
  593.     Tcl_DStringAppend(bufPtr, "", 1);
  594.     }
  595.  
  596.     /*
  597.      * Split on slashes.  Embedded elements that start with tilde will be
  598.      * prefixed with "./" so they are not affected by tilde substitution.
  599.      */
  600.  
  601.     do {
  602.     elementStart = p;
  603.     while ((*p != '\0') && (*p != '/') && (*p != '\\')) {
  604.         p++;
  605.     }
  606.     length = p - elementStart;
  607.     if (length > 0) {
  608.         if ((elementStart[0] == '~') && (elementStart != path)) {
  609.         Tcl_DStringAppend(bufPtr, "./", 2);
  610.         }
  611.         Tcl_DStringAppend(bufPtr, elementStart, length);
  612.         Tcl_DStringAppend(bufPtr, "", 1);
  613.     }
  614.     } while (*p++ != '\0');
  615.  
  616.     return Tcl_DStringValue(bufPtr);
  617. }
  618.  
  619. /*
  620.  *----------------------------------------------------------------------
  621.  *
  622.  * SplitOS2Path --
  623.  *
  624.  *    This routine is used by Tcl_SplitPath to handle splitting
  625.  *    OS/2 paths.
  626.  *
  627.  * Results:
  628.  *    Stores a null separated array of strings in the specified
  629.  *    Tcl_DString.
  630.  *
  631.  * Side effects:
  632.  *    None.
  633.  *
  634.  *----------------------------------------------------------------------
  635.  */
  636.  
  637. static char *
  638. SplitOS2Path(path, bufPtr)
  639.     char *path;            /* Pointer to string containing a path. */
  640.     Tcl_DString *bufPtr;    /* Pointer to DString to use for the result. */
  641. {
  642.     int length;
  643.     char *p, *elementStart;
  644.  
  645.     p = ExtractOS2Root(path, bufPtr, 0);
  646.  
  647.     /*
  648.      * Terminate the root portion, if we matched something.
  649.      */
  650.  
  651.     if (p != path) {
  652.     Tcl_DStringAppend(bufPtr, "", 1);
  653.     }
  654.  
  655.     /*
  656.      * Split on slashes.  Embedded elements that start with tilde will be
  657.      * prefixed with "./" so they are not affected by tilde substitution.
  658.      */
  659.  
  660.     do {
  661.     elementStart = p;
  662.     while ((*p != '\0') && (*p != '/') && (*p != '\\')) {
  663.         p++;
  664.     }
  665.     length = p - elementStart;
  666.     if (length > 0) {
  667.         if ((elementStart[0] == '~') && (elementStart != path)) {
  668.         Tcl_DStringAppend(bufPtr, "./", 2);
  669.         }
  670.         Tcl_DStringAppend(bufPtr, elementStart, length);
  671.         Tcl_DStringAppend(bufPtr, "", 1);
  672.     }
  673.     } while (*p++ != '\0');
  674.  
  675.     return Tcl_DStringValue(bufPtr);
  676. }
  677.  
  678. /*
  679.  *----------------------------------------------------------------------
  680.  *
  681.  * SplitMacPath --
  682.  *
  683.  *    This routine is used by Tcl_SplitPath to handle splitting
  684.  *    Macintosh paths.
  685.  *
  686.  * Results:
  687.  *    Returns a newly allocated argv array.
  688.  *
  689.  * Side effects:
  690.  *    None.
  691.  *
  692.  *----------------------------------------------------------------------
  693.  */
  694.  
  695. static char *
  696. SplitMacPath(path, bufPtr)
  697.     char *path;            /* Pointer to string containing a path. */
  698.     Tcl_DString *bufPtr;    /* Pointer to DString to use for the result. */
  699. {
  700.     int isMac = 0;        /* 1 if is Mac-style, 0 if Unix-style path. */
  701.     int i, length;
  702.     char *p, *elementStart;
  703.  
  704.     /*
  705.      * Initialize the path name parser for Macintosh path names.
  706.      */
  707.  
  708.     if (macRootPatternPtr == NULL) {
  709.     macRootPatternPtr = TclRegComp(MAC_ROOT_PATTERN);
  710.     if (!initialized) {
  711.         Tcl_CreateExitHandler(FileNameCleanup, NULL);
  712.         initialized = 1;
  713.     }
  714.     }
  715.  
  716.     /*
  717.      * Match the root portion of a Mac path name.
  718.      */
  719.  
  720.     i = 0;            /* Needed only to prevent gcc warnings. */
  721.     if (TclRegExec(macRootPatternPtr, path, path) == 1) {
  722.     /*
  723.      * Treat degenerate absolute paths like / and /../.. as
  724.      * Mac relative file names for lack of anything else to do.
  725.      */
  726.  
  727.     if (macRootPatternPtr->startp[2] != NULL) {
  728.         Tcl_DStringAppend(bufPtr, ":", 1);
  729.         Tcl_DStringAppend(bufPtr, path, macRootPatternPtr->endp[0]
  730.             - macRootPatternPtr->startp[0] + 1);
  731.         return Tcl_DStringValue(bufPtr);
  732.     }
  733.  
  734.     if (macRootPatternPtr->startp[5] != NULL) {
  735.  
  736.         /*
  737.          * Unix-style tilde prefixed paths.
  738.          */
  739.  
  740.         isMac = 0;
  741.         i = 5;
  742.     } else if (macRootPatternPtr->startp[7] != NULL) {
  743.  
  744.         /*
  745.          * Mac-style tilde prefixed paths.
  746.          */
  747.  
  748.         isMac = 1;
  749.         i = 7;
  750.     } else if (macRootPatternPtr->startp[10] != NULL) {
  751.  
  752.         /*
  753.          * Normal Unix style paths.
  754.          */
  755.  
  756.         isMac = 0;
  757.         i = 10;
  758.     } else if (macRootPatternPtr->startp[12] != NULL) {
  759.  
  760.         /*
  761.          * Normal Mac style paths.
  762.          */
  763.  
  764.         isMac = 1;
  765.         i = 12;
  766.     }
  767.  
  768.     length = macRootPatternPtr->endp[i]
  769.         - macRootPatternPtr->startp[i];
  770.  
  771.     /*
  772.      * Append the element and terminate it with a : and a null.  Note that
  773.      * we are forcing the DString to contain an extra null at the end.
  774.      */
  775.  
  776.     Tcl_DStringAppend(bufPtr, macRootPatternPtr->startp[i], length);
  777.     Tcl_DStringAppend(bufPtr, ":", 2);
  778.     p = macRootPatternPtr->endp[i];
  779.     } else {
  780.     isMac = (strchr(path, ':') != NULL);
  781.     p = path;
  782.     }
  783.     
  784.     if (isMac) {
  785.  
  786.     /*
  787.      * p is pointing at the first colon in the path.  There
  788.      * will always be one, since this is a Mac-style path.
  789.      */
  790.  
  791.     elementStart = p++;
  792.     while ((p = strchr(p, ':')) != NULL) {
  793.         length = p - elementStart;
  794.         if (length == 1) {
  795.         while (*p == ':') {
  796.             Tcl_DStringAppend(bufPtr, "::", 3);
  797.             elementStart = p++;
  798.         }
  799.         } else {
  800.         /*
  801.          * If this is a simple component, drop the leading colon.
  802.          */
  803.  
  804.         if ((elementStart[1] != '~')
  805.             && (strchr(elementStart+1, '/') == NULL)) {
  806.             elementStart++;
  807.             length--;
  808.         }
  809.         Tcl_DStringAppend(bufPtr, elementStart, length);
  810.         Tcl_DStringAppend(bufPtr, "", 1);
  811.         elementStart = p++;
  812.         }
  813.     }
  814.     if (elementStart[1] != '\0' || elementStart == path) {
  815.         if ((elementStart[1] != '~') && (elementStart[1] != '\0')
  816.             && (strchr(elementStart+1, '/') == NULL)) {
  817.             elementStart++;
  818.         }
  819.         Tcl_DStringAppend(bufPtr, elementStart, -1);
  820.         Tcl_DStringAppend(bufPtr, "", 1);
  821.     }
  822.     } else {
  823.  
  824.     /*
  825.      * Split on slashes, suppress extra /'s, and convert .. to ::. 
  826.      */
  827.  
  828.     for (;;) {
  829.         elementStart = p;
  830.         while ((*p != '\0') && (*p != '/')) {
  831.         p++;
  832.         }
  833.         length = p - elementStart;
  834.         if (length > 0) {
  835.         if ((length == 1) && (elementStart[0] == '.')) {
  836.             Tcl_DStringAppend(bufPtr, ":", 2);
  837.         } else if ((length == 2) && (elementStart[0] == '.')
  838.             && (elementStart[1] == '.')) {
  839.             Tcl_DStringAppend(bufPtr, "::", 3);
  840.         } else {
  841.             if (*elementStart == '~') {
  842.             Tcl_DStringAppend(bufPtr, ":", 1);
  843.             }
  844.             Tcl_DStringAppend(bufPtr, elementStart, length);
  845.             Tcl_DStringAppend(bufPtr, "", 1);
  846.         }
  847.         }
  848.         if (*p++ == '\0') {
  849.         break;
  850.         }
  851.     }
  852.     }
  853.     return Tcl_DStringValue(bufPtr);
  854. }
  855.  
  856. /*
  857.  *----------------------------------------------------------------------
  858.  *
  859.  * Tcl_JoinPath --
  860.  *
  861.  *    Combine a list of paths in a platform specific manner.
  862.  *
  863.  * Results:
  864.  *    Appends the joined path to the end of the specified
  865.  *    returning a pointer to the resulting string.  Note that
  866.  *    the Tcl_DString must already be initialized.
  867.  *
  868.  * Side effects:
  869.  *    Modifies the Tcl_DString.
  870.  *
  871.  *----------------------------------------------------------------------
  872.  */
  873.  
  874. char *
  875. Tcl_JoinPath(argc, argv, resultPtr)
  876.     int argc;
  877.     char **argv;
  878.     Tcl_DString *resultPtr;    /* Pointer to previously initialized DString. */
  879. {
  880.     int oldLength, length, i, needsSep;
  881.     Tcl_DString buffer;
  882.     char *p, c, *dest;
  883.  
  884.     Tcl_DStringInit(&buffer);
  885.     oldLength = Tcl_DStringLength(resultPtr);
  886.  
  887.     switch (tclPlatform) {
  888.        case TCL_PLATFORM_UNIX:
  889.         for (i = 0; i < argc; i++) {
  890.         p = argv[i];
  891.         /*
  892.          * If the path is absolute, reset the result buffer.
  893.          * Consume any duplicate leading slashes or a ./ in
  894.          * front of a tilde prefixed path that isn't at the
  895.          * beginning of the path.
  896.          */
  897.  
  898.         if (*p == '/') {
  899.             Tcl_DStringSetLength(resultPtr, oldLength);
  900.             Tcl_DStringAppend(resultPtr, "/", 1);
  901.             while (*p == '/') {
  902.             p++;
  903.             }
  904.         } else if (*p == '~') {
  905.             Tcl_DStringSetLength(resultPtr, oldLength);
  906.         } else if ((Tcl_DStringLength(resultPtr) != oldLength)
  907.             && (p[0] == '.') && (p[1] == '/')
  908.             && (p[2] == '~')) {
  909.             p += 2;
  910.         }
  911.  
  912.         if (*p == '\0') {
  913.             continue;
  914.         }
  915.  
  916.         /*
  917.          * Append a separator if needed.
  918.          */
  919.  
  920.         length = Tcl_DStringLength(resultPtr);
  921.         if ((length != oldLength)
  922.             && (Tcl_DStringValue(resultPtr)[length-1] != '/')) {
  923.             Tcl_DStringAppend(resultPtr, "/", 1);
  924.             length++;
  925.         }
  926.  
  927.         /*
  928.          * Append the element, eliminating duplicate and trailing
  929.          * slashes.
  930.          */
  931.  
  932.         Tcl_DStringSetLength(resultPtr, (int) (length + strlen(p)));
  933.         dest = Tcl_DStringValue(resultPtr) + length;
  934.         for (; *p != '\0'; p++) {
  935.             if (*p == '/') {
  936.             while (p[1] == '/') {
  937.                 p++;
  938.             }
  939.             if (p[1] != '\0') {
  940.                 *dest++ = '/';
  941.             }
  942.             } else {
  943.             *dest++ = *p;
  944.             }
  945.         }
  946.         length = dest - Tcl_DStringValue(resultPtr);
  947.         Tcl_DStringSetLength(resultPtr, length);
  948.         }
  949.         break;
  950.  
  951.         case TCL_PLATFORM_WINDOWS:
  952.             /*
  953.              * Iterate over all of the components.  If a component is
  954.              * absolute, then reset the result and start building the
  955.              * path from the current component on.
  956.              */
  957.  
  958.             for (i = 0; i < argc; i++) {
  959.                 p = ExtractWinRoot(argv[i], resultPtr, oldLength);
  960.                 length = Tcl_DStringLength(resultPtr);
  961.  
  962.                 /*
  963.                  * If the pointer didn't move, then this is a relative path
  964.                  * or a tilde prefixed path.
  965.                  */
  966.  
  967.                 if (p == argv[i]) {
  968.                     /*
  969.                      * Remove the ./ from tilde prefixed elements unless
  970.                      * it is the first component.
  971.                      */
  972.  
  973.                     if ((length != oldLength)
  974.                             && (p[0] == '.')
  975.                             && ((p[1] == '/') || (p[1] == '\\'))
  976.                             && (p[2] == '~')) {
  977.                         p += 2;
  978.                     } else if (*p == '~') {
  979.                         Tcl_DStringSetLength(resultPtr, oldLength);
  980.                         length = oldLength;
  981.                     }
  982.                 }
  983.  
  984.                 if (*p != '\0') {
  985.                     /*
  986.                      * Check to see if we need to append a separator.
  987.                      */
  988.  
  989.  
  990.                     if (length != oldLength) {
  991.                         c = Tcl_DStringValue(resultPtr)[length-1];
  992.                         if ((c != '/') && (c != ':')) {
  993.                             Tcl_DStringAppend(resultPtr, "/", 1);
  994.                         }
  995.                     }
  996.  
  997.                     /*
  998.                      * Append the element, eliminating duplicate and
  999.                      * trailing slashes.
  1000.                      */
  1001.  
  1002.                     length = Tcl_DStringLength(resultPtr);
  1003.                     Tcl_DStringSetLength(resultPtr, (int) (length + strlen(p)));
  1004.                     dest = Tcl_DStringValue(resultPtr) + length;
  1005.                     for (; *p != '\0'; p++) {
  1006.                         if ((*p == '/') || (*p == '\\')) {
  1007.                             while ((p[1] == '/') || (p[1] == '\\')) {
  1008.                                 p++;
  1009.                             }
  1010.                             if (p[1] != '\0') {
  1011.                                 *dest++ = '/';
  1012.                             }
  1013.                         } else {
  1014.                             *dest++ = *p;
  1015.                         }
  1016.                     }
  1017.                     length = dest - Tcl_DStringValue(resultPtr);
  1018.                     Tcl_DStringSetLength(resultPtr, length);
  1019.                 }
  1020.             }
  1021.             break;
  1022.  
  1023.     case TCL_PLATFORM_OS2:
  1024.         /*
  1025.          * Iterate over all of the components.  If a component is
  1026.          * absolute, then reset the result and start building the
  1027.          * path from the current component on.
  1028.          */
  1029.  
  1030.         for (i = 0; i < argc; i++) {
  1031.         p = ExtractOS2Root(argv[i], resultPtr, oldLength);
  1032.         length = Tcl_DStringLength(resultPtr);
  1033.         
  1034.         /*
  1035.          * If the pointer didn't move, then this is a relative path
  1036.          * or a tilde prefixed path.
  1037.          */
  1038.  
  1039.         if (p == argv[i]) {
  1040.             /*
  1041.              * Remove the ./ from tilde prefixed elements unless
  1042.              * it is the first component.
  1043.              */
  1044.  
  1045.             if ((length != oldLength)
  1046.                 && (p[0] == '.')
  1047.                 && ((p[1] == '/') || (p[1] == '\\'))
  1048.                 && (p[2] == '~')) {
  1049.             p += 2;
  1050.             } else if (*p == '~') {
  1051.             Tcl_DStringSetLength(resultPtr, oldLength);
  1052.             length = oldLength;
  1053.             }
  1054.         }
  1055.  
  1056.         if (*p != '\0') {
  1057.             /*
  1058.              * Check to see if we need to append a separator.
  1059.              */
  1060.  
  1061.             
  1062.             if (length != oldLength) {
  1063.             c = Tcl_DStringValue(resultPtr)[length-1];
  1064.             if ((c != '/') && (c != ':')) {
  1065.                 Tcl_DStringAppend(resultPtr, "/", 1);
  1066.             }
  1067.             }
  1068.  
  1069.             /*
  1070.              * Append the element, eliminating duplicate and
  1071.              * trailing slashes.
  1072.              */
  1073.  
  1074.             length = Tcl_DStringLength(resultPtr);
  1075.             Tcl_DStringSetLength(resultPtr, (int) (length + strlen(p)));
  1076.             dest = Tcl_DStringValue(resultPtr) + length;
  1077.             for (; *p != '\0'; p++) {
  1078.             if ((*p == '/') || (*p == '\\')) {
  1079.                 while ((p[1] == '/') || (p[1] == '\\')) {
  1080.                 p++;
  1081.                 }
  1082.                 if (p[1] != '\0') {
  1083.                 *dest++ = '/';
  1084.                 }
  1085.             } else {
  1086.                 *dest++ = *p;
  1087.             }
  1088.             }
  1089.             length = dest - Tcl_DStringValue(resultPtr);
  1090.             Tcl_DStringSetLength(resultPtr, length);
  1091.         }
  1092.         }
  1093.         break;
  1094.  
  1095.     case TCL_PLATFORM_MAC:
  1096.         needsSep = 1;
  1097.         for (i = 0; i < argc; i++) {
  1098.         Tcl_DStringSetLength(&buffer, 0);
  1099.         p = SplitMacPath(argv[i], &buffer);
  1100.         if ((*p != ':') && (*p != '\0')
  1101.             && (strchr(p, ':') != NULL)) {
  1102.             Tcl_DStringSetLength(resultPtr, oldLength);
  1103.             length = strlen(p);
  1104.             Tcl_DStringAppend(resultPtr, p, length);
  1105.             needsSep = 0;
  1106.             p += length+1;
  1107.         }
  1108.  
  1109.         /*
  1110.          * Now append the rest of the path elements, skipping
  1111.          * : unless it is the first element of the path, and
  1112.          * watching out for :: et al. so we don't end up with
  1113.          * too many colons in the result.
  1114.          */
  1115.  
  1116.         for (; *p != '\0'; p += length+1) {
  1117.             if (p[0] == ':' && p[1] == '\0') {
  1118.             if (Tcl_DStringLength(resultPtr) != oldLength) {
  1119.                 p++;
  1120.             } else {
  1121.                 needsSep = 0;
  1122.             }
  1123.             } else {
  1124.             c = p[1];
  1125.             if (*p == ':') {
  1126.                 if (!needsSep) {
  1127.                 p++;
  1128.                 }
  1129.             } else {
  1130.                 if (needsSep) {
  1131.                 Tcl_DStringAppend(resultPtr, ":", 1);
  1132.                 }
  1133.             }
  1134.             needsSep = (c == ':') ? 0 : 1;
  1135.             }
  1136.             length = strlen(p);
  1137.             Tcl_DStringAppend(resultPtr, p, length);
  1138.         }
  1139.         }
  1140.         break;
  1141.                    
  1142.     }
  1143.     Tcl_DStringFree(&buffer);
  1144.     return Tcl_DStringValue(resultPtr);
  1145. }
  1146.  
  1147. /*
  1148.  *----------------------------------------------------------------------
  1149.  *
  1150.  * Tcl_TranslateFileName --
  1151.  *
  1152.  *    Converts a file name into a form usable by the native system
  1153.  *    interfaces.  If the name starts with a tilde, it will produce
  1154.  *    a name where the tilde and following characters have been
  1155.  *    replaced by the home directory location for the named user.
  1156.  *
  1157.  * Results:
  1158.  *    The result is a pointer to a static string containing
  1159.  *    the new name.  If there was an error in processing the
  1160.  *    name, then an error message is left in interp->result
  1161.  *    and the return value is NULL.  The result will be stored
  1162.  *    in bufferPtr; the caller must call Tcl_DStringFree(bufferPtr)
  1163.  *    to free the name if the return value was not NULL.
  1164.  *
  1165.  * Side effects:
  1166.  *    Information may be left in bufferPtr.
  1167.  *
  1168.  *---------------------------------------------------------------------- */
  1169.  
  1170. char *
  1171. Tcl_TranslateFileName(interp, name, bufferPtr)
  1172.     Tcl_Interp *interp;        /* Interpreter in which to store error
  1173.                  * message (if necessary). */
  1174.     char *name;            /* File name, which may begin with "~"
  1175.                  * (to indicate current user's home directory)
  1176.                  * or "~<user>" (to indicate any user's
  1177.                  * home directory). */
  1178.     Tcl_DString *bufferPtr;    /* May be used to hold result.  Must not hold
  1179.                  * anything at the time of the call, and need
  1180.                  * not even be initialized. */
  1181. {
  1182.     register char *p;
  1183.  
  1184.     /*
  1185.      * Handle tilde substitutions, if needed.
  1186.      */
  1187.  
  1188.     if (name[0] == '~') {
  1189.     int argc, length;
  1190.     char **argv;
  1191.     Tcl_DString temp;
  1192.  
  1193.     Tcl_SplitPath(name, &argc, &argv);
  1194.     
  1195.     /*
  1196.      * Strip the trailing ':' off of a Mac path
  1197.      * before passing the user name to DoTildeSubst.
  1198.      */
  1199.  
  1200.     if (tclPlatform == TCL_PLATFORM_MAC) {
  1201.         length = strlen(argv[0]);
  1202.         argv[0][length-1] = '\0';
  1203.     }
  1204.     
  1205.     Tcl_DStringInit(&temp);
  1206.     argv[0] = DoTildeSubst(interp, argv[0]+1, &temp);
  1207.     if (argv[0] == NULL) {
  1208.         Tcl_DStringFree(&temp);
  1209.         ckfree((char *)argv);
  1210.         return NULL;
  1211.     }
  1212.     Tcl_DStringInit(bufferPtr);
  1213.     Tcl_JoinPath(argc, argv, bufferPtr);
  1214.     Tcl_DStringFree(&temp);
  1215.     ckfree((char*)argv);
  1216.     } else {
  1217.     Tcl_DStringInit(bufferPtr);
  1218.     Tcl_JoinPath(1, &name, bufferPtr);
  1219.     }
  1220.  
  1221.     /*
  1222.      * Convert forward slashes to backslashes in OS/2 paths because
  1223.      * some system interfaces don't accept forward slashes.
  1224.      */
  1225.  
  1226.     if (tclPlatform == TCL_PLATFORM_OS2) {
  1227.     for (p = Tcl_DStringValue(bufferPtr); *p != '\0'; p++) {
  1228.         if (*p == '/') {
  1229.         *p = '\\';
  1230.         }
  1231.     }
  1232.     }
  1233.     return Tcl_DStringValue(bufferPtr);
  1234. }
  1235.  
  1236. /*
  1237.  *----------------------------------------------------------------------
  1238.  *
  1239.  * TclGetExtension --
  1240.  *
  1241.  *    This function returns a pointer to the beginning of the
  1242.  *    extension part of a file name.
  1243.  *
  1244.  * Results:
  1245.  *    Returns a pointer into name which indicates where the extension
  1246.  *    starts.  If there is no extension, returns NULL.
  1247.  *
  1248.  * Side effects:
  1249.  *    None.
  1250.  *
  1251.  *----------------------------------------------------------------------
  1252.  */
  1253.  
  1254. char *
  1255. TclGetExtension(name)
  1256.     char *name;            /* File name to parse. */
  1257. {
  1258.     char *p, *lastSep;
  1259.  
  1260.     /*
  1261.      * First find the last directory separator.
  1262.      */
  1263.  
  1264.     lastSep = NULL;        /* Needed only to prevent gcc warnings. */
  1265.     switch (tclPlatform) {
  1266.     case TCL_PLATFORM_UNIX:
  1267.         lastSep = strrchr(name, '/');
  1268.         break;
  1269.  
  1270.     case TCL_PLATFORM_MAC:
  1271.         if (strchr(name, ':') == NULL) {
  1272.         lastSep = strrchr(name, '/');
  1273.         } else {
  1274.         lastSep = strrchr(name, ':');
  1275.         }
  1276.         break;
  1277.  
  1278.         case TCL_PLATFORM_WINDOWS:
  1279.             lastSep = NULL;
  1280.             for (p = name; *p != '\0'; p++) {
  1281.                 if (strchr("/\\:", *p) != NULL) {
  1282.                     lastSep = p;
  1283.                 }
  1284.             }
  1285.             break;
  1286.  
  1287.     case TCL_PLATFORM_OS2:
  1288.         lastSep = NULL;
  1289.         for (p = name; *p != '\0'; p++) {
  1290.         if (strchr("/\\:", *p) != NULL) {
  1291.             lastSep = p;
  1292.         }
  1293.         }
  1294.         break;
  1295.     }
  1296.     p = strrchr(name, '.');
  1297.     if ((p != NULL) && (lastSep != NULL)
  1298.         && (lastSep > p)) {
  1299.     p = NULL;
  1300.     }
  1301.     return p;
  1302. }
  1303.  
  1304. /*
  1305.  *----------------------------------------------------------------------
  1306.  *
  1307.  * DoTildeSubst --
  1308.  *
  1309.  *    Given a string following a tilde, this routine returns the
  1310.  *    corresponding home directory.
  1311.  *
  1312.  * Results:
  1313.  *    The result is a pointer to a static string containing the home
  1314.  *    directory in native format.  If there was an error in processing
  1315.  *    the substitution, then an error message is left in interp->result
  1316.  *    and the return value is NULL.  On success, the results are appended
  1317.  *     to resultPtr, and the contents of resultPtr are returned.
  1318.  *
  1319.  * Side effects:
  1320.  *    Information may be left in resultPtr.
  1321.  *
  1322.  *----------------------------------------------------------------------
  1323.  */
  1324.  
  1325. static char *
  1326. DoTildeSubst(interp, user, resultPtr)
  1327.     Tcl_Interp *interp;        /* Interpreter in which to store error
  1328.                  * message (if necessary). */
  1329.     char *user;            /* Name of user whose home directory should be
  1330.                  * substituted, or "" for current user. */
  1331.     Tcl_DString *resultPtr;    /* May be used to hold result.  Must not hold
  1332.                  * anything at the time of the call, and need
  1333.                  * not even be initialized. */
  1334. {
  1335.     char *dir;
  1336.  
  1337.     if (*user == '\0') {
  1338.     dir = TclGetEnv("HOME");
  1339.     if (dir == NULL) {
  1340.         if (interp) {
  1341.         Tcl_ResetResult(interp);
  1342.         Tcl_AppendResult(interp, "couldn't find HOME environment ",
  1343.             "variable to expand path", (char *) NULL);
  1344.         }
  1345.         return NULL;
  1346.     }
  1347.     Tcl_JoinPath(1, &dir, resultPtr);
  1348.     } else {
  1349.     if (TclGetUserHome(user, resultPtr) == NULL) {
  1350.         if (interp) {
  1351.         Tcl_ResetResult(interp);
  1352.         Tcl_AppendResult(interp, "user \"", user, "\" doesn't exist",
  1353.             (char *) NULL);
  1354.         }
  1355.         return NULL;
  1356.     }
  1357.     }
  1358.     return resultPtr->string;
  1359. }
  1360.  
  1361. /*
  1362.  *----------------------------------------------------------------------
  1363.  *
  1364.  * Tcl_GlobCmd --
  1365.  *
  1366.  *    This procedure is invoked to process the "glob" Tcl command.
  1367.  *    See the user documentation for details on what it does.
  1368.  *
  1369.  * Results:
  1370.  *    A standard Tcl result.
  1371.  *
  1372.  * Side effects:
  1373.  *    See the user documentation.
  1374.  *
  1375.  *----------------------------------------------------------------------
  1376.  */
  1377.  
  1378.     /* ARGSUSED */
  1379. int
  1380. Tcl_GlobCmd(dummy, interp, argc, argv)
  1381.     ClientData dummy;            /* Not used. */
  1382.     Tcl_Interp *interp;            /* Current interpreter. */
  1383.     int argc;                /* Number of arguments. */
  1384.     char **argv;            /* Argument strings. */
  1385. {
  1386.     int i, noComplain, firstArg;
  1387.     char c;
  1388.     int result = TCL_OK;
  1389.     Tcl_DString buffer;
  1390.     char *separators, *head, *tail;
  1391. #ifdef DEBUG
  1392.     printf("Tcl_GlobCmd\n");
  1393. #endif
  1394.  
  1395.     noComplain = 0;
  1396.     for (firstArg = 1; (firstArg < argc) && (argv[firstArg][0] == '-');
  1397.         firstArg++) {
  1398.     if (strcmp(argv[firstArg], "-nocomplain") == 0) {
  1399.         noComplain = 1;
  1400.     } else if (strcmp(argv[firstArg], "--") == 0) {
  1401.         firstArg++;
  1402.         break;
  1403.     } else {
  1404.         Tcl_AppendResult(interp, "bad switch \"", argv[firstArg],
  1405.             "\": must be -nocomplain or --", (char *) NULL);
  1406.         return TCL_ERROR;
  1407.     }
  1408.     }
  1409.     if (firstArg >= argc) {
  1410.     Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
  1411.         " ?switches? name ?name ...?\"", (char *) NULL);
  1412.     return TCL_ERROR;
  1413.     }
  1414.  
  1415.     Tcl_DStringInit(&buffer);
  1416.     separators = NULL;        /* Needed only to prevent gcc warnings. */
  1417.     for (i = firstArg; i < argc; i++) {
  1418.     head = tail = "";
  1419.  
  1420.     switch (tclPlatform) {
  1421.     case TCL_PLATFORM_UNIX:
  1422.         separators = "/";
  1423.         break;
  1424.         case TCL_PLATFORM_WINDOWS:
  1425.             separators = "/\\:";
  1426.             break;
  1427.     case TCL_PLATFORM_OS2:
  1428.         separators = "/\\:";
  1429.         break;
  1430.     case TCL_PLATFORM_MAC:
  1431.         separators = (strchr(argv[i], ':') == NULL) ? "/" : ":";
  1432.         break;
  1433.     }
  1434.  
  1435.     Tcl_DStringSetLength(&buffer, 0);
  1436.  
  1437.     /*
  1438.      * Perform tilde substitution, if needed.
  1439.      */
  1440.  
  1441.     if (argv[i][0] == '~') {
  1442.         char *p;
  1443.  
  1444.         /*
  1445.          * Find the first path separator after the tilde.
  1446.          */
  1447.  
  1448.         for (tail = argv[i]; *tail != '\0'; tail++) {
  1449.         if (*tail == '\\') {
  1450.             if (strchr(separators, tail[1]) != NULL) {
  1451.             break;
  1452.             }
  1453.         } else if (strchr(separators, *tail) != NULL) {
  1454.             break;
  1455.         }
  1456.         }
  1457.  
  1458.         /*
  1459.          * Determine the home directory for the specified user.  Note that
  1460.          * we don't allow special characters in the user name.
  1461.          */
  1462.  
  1463.         c = *tail;
  1464.         *tail = '\0';
  1465.         p = strpbrk(argv[i]+1, "\\[]*?{}");
  1466.         if (p == NULL) {
  1467.         head = DoTildeSubst(interp, argv[i]+1, &buffer);
  1468.         } else {
  1469.         if (!noComplain) {
  1470.             Tcl_ResetResult(interp);
  1471.             Tcl_AppendResult(interp, "globbing characters not ",
  1472.                 "supported in user names", (char *) NULL);
  1473.         }
  1474.         head = NULL;
  1475.         }
  1476.         *tail = c;
  1477.         if (head == NULL) {
  1478.         if (noComplain) {
  1479.             Tcl_ResetResult(interp);
  1480.             continue;
  1481.         } else {
  1482.             result = TCL_ERROR;
  1483.             goto done;
  1484.         }
  1485.         }
  1486.         if (head != Tcl_DStringValue(&buffer)) {
  1487.         Tcl_DStringAppend(&buffer, head, -1);
  1488.         }
  1489.     } else {
  1490.         tail = argv[i];
  1491.     }
  1492.  
  1493.     result = TclDoGlob(interp, separators, &buffer, tail);
  1494.     if (result != TCL_OK) {
  1495.         if (noComplain) {
  1496.         Tcl_ResetResult(interp);
  1497.         continue;
  1498.         } else {
  1499.         goto done;
  1500.         }
  1501.     }
  1502.     }
  1503.  
  1504.     if ((*interp->result == 0) && !noComplain) {
  1505.     char *sep = "";
  1506.  
  1507.     Tcl_AppendResult(interp, "no files matched glob pattern",
  1508.         (argc == 2) ? " \"" : "s \"", (char *) NULL);
  1509.     for (i = firstArg; i < argc; i++) {
  1510.         Tcl_AppendResult(interp, sep, argv[i], (char *) NULL);
  1511.         sep = " ";
  1512.     }
  1513.     Tcl_AppendResult(interp, "\"", (char *) NULL);
  1514.     result = TCL_ERROR;
  1515.     }
  1516. done:
  1517.     Tcl_DStringFree(&buffer);
  1518.     return result;
  1519. }
  1520.  
  1521. /*
  1522.  *----------------------------------------------------------------------
  1523.  *
  1524.  * SkipToChar --
  1525.  *
  1526.  *    This function traverses a glob pattern looking for the next
  1527.  *    unquoted occurance of the specified character at the same braces
  1528.  *    nesting level.
  1529.  *
  1530.  * Results:
  1531.  *    Updates stringPtr to point to the matching character, or to
  1532.  *    the end of the string if nothing matched.  The return value
  1533.  *    is 1 if a match was found at the top level, otherwise it is 0.
  1534.  *
  1535.  * Side effects:
  1536.  *    None.
  1537.  *
  1538.  *----------------------------------------------------------------------
  1539.  */
  1540.  
  1541. static int
  1542. SkipToChar(stringPtr, match)
  1543.     char **stringPtr;            /* Pointer string to check. */
  1544.     char *match;            /* Pointer to character to find. */
  1545. {
  1546.     int quoted, level;
  1547.     register char *p;
  1548.  
  1549.     quoted = 0;
  1550.     level = 0;
  1551.  
  1552.     for (p = *stringPtr; *p != '\0'; p++) {
  1553.     if (quoted) {
  1554.         quoted = 0;
  1555.         continue;
  1556.     }
  1557.     if ((level == 0) && (*p == *match)) {
  1558.         *stringPtr = p;
  1559.         return 1;
  1560.     }
  1561.     if (*p == '{') {
  1562.         level++;
  1563.     } else if (*p == '}') {
  1564.         level--;
  1565.     } else if (*p == '\\') {
  1566.         quoted = 1;
  1567.     }
  1568.     }
  1569.     *stringPtr = p;
  1570.     return 0;
  1571. }
  1572.  
  1573. /*
  1574.  *----------------------------------------------------------------------
  1575.  *
  1576.  * TclDoGlob --
  1577.  *
  1578.  *    This recursive procedure forms the heart of the globbing
  1579.  *    code.  It performs a depth-first traversal of the tree
  1580.  *    given by the path name to be globbed.  The directory and
  1581.  *    remainder are assumed to be native format paths.
  1582.  *
  1583.  * Results:
  1584.  *    The return value is a standard Tcl result indicating whether
  1585.  *    an error occurred in globbing.  After a normal return the
  1586.  *    result in interp will be set to hold all of the file names
  1587.  *    given by the dir and rem arguments.  After an error the
  1588.  *    result in interp will hold an error message.
  1589.  *
  1590.  * Side effects:
  1591.  *    None.
  1592.  *
  1593.  *----------------------------------------------------------------------
  1594.  */
  1595.  
  1596. int
  1597. TclDoGlob(interp, separators, headPtr, tail)
  1598.     Tcl_Interp *interp;        /* Interpreter to use for error reporting
  1599.                  * (e.g. unmatched brace). */
  1600.     char *separators;        /* String containing separator characters
  1601.                  * that should be used to identify globbing
  1602.                  * boundaries. */
  1603.     Tcl_DString *headPtr;    /* Completely expanded prefix. */
  1604.     char *tail;            /* The unexpanded remainder of the path. */
  1605. {
  1606.     int level, baseLength, quoted, count;
  1607.     int result = TCL_OK;
  1608.     char *p, *openBrace, *closeBrace, *name, savedChar;
  1609.     char lastChar = 0;
  1610.     int length = Tcl_DStringLength(headPtr);
  1611. #ifdef DEBUG
  1612.     printf("TclDoGlob\n");
  1613. #endif
  1614.  
  1615.     if (length > 0) {
  1616.     lastChar = Tcl_DStringValue(headPtr)[length-1];
  1617.     }
  1618.  
  1619.     /*
  1620.      * Consume any leading directory separators, leaving tail pointing
  1621.      * just past the last initial separator.
  1622.      */
  1623.  
  1624.     count = 0;
  1625.     name = tail;
  1626.     for (; *tail != '\0'; tail++) {
  1627.     if ((*tail == '\\') && (strchr(separators, tail[1]) != NULL)) {
  1628.         tail++;
  1629.     } else if (strchr(separators, *tail) == NULL) {
  1630.         break;
  1631.     }
  1632.     count++;
  1633.     }
  1634.  
  1635.     /*
  1636.      * Deal with path separators.  On the Mac, we have to watch out
  1637.      * for multiple separators, since they are special in Mac-style
  1638.      * paths.
  1639.      */
  1640.  
  1641.     switch (tclPlatform) {
  1642.     case TCL_PLATFORM_MAC:
  1643.         if (*separators == '/') {
  1644.         if (((length == 0) && (count == 0))
  1645.             || ((length > 0) && (lastChar != ':'))) {
  1646.             Tcl_DStringAppend(headPtr, ":", 1);
  1647.         }
  1648.         } else {
  1649.         if (count == 0) {
  1650.             if ((length > 0) && (lastChar != ':')) {
  1651.             Tcl_DStringAppend(headPtr, ":", 1);
  1652.             }
  1653.         } else {
  1654.             if (lastChar == ':') {
  1655.             count--;
  1656.             }
  1657.             while (count-- > 0) {
  1658.             Tcl_DStringAppend(headPtr, ":", 1);
  1659.             }
  1660.         }
  1661.         }
  1662.         break;
  1663.  
  1664.         case TCL_PLATFORM_WINDOWS:
  1665.             /*
  1666.              * If this is a drive relative path, add the colon and the
  1667.              * trailing slash if needed.  Otherwise add the slash if
  1668.              * this is the first absolute element, or a later relative
  1669.              * element.  Add an extra slash if this is a UNC path.
  1670.              */
  1671.  
  1672.             if (*name == ':') {
  1673.                 Tcl_DStringAppend(headPtr, ":", 1);
  1674.                 if (count > 1) {
  1675.                     Tcl_DStringAppend(headPtr, "/", 1);
  1676.                 }
  1677.             } else if ((*tail != '\0')
  1678.                     && (((length > 0)
  1679.                             && (strchr(separators, lastChar) == NULL))
  1680.                             || ((length == 0) && (count > 0)))) {
  1681.                 Tcl_DStringAppend(headPtr, "/", 1);
  1682.                 if ((length == 0) && (count > 1)) {
  1683.                     Tcl_DStringAppend(headPtr, "/", 1);
  1684.                 }
  1685.             }
  1686.  
  1687.             break;
  1688.  
  1689.     case TCL_PLATFORM_OS2:
  1690.         /*
  1691.          * If this is a drive relative path, add the colon and the
  1692.          * trailing slash if needed.  Otherwise add the slash if
  1693.          * this is the first absolute element, or a later relative
  1694.          * element.  Add an extra slash if this is a UNC path.
  1695.          */
  1696.  
  1697.         if (*name == ':') {
  1698.         Tcl_DStringAppend(headPtr, ":", 1);
  1699.         if (count > 1) {
  1700.             Tcl_DStringAppend(headPtr, "/", 1);
  1701.         }
  1702.         } else if ((*tail != '\0')
  1703.             && (((length > 0)
  1704.                 && (strchr(separators, lastChar) == NULL))
  1705.                 || ((length == 0) && (count > 0)))) {
  1706.         Tcl_DStringAppend(headPtr, "/", 1);
  1707.         if ((length == 0) && (count > 1)) {
  1708.             Tcl_DStringAppend(headPtr, "/", 1);
  1709.         }
  1710.         }
  1711.         
  1712.         break;
  1713.     case TCL_PLATFORM_UNIX:
  1714.         /*
  1715.          * Add a separator if this is the first absolute element, or
  1716.          * a later relative element.
  1717.          */
  1718.  
  1719.         if ((*tail != '\0')
  1720.             && (((length > 0)
  1721.                 && (strchr(separators, lastChar) == NULL))
  1722.                 || ((length == 0) && (count > 0)))) {
  1723.         Tcl_DStringAppend(headPtr, "/", 1);
  1724.         }
  1725.         break;
  1726.     }
  1727.  
  1728.     /*
  1729.      * Look for the first matching pair of braces or the first
  1730.      * directory separator that is not inside a pair of braces.
  1731.      */
  1732.  
  1733.     openBrace = closeBrace = NULL;
  1734.     level = 0;
  1735.     quoted = 0;
  1736.     for (p = tail; *p != '\0'; p++) {
  1737.     if (quoted) {
  1738.         quoted = 0;
  1739.     } else if (*p == '\\') {
  1740.         quoted = 1;
  1741.         if (strchr(separators, p[1]) != NULL) {
  1742.         break;            /* Quoted directory separator. */
  1743.         }
  1744.     } else if (strchr(separators, *p) != NULL) {
  1745.         break;            /* Unquoted directory separator. */
  1746.     } else if (*p == '{') {
  1747.         openBrace = p;
  1748.         p++;
  1749.         if (SkipToChar(&p, "}")) {
  1750.         closeBrace = p;        /* Balanced braces. */
  1751.         break;
  1752.         }
  1753.         Tcl_ResetResult(interp);
  1754.         interp->result = "unmatched open-brace in file name";
  1755.         return TCL_ERROR;
  1756.     } else if (*p == '}') {
  1757.         Tcl_ResetResult(interp);
  1758.         interp->result = "unmatched close-brace in file name";
  1759.         return TCL_ERROR;
  1760.     }
  1761.     }
  1762.  
  1763.     /*
  1764.      * Substitute the alternate patterns from the braces and recurse.
  1765.      */
  1766.  
  1767.     if (openBrace != NULL) {
  1768.     char *element;
  1769.     Tcl_DString newName;
  1770.     Tcl_DStringInit(&newName);
  1771.  
  1772.     /*
  1773.      * For each element within in the outermost pair of braces,
  1774.      * append the element and the remainder to the fixed portion
  1775.      * before the first brace and recursively call TclDoGlob.
  1776.      */
  1777.  
  1778.     Tcl_DStringAppend(&newName, tail, openBrace-tail);
  1779.     baseLength = Tcl_DStringLength(&newName);
  1780.     length = Tcl_DStringLength(headPtr);
  1781.     *closeBrace = '\0';
  1782.     for (p = openBrace; p != closeBrace; ) {
  1783.         p++;
  1784.         element = p;
  1785.         SkipToChar(&p, ",");
  1786.         Tcl_DStringSetLength(headPtr, length);
  1787.         Tcl_DStringSetLength(&newName, baseLength);
  1788.         Tcl_DStringAppend(&newName, element, p-element);
  1789.         Tcl_DStringAppend(&newName, closeBrace+1, -1);
  1790.         result = TclDoGlob(interp, separators,
  1791.             headPtr, Tcl_DStringValue(&newName));
  1792.         if (result != TCL_OK) {
  1793.         break;
  1794.         }
  1795.     }
  1796.     *closeBrace = '}';
  1797.     Tcl_DStringFree(&newName);
  1798.     return result;
  1799.     }
  1800.  
  1801.     /*
  1802.      * At this point, there are no more brace substitutions to perform on
  1803.      * this path component.  The variable p is pointing at a quoted or
  1804.      * unquoted directory separator or the end of the string.  So we need
  1805.      * to check for special globbing characters in the current pattern.
  1806.      */
  1807.  
  1808.     savedChar = *p;
  1809.     *p = '\0';
  1810.  
  1811.     if (strpbrk(tail, "*[]?\\") != NULL) {
  1812.     *p = savedChar;
  1813.     /*
  1814.      * Look for matching files in the current directory.  The
  1815.      * implementation of this function is platform specific, but may
  1816.      * recursively call TclDoGlob.  For each file that matches, it will
  1817.      * add the match onto the interp->result, or call TclDoGlob if there
  1818.      * are more characters to be processed.
  1819.      */
  1820.  
  1821.     return TclMatchFiles(interp, separators, headPtr, tail, p);
  1822.     }
  1823.     *p = savedChar;
  1824.     Tcl_DStringAppend(headPtr, tail, p-tail);
  1825.     if (*p != '\0') {
  1826.     return TclDoGlob(interp, separators, headPtr, p);
  1827.     }
  1828.  
  1829.     /*
  1830.      * There are no more wildcards in the pattern and no more unprocessed
  1831.      * characters in the tail, so now we can construct the path and verify
  1832.      * the existence of the file.
  1833.      */
  1834.  
  1835.     switch (tclPlatform) {
  1836.     case TCL_PLATFORM_MAC:
  1837.         if (strchr(Tcl_DStringValue(headPtr), ':') == NULL) {
  1838.         Tcl_DStringAppend(headPtr, ":", 1);
  1839.         }
  1840.         name = Tcl_DStringValue(headPtr);
  1841.         if (access(name, F_OK) == 0) {
  1842.         if ((name[1] != '\0') && (strchr(name+1, ':') == NULL)) {
  1843.             Tcl_AppendElement(interp, name+1);
  1844.         } else {
  1845.             Tcl_AppendElement(interp, name);
  1846.         }
  1847.         }
  1848.         break;
  1849.         case TCL_PLATFORM_WINDOWS: {
  1850.             int exists;
  1851.             /*
  1852.              * We need to convert slashes to backslashes before checking
  1853.              * for the existence of the file.  Once we are done, we need
  1854.              * to convert the slashes back.
  1855.              */
  1856.  
  1857.             if (Tcl_DStringLength(headPtr) == 0) {
  1858.                 if (((*name == '\\') && (name[1] == '/' || name[1] == '\\'))
  1859.                         || (*name == '/')) {
  1860.                     Tcl_DStringAppend(headPtr, "\\", 1);
  1861.                 } else {
  1862.                     Tcl_DStringAppend(headPtr, ".", 1);
  1863.                 }
  1864.             } else {
  1865.                 for (p = Tcl_DStringValue(headPtr); *p != '\0'; p++) {
  1866.                     if (*p == '/') {
  1867.                         *p = '\\';
  1868.                     }
  1869.                 }
  1870.             }
  1871.             name = Tcl_DStringValue(headPtr);
  1872.             exists = (access(name, F_OK) == 0);
  1873.             for (p = name; *p != '\0'; p++) {
  1874.                 if (*p == '\\') {
  1875.                     *p = '/';
  1876.                 }
  1877.             }
  1878.             if (exists) {
  1879.                 Tcl_AppendElement(interp, name);
  1880.             }
  1881.             break;
  1882.         }
  1883.     case TCL_PLATFORM_OS2: {
  1884.         int exists;
  1885.         /*
  1886.          * We need to convert slashes to backslashes before checking
  1887.          * for the existence of the file.  Once we are done, we need
  1888.          * to convert the slashes back.
  1889.          */
  1890.  
  1891.         if (Tcl_DStringLength(headPtr) == 0) {
  1892.         if (((*name == '\\') && (name[1] == '/' || name[1] == '\\'))
  1893.             || (*name == '/')) {
  1894.             Tcl_DStringAppend(headPtr, "\\", 1);
  1895.         } else {
  1896.             Tcl_DStringAppend(headPtr, ".", 1);
  1897.         }
  1898.         } else {
  1899.         for (p = Tcl_DStringValue(headPtr); *p != '\0'; p++) {
  1900.             if (*p == '/') {
  1901.             *p = '\\';
  1902.             }
  1903.         }
  1904.         }
  1905.         name = Tcl_DStringValue(headPtr);
  1906.         exists = (access(name, F_OK) == 0);
  1907.         for (p = name; *p != '\0'; p++) {
  1908.         if (*p == '\\') {
  1909.             *p = '/';
  1910.         }
  1911.         }
  1912.         if (exists) {
  1913.         Tcl_AppendElement(interp, name);
  1914.         }
  1915.         break;
  1916.     }
  1917.     case TCL_PLATFORM_UNIX:
  1918.         if (Tcl_DStringLength(headPtr) == 0) {
  1919.         if ((*name == '\\' && name[1] == '/') || (*name == '/')) {
  1920.             Tcl_DStringAppend(headPtr, "/", 1);
  1921.         } else {
  1922.             Tcl_DStringAppend(headPtr, ".", 1);
  1923.         }
  1924.         }
  1925.         name = Tcl_DStringValue(headPtr);
  1926.         if (access(name, F_OK) == 0) {
  1927.         Tcl_AppendElement(interp, name);
  1928.         }
  1929.         break;
  1930.     }
  1931.  
  1932.     return TCL_OK;
  1933. }
  1934.