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