Planet
navi homePPSaboutscreenshotsdownloaddevelopmentforum

source: downloads/tcl8.5.2/generic/tclFileName.c @ 63

Last change on this file since 63 was 25, checked in by landauf, 17 years ago

added tcl to libs

File size: 63.9 KB
Line 
1/*
2 * tclFileName.c --
3 *
4 *      This file contains routines for converting file names betwen native
5 *      and network form.
6 *
7 * Copyright (c) 1995-1998 Sun Microsystems, Inc.
8 * Copyright (c) 1998-1999 by Scriptics Corporation.
9 *
10 * See the file "license.terms" for information on usage and redistribution of
11 * this file, and for a DISCLAIMER OF ALL WARRANTIES.
12 *
13 * RCS: @(#) $Id: tclFileName.c,v 1.86 2007/12/13 15:23:17 dgp Exp $
14 */
15
16#include "tclInt.h"
17#include "tclRegexp.h"
18#include "tclFileSystem.h" /* For TclGetPathType() */
19
20/*
21 * The following variable is set in the TclPlatformInit call to one of:
22 * TCL_PLATFORM_UNIX or TCL_PLATFORM_WINDOWS.
23 */
24
25TclPlatformType tclPlatform = TCL_PLATFORM_UNIX;
26
27/*
28 * Prototypes for local procedures defined in this file:
29 */
30
31static const char *     DoTildeSubst(Tcl_Interp *interp,
32                            const char *user, Tcl_DString *resultPtr);
33static const char *     ExtractWinRoot(const char *path,
34                            Tcl_DString *resultPtr, int offset,
35                            Tcl_PathType *typePtr);
36static int              SkipToChar(char **stringPtr, int match);
37static Tcl_Obj*         SplitWinPath(const char *path);
38static Tcl_Obj*         SplitUnixPath(const char *path);
39static int              DoGlob(Tcl_Interp *interp, Tcl_Obj *resultPtr,
40                            const char *separators, Tcl_Obj *pathPtr, int flags,
41                            char *pattern, Tcl_GlobTypeData *types);
42
43/*
44 *----------------------------------------------------------------------
45 *
46 * SetResultLength --
47 *
48 *      Resets the result DString for ExtractWinRoot to accommodate
49 *      any NT extended path prefixes.
50 *
51 * Results:
52 *      None.
53 *
54 * Side effects:
55 *      May modify the Tcl_DString.
56 *----------------------------------------------------------------------
57 */
58
59static void
60SetResultLength(
61    Tcl_DString *resultPtr,
62    int offset,
63    int extended)
64{
65    Tcl_DStringSetLength(resultPtr, offset);
66    if (extended == 2) {
67        Tcl_DStringAppend(resultPtr, "//?/UNC/", 8);
68    } else if (extended == 1) {
69        Tcl_DStringAppend(resultPtr, "//?/", 4);
70    }
71}
72
73/*
74 *----------------------------------------------------------------------
75 *
76 * ExtractWinRoot --
77 *
78 *      Matches the root portion of a Windows path and appends it to the
79 *      specified Tcl_DString.
80 *
81 * Results:
82 *      Returns the position in the path immediately after the root including
83 *      any trailing slashes. Appends a cleaned up version of the root to the
84 *      Tcl_DString at the specified offest.
85 *
86 * Side effects:
87 *      Modifies the specified Tcl_DString.
88 *
89 *----------------------------------------------------------------------
90 */
91
92static const char *
93ExtractWinRoot(
94    const char *path,           /* Path to parse. */
95    Tcl_DString *resultPtr,     /* Buffer to hold result. */
96    int offset,                 /* Offset in buffer where result should be
97                                 * stored. */
98    Tcl_PathType *typePtr)      /* Where to store pathType result */
99{
100    int extended = 0;
101
102    if (   (path[0] == '/' || path[0] == '\\')
103        && (path[1] == '/' || path[1] == '\\')
104        && (path[2] == '?')
105        && (path[3] == '/' || path[3] == '\\')) {
106        extended = 1;
107        path = path + 4;
108        if (path[0] == 'U' && path[1] == 'N' && path[2] == 'C'
109            && (path[3] == '/' || path[3] == '\\')) {
110            extended = 2;
111            path = path + 4;
112        }
113    }
114
115    if (path[0] == '/' || path[0] == '\\') {
116        /*
117         * Might be a UNC or Vol-Relative path.
118         */
119
120        const char *host, *share, *tail;
121        int hlen, slen;
122
123        if (path[1] != '/' && path[1] != '\\') {
124            SetResultLength(resultPtr, offset, extended);
125            *typePtr = TCL_PATH_VOLUME_RELATIVE;
126            Tcl_DStringAppend(resultPtr, "/", 1);
127            return &path[1];
128        }
129        host = &path[2];
130
131        /*
132         * Skip separators.
133         */
134
135        while (host[0] == '/' || host[0] == '\\') {
136            host++;
137        }
138
139        for (hlen = 0; host[hlen];hlen++) {
140            if (host[hlen] == '/' || host[hlen] == '\\') {
141                break;
142            }
143        }
144        if (host[hlen] == 0 || host[hlen+1] == 0) {
145            /*
146             * The path given is simply of the form '/foo', '//foo',
147             * '/////foo' or the same with backslashes. If there is exactly
148             * one leading '/' the path is volume relative (see filename man
149             * page). If there are more than one, we are simply assuming they
150             * are superfluous and we trim them away. (An alternative
151             * interpretation would be that it is a host name, but we have
152             * been documented that that is not the case).
153             */
154
155            *typePtr = TCL_PATH_VOLUME_RELATIVE;
156            Tcl_DStringAppend(resultPtr, "/", 1);
157            return &path[2];
158        }
159        SetResultLength(resultPtr, offset, extended);
160        share = &host[hlen];
161
162        /*
163         * Skip separators.
164         */
165
166        while (share[0] == '/' || share[0] == '\\') {
167            share++;
168        }
169
170        for (slen=0; share[slen]; slen++) {
171            if (share[slen] == '/' || share[slen] == '\\') {
172                break;
173            }
174        }
175        Tcl_DStringAppend(resultPtr, "//", 2);
176        Tcl_DStringAppend(resultPtr, host, hlen);
177        Tcl_DStringAppend(resultPtr, "/", 1);
178        Tcl_DStringAppend(resultPtr, share, slen);
179
180        tail = &share[slen];
181
182        /*
183         * Skip separators.
184         */
185
186        while (tail[0] == '/' || tail[0] == '\\') {
187            tail++;
188        }
189
190        *typePtr = TCL_PATH_ABSOLUTE;
191        return tail;
192    } else if (*path && path[1] == ':') {
193        /*
194         * Might be a drive separator.
195         */
196
197        SetResultLength(resultPtr, offset, extended);
198
199        if (path[2] != '/' && path[2] != '\\') {
200            *typePtr = TCL_PATH_VOLUME_RELATIVE;
201            Tcl_DStringAppend(resultPtr, path, 2);
202            return &path[2];
203        } else {
204            char *tail = (char*)&path[3];
205
206            /*
207             * Skip separators.
208             */
209
210            while (*tail && (tail[0] == '/' || tail[0] == '\\')) {
211                tail++;
212            }
213
214            *typePtr = TCL_PATH_ABSOLUTE;
215            Tcl_DStringAppend(resultPtr, path, 2);
216            Tcl_DStringAppend(resultPtr, "/", 1);
217
218            return tail;
219        }
220    } else {
221        int abs = 0;
222
223        /*
224         * Check for Windows devices.
225         */
226
227        if ((path[0] == 'c' || path[0] == 'C')
228                && (path[1] == 'o' || path[1] == 'O')) {
229            if ((path[2] == 'm' || path[2] == 'M')
230                    && path[3] >= '1' && path[3] <= '4') {
231                /*
232                 * May have match for 'com[1-4]:?', which is a serial port.
233                 */
234
235                if (path[4] == '\0') {
236                    abs = 4;
237                } else if (path [4] == ':' && path[5] == '\0') {
238                    abs = 5;
239                }
240
241            } else if ((path[2] == 'n' || path[2] == 'N') && path[3] == '\0') {
242                /*
243                 * Have match for 'con'.
244                 */
245
246                abs = 3;
247            }
248
249        } else if ((path[0] == 'l' || path[0] == 'L')
250                && (path[1] == 'p' || path[1] == 'P')
251                && (path[2] == 't' || path[2] == 'T')) {
252            if (path[3] >= '1' && path[3] <= '3') {
253                /*
254                 * May have match for 'lpt[1-3]:?'
255                 */
256
257                if (path[4] == '\0') {
258                    abs = 4;
259                } else if (path [4] == ':' && path[5] == '\0') {
260                    abs = 5;
261                }
262            }
263
264        } else if ((path[0] == 'p' || path[0] == 'P')
265                && (path[1] == 'r' || path[1] == 'R')
266                && (path[2] == 'n' || path[2] == 'N')
267                && path[3] == '\0') {
268            /*
269             * Have match for 'prn'.
270             */
271            abs = 3;
272
273        } else if ((path[0] == 'n' || path[0] == 'N')
274                && (path[1] == 'u' || path[1] == 'U')
275                && (path[2] == 'l' || path[2] == 'L')
276                && path[3] == '\0') {
277            /*
278             * Have match for 'nul'.
279             */
280
281            abs = 3;
282
283        } else if ((path[0] == 'a' || path[0] == 'A')
284                && (path[1] == 'u' || path[1] == 'U')
285                && (path[2] == 'x' || path[2] == 'X')
286                && path[3] == '\0') {
287            /*
288             * Have match for 'aux'.
289             */
290
291            abs = 3;
292        }
293
294        if (abs != 0) {
295            *typePtr = TCL_PATH_ABSOLUTE;
296            SetResultLength(resultPtr, offset, extended);
297            Tcl_DStringAppend(resultPtr, path, abs);
298            return path + abs;
299        }
300    }
301
302    /*
303     * Anything else is treated as relative.
304     */
305
306    *typePtr = TCL_PATH_RELATIVE;
307    return path;
308}
309
310/*
311 *----------------------------------------------------------------------
312 *
313 * Tcl_GetPathType --
314 *
315 *      Determines whether a given path is relative to the current directory,
316 *      relative to the current volume, or absolute.
317 *
318 *      The objectified Tcl_FSGetPathType should be used in preference to this
319 *      function (as you can see below, this is just a wrapper around that
320 *      other function).
321 *
322 * Results:
323 *      Returns one of TCL_PATH_ABSOLUTE, TCL_PATH_RELATIVE, or
324 *      TCL_PATH_VOLUME_RELATIVE.
325 *
326 * Side effects:
327 *      None.
328 *
329 *----------------------------------------------------------------------
330 */
331
332Tcl_PathType
333Tcl_GetPathType(
334    const char *path)
335{
336    Tcl_PathType type;
337    Tcl_Obj *tempObj = Tcl_NewStringObj(path,-1);
338
339    Tcl_IncrRefCount(tempObj);
340    type = Tcl_FSGetPathType(tempObj);
341    Tcl_DecrRefCount(tempObj);
342    return type;
343}
344
345/*
346 *----------------------------------------------------------------------
347 *
348 * TclpGetNativePathType --
349 *
350 *      Determines whether a given path is relative to the current directory,
351 *      relative to the current volume, or absolute, but ONLY FOR THE NATIVE
352 *      FILESYSTEM. This function is called from tclIOUtil.c (but needs to be
353 *      here due to its dependence on static variables/functions in this
354 *      file). The exported function Tcl_FSGetPathType should be used by
355 *      extensions.
356 *
357 *      Note that '~' paths are always considered TCL_PATH_ABSOLUTE, even
358 *      though expanding the '~' could lead to any possible path type. This
359 *      function should therefore be considered a low-level, string
360 *      manipulation function only -- it doesn't actually do any expansion in
361 *      making its determination.
362 *
363 * Results:
364 *      Returns one of TCL_PATH_ABSOLUTE, TCL_PATH_RELATIVE, or
365 *      TCL_PATH_VOLUME_RELATIVE.
366 *
367 * Side effects:
368 *      None.
369 *
370 *----------------------------------------------------------------------
371 */
372
373Tcl_PathType
374TclpGetNativePathType(
375    Tcl_Obj *pathPtr,           /* Native path of interest */
376    int *driveNameLengthPtr,    /* Returns length of drive, if non-NULL and
377                                 * path was absolute */
378    Tcl_Obj **driveNameRef)
379{
380    Tcl_PathType type = TCL_PATH_ABSOLUTE;
381    int pathLen;
382    char *path = Tcl_GetStringFromObj(pathPtr, &pathLen);
383
384    if (path[0] == '~') {
385        /*
386         * This case is common to all platforms. Paths that begin with ~ are
387         * absolute.
388         */
389
390        if (driveNameLengthPtr != NULL) {
391            char *end = path + 1;
392            while ((*end != '\0') && (*end != '/')) {
393                end++;
394            }
395            *driveNameLengthPtr = end - path;
396        }
397    } else {
398        switch (tclPlatform) {
399        case TCL_PLATFORM_UNIX: {
400            char *origPath = path;
401
402            /*
403             * Paths that begin with / are absolute.
404             */
405
406#ifdef __QNX__
407            /*
408             * Check for QNX //<node id> prefix
409             */
410            if (*path && (pathLen > 3) && (path[0] == '/')
411                    && (path[1] == '/') && isdigit(UCHAR(path[2]))) {
412                path += 3;
413                while (isdigit(UCHAR(*path))) {
414                    ++path;
415                }
416            }
417#endif
418            if (path[0] == '/') {
419                if (driveNameLengthPtr != NULL) {
420                    /*
421                     * We need this addition in case the QNX code was used.
422                     */
423
424                    *driveNameLengthPtr = (1 + path - origPath);
425                }
426            } else {
427                type = TCL_PATH_RELATIVE;
428            }
429            break;
430        }
431        case TCL_PLATFORM_WINDOWS: {
432            Tcl_DString ds;
433            const char *rootEnd;
434
435            Tcl_DStringInit(&ds);
436            rootEnd = ExtractWinRoot(path, &ds, 0, &type);
437            if ((rootEnd != path) && (driveNameLengthPtr != NULL)) {
438                *driveNameLengthPtr = rootEnd - path;
439                if (driveNameRef != NULL) {
440                    *driveNameRef = Tcl_NewStringObj(Tcl_DStringValue(&ds),
441                            Tcl_DStringLength(&ds));
442                    Tcl_IncrRefCount(*driveNameRef);
443                }
444            }
445            Tcl_DStringFree(&ds);
446            break;
447        }
448        }
449    }
450    return type;
451}
452
453/*
454 *---------------------------------------------------------------------------
455 *
456 * TclpNativeSplitPath --
457 *
458 *      This function takes the given Tcl_Obj, which should be a valid path,
459 *      and returns a Tcl List object containing each segment of that path as
460 *      an element.
461 *
462 *      Note this function currently calls the older Split(Plat)Path
463 *      functions, which require more memory allocation than is desirable.
464 *
465 * Results:
466 *      Returns list object with refCount of zero. If the passed in lenPtr is
467 *      non-NULL, we use it to return the number of elements in the returned
468 *      list.
469 *
470 * Side effects:
471 *      None.
472 *
473 *---------------------------------------------------------------------------
474 */
475
476Tcl_Obj *
477TclpNativeSplitPath(
478    Tcl_Obj *pathPtr,           /* Path to split. */
479    int *lenPtr)                /* int to store number of path elements. */
480{
481    Tcl_Obj *resultPtr = NULL;  /* Needed only to prevent gcc warnings. */
482
483    /*
484     * Perform platform specific splitting.
485     */
486
487    switch (tclPlatform) {
488    case TCL_PLATFORM_UNIX:
489        resultPtr = SplitUnixPath(Tcl_GetString(pathPtr));
490        break;
491
492    case TCL_PLATFORM_WINDOWS:
493        resultPtr = SplitWinPath(Tcl_GetString(pathPtr));
494        break;
495    }
496
497    /*
498     * Compute the number of elements in the result.
499     */
500
501    if (lenPtr != NULL) {
502        Tcl_ListObjLength(NULL, resultPtr, lenPtr);
503    }
504    return resultPtr;
505}
506
507/*
508 *----------------------------------------------------------------------
509 *
510 * Tcl_SplitPath --
511 *
512 *      Split a path into a list of path components. The first element of the
513 *      list will have the same path type as the original path.
514 *
515 * Results:
516 *      Returns a standard Tcl result. The interpreter result contains a list
517 *      of path components. *argvPtr will be filled in with the address of an
518 *      array whose elements point to the elements of path, in order.
519 *      *argcPtr will get filled in with the number of valid elements in the
520 *      array. A single block of memory is dynamically allocated to hold both
521 *      the argv array and a copy of the path elements. The caller must
522 *      eventually free this memory by calling ckfree() on *argvPtr. Note:
523 *      *argvPtr and *argcPtr are only modified if the procedure returns
524 *      normally.
525 *
526 * Side effects:
527 *      Allocates memory.
528 *
529 *----------------------------------------------------------------------
530 */
531
532void
533Tcl_SplitPath(
534    const char *path,           /* Pointer to string containing a path. */
535    int *argcPtr,               /* Pointer to location to fill in with the
536                                 * number of elements in the path. */
537    const char ***argvPtr)      /* Pointer to place to store pointer to array
538                                 * of pointers to path elements. */
539{
540    Tcl_Obj *resultPtr = NULL;  /* Needed only to prevent gcc warnings. */
541    Tcl_Obj *tmpPtr, *eltPtr;
542    int i, size, len;
543    char *p, *str;
544
545    /*
546     * Perform the splitting, using objectified, vfs-aware code.
547     */
548
549    tmpPtr = Tcl_NewStringObj(path, -1);
550    Tcl_IncrRefCount(tmpPtr);
551    resultPtr = Tcl_FSSplitPath(tmpPtr, argcPtr);
552    Tcl_IncrRefCount(resultPtr);
553    Tcl_DecrRefCount(tmpPtr);
554
555    /*
556     * Calculate space required for the result.
557     */
558
559    size = 1;
560    for (i = 0; i < *argcPtr; i++) {
561        Tcl_ListObjIndex(NULL, resultPtr, i, &eltPtr);
562        Tcl_GetStringFromObj(eltPtr, &len);
563        size += len + 1;
564    }
565
566    /*
567     * Allocate a buffer large enough to hold the contents of all of the list
568     * plus the argv pointers and the terminating NULL pointer.
569     */
570
571    *argvPtr = (const char **) ckalloc((unsigned)
572            ((((*argcPtr) + 1) * sizeof(char *)) + size));
573
574    /*
575     * Position p after the last argv pointer and copy the contents of the
576     * list in, piece by piece.
577     */
578
579    p = (char *) &(*argvPtr)[(*argcPtr) + 1];
580    for (i = 0; i < *argcPtr; i++) {
581        Tcl_ListObjIndex(NULL, resultPtr, i, &eltPtr);
582        str = Tcl_GetStringFromObj(eltPtr, &len);
583        memcpy(p, str, (size_t) len+1);
584        p += len+1;
585    }
586
587    /*
588     * Now set up the argv pointers.
589     */
590
591    p = (char *) &(*argvPtr)[(*argcPtr) + 1];
592
593    for (i = 0; i < *argcPtr; i++) {
594        (*argvPtr)[i] = p;
595        for (; *(p++)!='\0'; );
596    }
597    (*argvPtr)[i] = NULL;
598
599    /*
600     * Free the result ptr given to us by Tcl_FSSplitPath
601     */
602
603    Tcl_DecrRefCount(resultPtr);
604}
605
606/*
607 *----------------------------------------------------------------------
608 *
609 * SplitUnixPath --
610 *
611 *      This routine is used by Tcl_(FS)SplitPath to handle splitting Unix
612 *      paths.
613 *
614 * Results:
615 *      Returns a newly allocated Tcl list object.
616 *
617 * Side effects:
618 *      None.
619 *
620 *----------------------------------------------------------------------
621 */
622
623static Tcl_Obj *
624SplitUnixPath(
625    const char *path)           /* Pointer to string containing a path. */
626{
627    int length;
628    const char *p, *elementStart;
629    Tcl_Obj *result = Tcl_NewObj();
630
631    /*
632     * Deal with the root directory as a special case.
633     */
634
635#ifdef __QNX__
636    /*
637     * Check for QNX //<node id> prefix
638     */
639    if ((path[0] == '/') && (path[1] == '/')
640            && isdigit(UCHAR(path[2]))) { /* INTL: digit */
641        path += 3;
642        while (isdigit(UCHAR(*path))) { /* INTL: digit */
643            ++path;
644        }
645    }
646#endif
647
648    if (path[0] == '/') {
649        Tcl_ListObjAppendElement(NULL, result, Tcl_NewStringObj("/",1));
650        p = path+1;
651    } else {
652        p = path;
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    for (;;) {
661        elementStart = p;
662        while ((*p != '\0') && (*p != '/')) {
663            p++;
664        }
665        length = p - elementStart;
666        if (length > 0) {
667            Tcl_Obj *nextElt;
668            if ((elementStart[0] == '~') && (elementStart != path)) {
669                TclNewLiteralStringObj(nextElt, "./");
670                Tcl_AppendToObj(nextElt, elementStart, length);
671            } else {
672                nextElt = Tcl_NewStringObj(elementStart, length);
673            }
674            Tcl_ListObjAppendElement(NULL, result, nextElt);
675        }
676        if (*p++ == '\0') {
677            break;
678        }
679    }
680    return result;
681}
682
683/*
684 *----------------------------------------------------------------------
685 *
686 * SplitWinPath --
687 *
688 *      This routine is used by Tcl_(FS)SplitPath to handle splitting Windows
689 *      paths.
690 *
691 * Results:
692 *      Returns a newly allocated Tcl list object.
693 *
694 * Side effects:
695 *      None.
696 *
697 *----------------------------------------------------------------------
698 */
699
700static Tcl_Obj *
701SplitWinPath(
702    const char *path)           /* Pointer to string containing a path. */
703{
704    int length;
705    const char *p, *elementStart;
706    Tcl_PathType type = TCL_PATH_ABSOLUTE;
707    Tcl_DString buf;
708    Tcl_Obj *result = Tcl_NewObj();
709    Tcl_DStringInit(&buf);
710
711    p = ExtractWinRoot(path, &buf, 0, &type);
712
713    /*
714     * Terminate the root portion, if we matched something.
715     */
716
717    if (p != path) {
718        Tcl_ListObjAppendElement(NULL, result, Tcl_NewStringObj(
719                Tcl_DStringValue(&buf), Tcl_DStringLength(&buf)));
720    }
721    Tcl_DStringFree(&buf);
722
723    /*
724     * Split on slashes. Embedded elements that start with tilde or a drive
725     * letter will be prefixed with "./" so they are not affected by tilde
726     * substitution.
727     */
728
729    do {
730        elementStart = p;
731        while ((*p != '\0') && (*p != '/') && (*p != '\\')) {
732            p++;
733        }
734        length = p - elementStart;
735        if (length > 0) {
736            Tcl_Obj *nextElt;
737            if ((elementStart != path) && ((elementStart[0] == '~')
738                    || (isalpha(UCHAR(elementStart[0]))
739                        && elementStart[1] == ':'))) {
740                TclNewLiteralStringObj(nextElt, "./");
741                Tcl_AppendToObj(nextElt, elementStart, length);
742            } else {
743                nextElt = Tcl_NewStringObj(elementStart, length);
744            }
745            Tcl_ListObjAppendElement(NULL, result, nextElt);
746        }
747    } while (*p++ != '\0');
748
749    return result;
750}
751
752/*
753 *---------------------------------------------------------------------------
754 *
755 * Tcl_FSJoinToPath --
756 *
757 *      This function takes the given object, which should usually be a valid
758 *      path or NULL, and joins onto it the array of paths segments given.
759 *
760 *      The objects in the array given will temporarily have their refCount
761 *      increased by one, and then decreased by one when this function exits
762 *      (which means if they had zero refCount when we were called, they will
763 *      be freed).
764 *
765 * Results:
766 *      Returns object owned by the caller (which should increment its
767 *      refCount) - typically an object with refCount of zero.
768 *
769 * Side effects:
770 *      None.
771 *
772 *---------------------------------------------------------------------------
773 */
774
775Tcl_Obj *
776Tcl_FSJoinToPath(
777    Tcl_Obj *pathPtr,           /* Valid path or NULL. */
778    int objc,                   /* Number of array elements to join */
779    Tcl_Obj *const objv[])      /* Path elements to join. */
780{
781    int i;
782    Tcl_Obj *lobj, *ret;
783
784    if (pathPtr == NULL) {
785        lobj = Tcl_NewListObj(0, NULL);
786    } else {
787        lobj = Tcl_NewListObj(1, &pathPtr);
788    }
789
790    for (i = 0; i<objc;i++) {
791        Tcl_ListObjAppendElement(NULL, lobj, objv[i]);
792    }
793    ret = Tcl_FSJoinPath(lobj, -1);
794
795    /*
796     * It is possible that 'ret' is just a member of the list and is therefore
797     * going to be freed here. Therefore we must adjust the refCount manually.
798     * (It would be better if we changed the documentation of this function
799     * and Tcl_FSJoinPath so that the returned object already has a refCount
800     * for the caller, hence avoiding these subtleties (and code ugliness)).
801     */
802
803    Tcl_IncrRefCount(ret);
804    Tcl_DecrRefCount(lobj);
805    ret->refCount--;
806    return ret;
807}
808
809/*
810 *---------------------------------------------------------------------------
811 *
812 * TclpNativeJoinPath --
813 *
814 *      'prefix' is absolute, 'joining' is relative to prefix.
815 *
816 * Results:
817 *      modifies prefix
818 *
819 * Side effects:
820 *      None.
821 *
822 *---------------------------------------------------------------------------
823 */
824
825void
826TclpNativeJoinPath(
827    Tcl_Obj *prefix,
828    char *joining)
829{
830    int length, needsSep;
831    char *dest, *p, *start;
832
833    start = Tcl_GetStringFromObj(prefix, &length);
834
835    /*
836     * Remove the ./ from tilde prefixed elements, and drive-letter prefixed
837     * elements on Windows, unless it is the first component.
838     */
839
840    p = joining;
841
842    if (length != 0) {
843        if ((p[0] == '.') && (p[1] == '/') && ((p[2] == '~')
844                || (tclPlatform==TCL_PLATFORM_WINDOWS && isalpha(UCHAR(p[2]))
845                && (p[3] == ':')))) {
846            p += 2;
847        }
848    }
849    if (*p == '\0') {
850        return;
851    }
852
853    switch (tclPlatform) {
854    case TCL_PLATFORM_UNIX:
855        /*
856         * Append a separator if needed.
857         */
858
859        if (length > 0 && (start[length-1] != '/')) {
860            Tcl_AppendToObj(prefix, "/", 1);
861            length++;
862        }
863        needsSep = 0;
864
865        /*
866         * Append the element, eliminating duplicate and trailing slashes.
867         */
868
869        Tcl_SetObjLength(prefix, length + (int) strlen(p));
870
871        dest = Tcl_GetString(prefix) + length;
872        for (; *p != '\0'; p++) {
873            if (*p == '/') {
874                while (p[1] == '/') {
875                    p++;
876                }
877                if (p[1] != '\0' && needsSep) {
878                    *dest++ = '/';
879                }
880            } else {
881                *dest++ = *p;
882                needsSep = 1;
883            }
884        }
885        length = dest - Tcl_GetString(prefix);
886        Tcl_SetObjLength(prefix, length);
887        break;
888
889    case TCL_PLATFORM_WINDOWS:
890        /*
891         * Check to see if we need to append a separator.
892         */
893
894        if ((length > 0) &&
895                (start[length-1] != '/') && (start[length-1] != ':')) {
896            Tcl_AppendToObj(prefix, "/", 1);
897            length++;
898        }
899        needsSep = 0;
900
901        /*
902         * Append the element, eliminating duplicate and trailing slashes.
903         */
904
905        Tcl_SetObjLength(prefix, length + (int) strlen(p));
906        dest = Tcl_GetString(prefix) + length;
907        for (; *p != '\0'; p++) {
908            if ((*p == '/') || (*p == '\\')) {
909                while ((p[1] == '/') || (p[1] == '\\')) {
910                    p++;
911                }
912                if ((p[1] != '\0') && needsSep) {
913                    *dest++ = '/';
914                }
915            } else {
916                *dest++ = *p;
917                needsSep = 1;
918            }
919        }
920        length = dest - Tcl_GetString(prefix);
921        Tcl_SetObjLength(prefix, length);
922        break;
923    }
924    return;
925}
926
927/*
928 *----------------------------------------------------------------------
929 *
930 * Tcl_JoinPath --
931 *
932 *      Combine a list of paths in a platform specific manner. The function
933 *      'Tcl_FSJoinPath' should be used in preference where possible.
934 *
935 * Results:
936 *      Appends the joined path to the end of the specified Tcl_DString
937 *      returning a pointer to the resulting string. Note that the
938 *      Tcl_DString must already be initialized.
939 *
940 * Side effects:
941 *      Modifies the Tcl_DString.
942 *
943 *----------------------------------------------------------------------
944 */
945
946char *
947Tcl_JoinPath(
948    int argc,
949    const char *const *argv,
950    Tcl_DString *resultPtr)     /* Pointer to previously initialized DString */
951{
952    int i, len;
953    Tcl_Obj *listObj = Tcl_NewObj();
954    Tcl_Obj *resultObj;
955    char *resultStr;
956
957    /*
958     * Build the list of paths.
959     */
960
961    for (i = 0; i < argc; i++) {
962        Tcl_ListObjAppendElement(NULL, listObj,
963                Tcl_NewStringObj(argv[i], -1));
964    }
965
966    /*
967     * Ask the objectified code to join the paths.
968     */
969
970    Tcl_IncrRefCount(listObj);
971    resultObj = Tcl_FSJoinPath(listObj, argc);
972    Tcl_IncrRefCount(resultObj);
973    Tcl_DecrRefCount(listObj);
974
975    /*
976     * Store the result.
977     */
978
979    resultStr = Tcl_GetStringFromObj(resultObj, &len);
980    Tcl_DStringAppend(resultPtr, resultStr, len);
981    Tcl_DecrRefCount(resultObj);
982
983    /*
984     * Return a pointer to the result.
985     */
986
987    return Tcl_DStringValue(resultPtr);
988}
989
990/*
991 *---------------------------------------------------------------------------
992 *
993 * Tcl_TranslateFileName --
994 *
995 *      Converts a file name into a form usable by the native system
996 *      interfaces. If the name starts with a tilde, it will produce a name
997 *      where the tilde and following characters have been replaced by the
998 *      home directory location for the named user.
999 *
1000 * Results:
1001 *      The return value is a pointer to a string containing the name after
1002 *      tilde substitution. If there was no tilde substitution, the return
1003 *      value is a pointer to a copy of the original string. If there was an
1004 *      error in processing the name, then an error message is left in the
1005 *      interp's result (if interp was not NULL) and the return value is NULL.
1006 *      Space for the return value is allocated in bufferPtr; the caller must
1007 *      call Tcl_DStringFree() to free the space if the return value was not
1008 *      NULL.
1009 *
1010 * Side effects:
1011 *      None.
1012 *
1013 *----------------------------------------------------------------------
1014 */
1015
1016char *
1017Tcl_TranslateFileName(
1018    Tcl_Interp *interp,         /* Interpreter in which to store error message
1019                                 * (if necessary). */
1020    const char *name,           /* File name, which may begin with "~" (to
1021                                 * indicate current user's home directory) or
1022                                 * "~<user>" (to indicate any user's home
1023                                 * directory). */
1024    Tcl_DString *bufferPtr)     /* Uninitialized or free DString filled with
1025                                 * name after tilde substitution. */
1026{
1027    Tcl_Obj *path = Tcl_NewStringObj(name, -1);
1028    Tcl_Obj *transPtr;
1029
1030    Tcl_IncrRefCount(path);
1031    transPtr = Tcl_FSGetTranslatedPath(interp, path);
1032    if (transPtr == NULL) {
1033        Tcl_DecrRefCount(path);
1034        return NULL;
1035    }
1036
1037    Tcl_DStringInit(bufferPtr);
1038    Tcl_DStringAppend(bufferPtr, Tcl_GetString(transPtr), -1);
1039    Tcl_DecrRefCount(path);
1040    Tcl_DecrRefCount(transPtr);
1041
1042    /*
1043     * Convert forward slashes to backslashes in Windows paths because some
1044     * system interfaces don't accept forward slashes.
1045     */
1046
1047    if (tclPlatform == TCL_PLATFORM_WINDOWS) {
1048        register char *p;
1049        for (p = Tcl_DStringValue(bufferPtr); *p != '\0'; p++) {
1050            if (*p == '/') {
1051                *p = '\\';
1052            }
1053        }
1054    }
1055
1056    return Tcl_DStringValue(bufferPtr);
1057}
1058
1059/*
1060 *----------------------------------------------------------------------
1061 *
1062 * TclGetExtension --
1063 *
1064 *      This function returns a pointer to the beginning of the extension part
1065 *      of a file name.
1066 *
1067 * Results:
1068 *      Returns a pointer into name which indicates where the extension
1069 *      starts. If there is no extension, returns NULL.
1070 *
1071 * Side effects:
1072 *      None.
1073 *
1074 *----------------------------------------------------------------------
1075 */
1076
1077const char *
1078TclGetExtension(
1079    const char *name)           /* File name to parse. */
1080{
1081    const char *p, *lastSep;
1082
1083    /*
1084     * First find the last directory separator.
1085     */
1086
1087    lastSep = NULL;             /* Needed only to prevent gcc warnings. */
1088    switch (tclPlatform) {
1089    case TCL_PLATFORM_UNIX:
1090        lastSep = strrchr(name, '/');
1091        break;
1092
1093    case TCL_PLATFORM_WINDOWS:
1094        lastSep = NULL;
1095        for (p = name; *p != '\0'; p++) {
1096            if (strchr("/\\:", *p) != NULL) {
1097                lastSep = p;
1098            }
1099        }
1100        break;
1101    }
1102    p = strrchr(name, '.');
1103    if ((p != NULL) && (lastSep != NULL) && (lastSep > p)) {
1104        p = NULL;
1105    }
1106
1107    /*
1108     * In earlier versions, we used to back up to the first period in a series
1109     * so that "foo..o" would be split into "foo" and "..o". This is a
1110     * confusing and usually incorrect behavior, so now we split at the last
1111     * period in the name.
1112     */
1113
1114    return p;
1115}
1116
1117/*
1118 *----------------------------------------------------------------------
1119 *
1120 * DoTildeSubst --
1121 *
1122 *      Given a string following a tilde, this routine returns the
1123 *      corresponding home directory.
1124 *
1125 * Results:
1126 *      The result is a pointer to a static string containing the home
1127 *      directory in native format. If there was an error in processing the
1128 *      substitution, then an error message is left in the interp's result and
1129 *      the return value is NULL. On success, the results are appended to
1130 *      resultPtr, and the contents of resultPtr are returned.
1131 *
1132 * Side effects:
1133 *      Information may be left in resultPtr.
1134 *
1135 *----------------------------------------------------------------------
1136 */
1137
1138static const char *
1139DoTildeSubst(
1140    Tcl_Interp *interp,         /* Interpreter in which to store error message
1141                                 * (if necessary). */
1142    const char *user,           /* Name of user whose home directory should be
1143                                 * substituted, or "" for current user. */
1144    Tcl_DString *resultPtr)     /* Initialized DString filled with name after
1145                                 * tilde substitution. */
1146{
1147    const char *dir;
1148
1149    if (*user == '\0') {
1150        Tcl_DString dirString;
1151
1152        dir = TclGetEnv("HOME", &dirString);
1153        if (dir == NULL) {
1154            if (interp) {
1155                Tcl_ResetResult(interp);
1156                Tcl_AppendResult(interp, "couldn't find HOME environment "
1157                        "variable to expand path", NULL);
1158            }
1159            return NULL;
1160        }
1161        Tcl_JoinPath(1, &dir, resultPtr);
1162        Tcl_DStringFree(&dirString);
1163    } else if (TclpGetUserHome(user, resultPtr) == NULL) {
1164        if (interp) {
1165            Tcl_ResetResult(interp);
1166            Tcl_AppendResult(interp, "user \"", user, "\" doesn't exist",
1167                    NULL);
1168        }
1169        return NULL;
1170    }
1171    return Tcl_DStringValue(resultPtr);
1172}
1173
1174/*
1175 *----------------------------------------------------------------------
1176 *
1177 * Tcl_GlobObjCmd --
1178 *
1179 *      This procedure is invoked to process the "glob" Tcl command. See the
1180 *      user documentation for details on what it does.
1181 *
1182 * Results:
1183 *      A standard Tcl result.
1184 *
1185 * Side effects:
1186 *      See the user documentation.
1187 *
1188 *----------------------------------------------------------------------
1189 */
1190
1191        /* ARGSUSED */
1192int
1193Tcl_GlobObjCmd(
1194    ClientData dummy,           /* Not used. */
1195    Tcl_Interp *interp,         /* Current interpreter. */
1196    int objc,                   /* Number of arguments. */
1197    Tcl_Obj *const objv[])      /* Argument objects. */
1198{
1199    int index, i, globFlags, length, join, dir, result;
1200    char *string;
1201    const char *separators;
1202    Tcl_Obj *typePtr, *resultPtr, *look;
1203    Tcl_Obj *pathOrDir = NULL;
1204    Tcl_DString prefix;
1205    static const char *options[] = {
1206        "-directory", "-join", "-nocomplain", "-path", "-tails",
1207        "-types", "--", NULL
1208    };
1209    enum options {
1210        GLOB_DIR, GLOB_JOIN, GLOB_NOCOMPLAIN, GLOB_PATH, GLOB_TAILS,
1211        GLOB_TYPE, GLOB_LAST
1212    };
1213    enum pathDirOptions {PATH_NONE = -1 , PATH_GENERAL = 0, PATH_DIR = 1};
1214    Tcl_GlobTypeData *globTypes = NULL;
1215
1216    globFlags = 0;
1217    join = 0;
1218    dir = PATH_NONE;
1219    typePtr = NULL;
1220    for (i = 1; i < objc; i++) {
1221        if (Tcl_GetIndexFromObj(interp, objv[i], options, "option", 0,
1222                &index) != TCL_OK) {
1223            string = Tcl_GetStringFromObj(objv[i], &length);
1224            if (string[0] == '-') {
1225                /*
1226                 * It looks like the command contains an option so signal an
1227                 * error.
1228                 */
1229
1230                return TCL_ERROR;
1231            } else {
1232                /*
1233                 * This clearly isn't an option; assume it's the first glob
1234                 * pattern. We must clear the error.
1235                 */
1236
1237                Tcl_ResetResult(interp);
1238                break;
1239            }
1240        }
1241
1242        switch (index) {
1243        case GLOB_NOCOMPLAIN:                   /* -nocomplain */
1244            globFlags |= TCL_GLOBMODE_NO_COMPLAIN;
1245            break;
1246        case GLOB_DIR:                          /* -dir */
1247            if (i == (objc-1)) {
1248                Tcl_SetObjResult(interp, Tcl_NewStringObj(
1249                        "missing argument to \"-directory\"", -1));
1250                return TCL_ERROR;
1251            }
1252            if (dir != PATH_NONE) {
1253                Tcl_SetObjResult(interp, Tcl_NewStringObj(
1254                        "\"-directory\" cannot be used with \"-path\"", -1));
1255                return TCL_ERROR;
1256            }
1257            dir = PATH_DIR;
1258            globFlags |= TCL_GLOBMODE_DIR;
1259            pathOrDir = objv[i+1];
1260            i++;
1261            break;
1262        case GLOB_JOIN:                         /* -join */
1263            join = 1;
1264            break;
1265        case GLOB_TAILS:                                /* -tails */
1266            globFlags |= TCL_GLOBMODE_TAILS;
1267            break;
1268        case GLOB_PATH:                         /* -path */
1269            if (i == (objc-1)) {
1270                Tcl_SetObjResult(interp, Tcl_NewStringObj(
1271                        "missing argument to \"-path\"", -1));
1272                return TCL_ERROR;
1273            }
1274            if (dir != PATH_NONE) {
1275                Tcl_SetObjResult(interp, Tcl_NewStringObj(
1276                        "\"-path\" cannot be used with \"-directory\"", -1));
1277                return TCL_ERROR;
1278            }
1279            dir = PATH_GENERAL;
1280            pathOrDir = objv[i+1];
1281            i++;
1282            break;
1283        case GLOB_TYPE:                         /* -types */
1284            if (i == (objc-1)) {
1285                Tcl_SetObjResult(interp, Tcl_NewStringObj(
1286                        "missing argument to \"-types\"", -1));
1287                return TCL_ERROR;
1288            }
1289            typePtr = objv[i+1];
1290            if (Tcl_ListObjLength(interp, typePtr, &length) != TCL_OK) {
1291                return TCL_ERROR;
1292            }
1293            i++;
1294            break;
1295        case GLOB_LAST:                         /* -- */
1296            i++;
1297            goto endOfForLoop;
1298        }
1299    }
1300
1301  endOfForLoop:
1302    if (objc - i < 1) {
1303        Tcl_WrongNumArgs(interp, 1, objv, "?switches? name ?name ...?");
1304        return TCL_ERROR;
1305    }
1306    if ((globFlags & TCL_GLOBMODE_TAILS) && (pathOrDir == NULL)) {
1307        Tcl_AppendResult(interp,
1308                "\"-tails\" must be used with either "
1309                "\"-directory\" or \"-path\"", NULL);
1310        return TCL_ERROR;
1311    }
1312
1313    separators = NULL;          /* lint. */
1314    switch (tclPlatform) {
1315    case TCL_PLATFORM_UNIX:
1316        separators = "/";
1317        break;
1318    case TCL_PLATFORM_WINDOWS:
1319        separators = "/\\:";
1320        break;
1321    }
1322
1323    if (dir == PATH_GENERAL) {
1324        int pathlength;
1325        char *last;
1326        char *first = Tcl_GetStringFromObj(pathOrDir,&pathlength);
1327
1328        /*
1329         * Find the last path separator in the path
1330         */
1331
1332        last = first + pathlength;
1333        for (; last != first; last--) {
1334            if (strchr(separators, *(last-1)) != NULL) {
1335                break;
1336            }
1337        }
1338
1339        if (last == first + pathlength) {
1340            /*
1341             * It's really a directory.
1342             */
1343
1344            dir = PATH_DIR;
1345
1346        } else {
1347            Tcl_DString pref;
1348            char *search, *find;
1349            Tcl_DStringInit(&pref);
1350            if (last == first) {
1351                /*
1352                 * The whole thing is a prefix. This means we must remove any
1353                 * 'tails' flag too, since it is irrelevant now (the same
1354                 * effect will happen without it), but in particular its use
1355                 * in TclGlob requires a non-NULL pathOrDir.
1356                 */
1357
1358                Tcl_DStringAppend(&pref, first, -1);
1359                globFlags &= ~TCL_GLOBMODE_TAILS;
1360                pathOrDir = NULL;
1361            } else {
1362                /*
1363                 * Have to split off the end.
1364                 */
1365
1366                Tcl_DStringAppend(&pref, last, first+pathlength-last);
1367                pathOrDir = Tcl_NewStringObj(first, last-first-1);
1368
1369                /*
1370                 * We must ensure that we haven't cut off too much, and turned
1371                 * a valid path like '/' or 'C:/' into an incorrect path like
1372                 * '' or 'C:'. The way we do this is to add a separator if
1373                 * there are none presently in the prefix.
1374                 */
1375
1376                if (strpbrk(Tcl_GetString(pathOrDir), "\\/") == NULL) {
1377                    Tcl_AppendToObj(pathOrDir, last-1, 1);
1378                }
1379            }
1380
1381            /*
1382             * Need to quote 'prefix'.
1383             */
1384
1385            Tcl_DStringInit(&prefix);
1386            search = Tcl_DStringValue(&pref);
1387            while ((find = (strpbrk(search, "\\[]*?{}"))) != NULL) {
1388                Tcl_DStringAppend(&prefix, search, find-search);
1389                Tcl_DStringAppend(&prefix, "\\", 1);
1390                Tcl_DStringAppend(&prefix, find, 1);
1391                search = find+1;
1392                if (*search == '\0') {
1393                    break;
1394                }
1395            }
1396            if (*search != '\0') {
1397                Tcl_DStringAppend(&prefix, search, -1);
1398            }
1399            Tcl_DStringFree(&pref);
1400        }
1401    }
1402
1403    if (pathOrDir != NULL) {
1404        Tcl_IncrRefCount(pathOrDir);
1405    }
1406
1407    if (typePtr != NULL) {
1408        /*
1409         * The rest of the possible type arguments (except 'd') are platform
1410         * specific. We don't complain when they are used on an incompatible
1411         * platform.
1412         */
1413
1414        Tcl_ListObjLength(interp, typePtr, &length);
1415        globTypes = (Tcl_GlobTypeData*)
1416                TclStackAlloc(interp,sizeof(Tcl_GlobTypeData));
1417        globTypes->type = 0;
1418        globTypes->perm = 0;
1419        globTypes->macType = NULL;
1420        globTypes->macCreator = NULL;
1421
1422        while (--length >= 0) {
1423            int len;
1424            char *str;
1425
1426            Tcl_ListObjIndex(interp, typePtr, length, &look);
1427            str = Tcl_GetStringFromObj(look, &len);
1428            if (strcmp("readonly", str) == 0) {
1429                globTypes->perm |= TCL_GLOB_PERM_RONLY;
1430            } else if (strcmp("hidden", str) == 0) {
1431                globTypes->perm |= TCL_GLOB_PERM_HIDDEN;
1432            } else if (len == 1) {
1433                switch (str[0]) {
1434                case 'r':
1435                    globTypes->perm |= TCL_GLOB_PERM_R;
1436                    break;
1437                case 'w':
1438                    globTypes->perm |= TCL_GLOB_PERM_W;
1439                    break;
1440                case 'x':
1441                    globTypes->perm |= TCL_GLOB_PERM_X;
1442                    break;
1443                case 'b':
1444                    globTypes->type |= TCL_GLOB_TYPE_BLOCK;
1445                    break;
1446                case 'c':
1447                    globTypes->type |= TCL_GLOB_TYPE_CHAR;
1448                    break;
1449                case 'd':
1450                    globTypes->type |= TCL_GLOB_TYPE_DIR;
1451                    break;
1452                case 'p':
1453                    globTypes->type |= TCL_GLOB_TYPE_PIPE;
1454                    break;
1455                case 'f':
1456                    globTypes->type |= TCL_GLOB_TYPE_FILE;
1457                    break;
1458                case 'l':
1459                    globTypes->type |= TCL_GLOB_TYPE_LINK;
1460                    break;
1461                case 's':
1462                    globTypes->type |= TCL_GLOB_TYPE_SOCK;
1463                    break;
1464                default:
1465                    goto badTypesArg;
1466                }
1467
1468            } else if (len == 4) {
1469                /*
1470                 * This is assumed to be a MacOS file type.
1471                 */
1472
1473                if (globTypes->macType != NULL) {
1474                    goto badMacTypesArg;
1475                }
1476                globTypes->macType = look;
1477                Tcl_IncrRefCount(look);
1478
1479            } else {
1480                Tcl_Obj* item;
1481
1482                if ((Tcl_ListObjLength(NULL, look, &len) == TCL_OK) &&
1483                        (len == 3)) {
1484                    Tcl_ListObjIndex(interp, look, 0, &item);
1485                    if (!strcmp("macintosh", Tcl_GetString(item))) {
1486                        Tcl_ListObjIndex(interp, look, 1, &item);
1487                        if (!strcmp("type", Tcl_GetString(item))) {
1488                            Tcl_ListObjIndex(interp, look, 2, &item);
1489                            if (globTypes->macType != NULL) {
1490                                goto badMacTypesArg;
1491                            }
1492                            globTypes->macType = item;
1493                            Tcl_IncrRefCount(item);
1494                            continue;
1495                        } else if (!strcmp("creator", Tcl_GetString(item))) {
1496                            Tcl_ListObjIndex(interp, look, 2, &item);
1497                            if (globTypes->macCreator != NULL) {
1498                                goto badMacTypesArg;
1499                            }
1500                            globTypes->macCreator = item;
1501                            Tcl_IncrRefCount(item);
1502                            continue;
1503                        }
1504                    }
1505                }
1506
1507                /*
1508                 * Error cases. We reset the 'join' flag to zero, since we
1509                 * haven't yet made use of it.
1510                 */
1511
1512            badTypesArg:
1513                TclNewObj(resultPtr);
1514                Tcl_AppendToObj(resultPtr, "bad argument to \"-types\": ", -1);
1515                Tcl_AppendObjToObj(resultPtr, look);
1516                Tcl_SetObjResult(interp, resultPtr);
1517                result = TCL_ERROR;
1518                join = 0;
1519                goto endOfGlob;
1520
1521            badMacTypesArg:
1522                Tcl_SetObjResult(interp, Tcl_NewStringObj(
1523                        "only one MacOS type or creator argument"
1524                        " to \"-types\" allowed", -1));
1525                result = TCL_ERROR;
1526                join = 0;
1527                goto endOfGlob;
1528            }
1529        }
1530    }
1531
1532    /*
1533     * Now we perform the actual glob below. This may involve joining together
1534     * the pattern arguments, dealing with particular file types etc. We use a
1535     * 'goto' to ensure we free any memory allocated along the way.
1536     */
1537
1538    objc -= i;
1539    objv += i;
1540    result = TCL_OK;
1541
1542    if (join) {
1543        if (dir != PATH_GENERAL) {
1544            Tcl_DStringInit(&prefix);
1545        }
1546        for (i = 0; i < objc; i++) {
1547            string = Tcl_GetStringFromObj(objv[i], &length);
1548            Tcl_DStringAppend(&prefix, string, length);
1549            if (i != objc -1) {
1550                Tcl_DStringAppend(&prefix, separators, 1);
1551            }
1552        }
1553        if (TclGlob(interp, Tcl_DStringValue(&prefix), pathOrDir, globFlags,
1554                globTypes) != TCL_OK) {
1555            result = TCL_ERROR;
1556            goto endOfGlob;
1557        }
1558    } else if (dir == PATH_GENERAL) {
1559        Tcl_DString str;
1560
1561        for (i = 0; i < objc; i++) {
1562            Tcl_DStringInit(&str);
1563            if (dir == PATH_GENERAL) {
1564                Tcl_DStringAppend(&str, Tcl_DStringValue(&prefix),
1565                        Tcl_DStringLength(&prefix));
1566            }
1567            string = Tcl_GetStringFromObj(objv[i], &length);
1568            Tcl_DStringAppend(&str, string, length);
1569            if (TclGlob(interp, Tcl_DStringValue(&str), pathOrDir, globFlags,
1570                    globTypes) != TCL_OK) {
1571                result = TCL_ERROR;
1572                Tcl_DStringFree(&str);
1573                goto endOfGlob;
1574            }
1575        }
1576        Tcl_DStringFree(&str);
1577    } else {
1578        for (i = 0; i < objc; i++) {
1579            string = Tcl_GetString(objv[i]);
1580            if (TclGlob(interp, string, pathOrDir, globFlags,
1581                    globTypes) != TCL_OK) {
1582                result = TCL_ERROR;
1583                goto endOfGlob;
1584            }
1585        }
1586    }
1587
1588    if ((globFlags & TCL_GLOBMODE_NO_COMPLAIN) == 0) {
1589        if (Tcl_ListObjLength(interp, Tcl_GetObjResult(interp),
1590                &length) != TCL_OK) {
1591            /*
1592             * This should never happen. Maybe we should be more dramatic.
1593             */
1594
1595            result = TCL_ERROR;
1596            goto endOfGlob;
1597        }
1598
1599        if (length == 0) {
1600            Tcl_AppendResult(interp, "no files matched glob pattern",
1601                    (join || (objc == 1)) ? " \"" : "s \"", NULL);
1602            if (join) {
1603                Tcl_AppendResult(interp, Tcl_DStringValue(&prefix), NULL);
1604            } else {
1605                const char *sep = "";
1606                for (i = 0; i < objc; i++) {
1607                    string = Tcl_GetString(objv[i]);
1608                    Tcl_AppendResult(interp, sep, string, NULL);
1609                    sep = " ";
1610                }
1611            }
1612            Tcl_AppendResult(interp, "\"", NULL);
1613            result = TCL_ERROR;
1614        }
1615    }
1616
1617  endOfGlob:
1618    if (join || (dir == PATH_GENERAL)) {
1619        Tcl_DStringFree(&prefix);
1620    }
1621    if (pathOrDir != NULL) {
1622        Tcl_DecrRefCount(pathOrDir);
1623    }
1624    if (globTypes != NULL) {
1625        if (globTypes->macType != NULL) {
1626            Tcl_DecrRefCount(globTypes->macType);
1627        }
1628        if (globTypes->macCreator != NULL) {
1629            Tcl_DecrRefCount(globTypes->macCreator);
1630        }
1631        TclStackFree(interp, globTypes);
1632    }
1633    return result;
1634}
1635
1636/*
1637 *----------------------------------------------------------------------
1638 *
1639 * TclGlob --
1640 *
1641 *      This procedure prepares arguments for the DoGlob call. It sets the
1642 *      separator string based on the platform, performs * tilde substitution,
1643 *      and calls DoGlob.
1644 *
1645 *      The interpreter's result, on entry to this function, must be a valid
1646 *      Tcl list (e.g. it could be empty), since we will lappend any new
1647 *      results to that list. If it is not a valid list, this function will
1648 *      fail to do anything very meaningful.
1649 *
1650 *      Note that if globFlags contains 'TCL_GLOBMODE_TAILS' then pathPrefix
1651 *      cannot be NULL (it is only allowed with -dir or -path).
1652 *
1653 * Results:
1654 *      The return value is a standard Tcl result indicating whether an error
1655 *      occurred in globbing. After a normal return the result in interp (set
1656 *      by DoGlob) holds all of the file names given by the pattern and
1657 *      pathPrefix arguments. After an error the result in interp will hold
1658 *      an error message.
1659 *
1660 * Side effects:
1661 *      The 'pattern' is written to.
1662 *
1663 *----------------------------------------------------------------------
1664 */
1665
1666        /* ARGSUSED */
1667int
1668TclGlob(
1669    Tcl_Interp *interp,         /* Interpreter for returning error message or
1670                                 * appending list of matching file names. */
1671    char *pattern,              /* Glob pattern to match. Must not refer to a
1672                                 * static string. */
1673    Tcl_Obj *pathPrefix,        /* Path prefix to glob pattern, if non-null,
1674                                 * which is considered literally. */
1675    int globFlags,              /* Stores or'ed combination of flags */
1676    Tcl_GlobTypeData *types)    /* Struct containing acceptable types. May be
1677                                 * NULL. */
1678{
1679    const char *separators;
1680    const char *head;
1681    char *tail, *start;
1682    int result;
1683    Tcl_Obj *filenamesObj, *savedResultObj;
1684
1685    separators = NULL;          /* lint. */
1686    switch (tclPlatform) {
1687    case TCL_PLATFORM_UNIX:
1688        separators = "/";
1689        break;
1690    case TCL_PLATFORM_WINDOWS:
1691        separators = "/\\:";
1692        break;
1693    }
1694
1695    if (pathPrefix == NULL) {
1696        char c;
1697        Tcl_DString buffer;
1698        Tcl_DStringInit(&buffer);
1699
1700        start = pattern;
1701
1702        /*
1703         * Perform tilde substitution, if needed.
1704         */
1705
1706        if (start[0] == '~') {
1707            /*
1708             * Find the first path separator after the tilde.
1709             */
1710
1711            for (tail = start; *tail != '\0'; tail++) {
1712                if (*tail == '\\') {
1713                    if (strchr(separators, tail[1]) != NULL) {
1714                        break;
1715                    }
1716                } else if (strchr(separators, *tail) != NULL) {
1717                    break;
1718                }
1719            }
1720
1721            /*
1722             * Determine the home directory for the specified user.
1723             */
1724
1725            c = *tail;
1726            *tail = '\0';
1727            head = DoTildeSubst(interp, start+1, &buffer);
1728            *tail = c;
1729            if (head == NULL) {
1730                return TCL_ERROR;
1731            }
1732            if (head != Tcl_DStringValue(&buffer)) {
1733                Tcl_DStringAppend(&buffer, head, -1);
1734            }
1735            pathPrefix = Tcl_NewStringObj(Tcl_DStringValue(&buffer),
1736                    Tcl_DStringLength(&buffer));
1737            Tcl_IncrRefCount(pathPrefix);
1738            globFlags |= TCL_GLOBMODE_DIR;
1739            if (c != '\0') {
1740                tail++;
1741            }
1742            Tcl_DStringFree(&buffer);
1743        } else {
1744            tail = pattern;
1745        }
1746    } else {
1747        Tcl_IncrRefCount(pathPrefix);
1748        tail = pattern;
1749    }
1750
1751    /*
1752     * Handling empty path prefixes with glob patterns like 'C:' or
1753     * 'c:////////' is a pain on Windows if we leave it too late, since these
1754     * aren't really patterns at all! We therefore check the head of the
1755     * pattern now for such cases, if we don't have an unquoted prefix yet.
1756     *
1757     * Similarly on Unix with '/' at the head of the pattern -- it just
1758     * indicates the root volume, so we treat it as such.
1759     */
1760
1761    if (tclPlatform == TCL_PLATFORM_WINDOWS) {
1762        if (pathPrefix == NULL && tail[0] != '\0' && tail[1] == ':') {
1763            char *p = tail + 1;
1764            pathPrefix = Tcl_NewStringObj(tail, 1);
1765            while (*p != '\0') {
1766                char c = p[1];
1767                if (*p == '\\') {
1768                    if (strchr(separators, c) != NULL) {
1769                        if (c == '\\') {
1770                            c = '/';
1771                        }
1772                        Tcl_AppendToObj(pathPrefix, &c, 1);
1773                        p++;
1774                    } else {
1775                        break;
1776                    }
1777                } else if (strchr(separators, *p) != NULL) {
1778                    Tcl_AppendToObj(pathPrefix, p, 1);
1779                } else {
1780                    break;
1781                }
1782                p++;
1783            }
1784            tail = p;
1785            Tcl_IncrRefCount(pathPrefix);
1786        } else if (pathPrefix == NULL && (tail[0] == '/'
1787                || (tail[0] == '\\' && tail[1] == '\\'))) {
1788            int driveNameLen;
1789            Tcl_Obj *driveName;
1790            Tcl_Obj *temp = Tcl_NewStringObj(tail, -1);
1791            Tcl_IncrRefCount(temp);
1792
1793            switch (TclGetPathType(temp, NULL, &driveNameLen, &driveName)) {
1794            case TCL_PATH_VOLUME_RELATIVE: {
1795                /*
1796                 * Volume relative path which is equivalent to a path in the
1797                 * root of the cwd's volume. We will actually return
1798                 * non-volume-relative paths here. i.e. 'glob /foo*' will
1799                 * return 'C:/foobar'. This is much the same as globbing for a
1800                 * path with '\\' will return one with '/' on Windows.
1801                 */
1802
1803                Tcl_Obj *cwd = Tcl_FSGetCwd(interp);
1804
1805                if (cwd == NULL) {
1806                    Tcl_DecrRefCount(temp);
1807                    return TCL_ERROR;
1808                }
1809                pathPrefix = Tcl_NewStringObj(Tcl_GetString(cwd), 3);
1810                Tcl_DecrRefCount(cwd);
1811                if (tail[0] == '/') {
1812                    tail++;
1813                } else {
1814                    tail+=2;
1815                }
1816                Tcl_IncrRefCount(pathPrefix);
1817                break;
1818            }
1819            case TCL_PATH_ABSOLUTE:
1820                /*
1821                 * Absolute, possibly network path //Machine/Share. Use that
1822                 * as the path prefix (it already has a refCount).
1823                 */
1824
1825                pathPrefix = driveName;
1826                tail += driveNameLen;
1827                break;
1828            case TCL_PATH_RELATIVE:
1829                /* Do nothing */
1830                break;
1831            }
1832            Tcl_DecrRefCount(temp);
1833        }
1834
1835        /*
1836         * ':' no longer needed as a separator. It is only relevant to the
1837         * beginning of the path.
1838         */
1839
1840        separators = "/\\";
1841
1842    } else if (tclPlatform == TCL_PLATFORM_UNIX) {
1843        if (pathPrefix == NULL && tail[0] == '/') {
1844            pathPrefix = Tcl_NewStringObj(tail, 1);
1845            tail++;
1846            Tcl_IncrRefCount(pathPrefix);
1847        }
1848    }
1849
1850    /*
1851     * Finally if we still haven't managed to generate a path prefix, check if
1852     * the path starts with a current volume.
1853     */
1854
1855    if (pathPrefix == NULL) {
1856        int driveNameLen;
1857        Tcl_Obj *driveName;
1858        if (TclFSNonnativePathType(tail, (int) strlen(tail), NULL,
1859                &driveNameLen, &driveName) == TCL_PATH_ABSOLUTE) {
1860            pathPrefix = driveName;
1861            tail += driveNameLen;
1862        }
1863    }
1864
1865    /*
1866     * To process a [glob] invokation, this function may be called multiple
1867     * times. Each time, the previously discovered filenames are in the
1868     * interpreter result. We stash that away here so the result is free for
1869     * error messsages.
1870     */
1871
1872    savedResultObj = Tcl_GetObjResult(interp);
1873    Tcl_IncrRefCount(savedResultObj);
1874    Tcl_ResetResult(interp);
1875    TclNewObj(filenamesObj);
1876    Tcl_IncrRefCount(filenamesObj);
1877
1878    /*
1879     * Now we do the actual globbing, adding filenames as we go to buffer in
1880     * filenamesObj
1881     */
1882
1883    if (*tail == '\0' && pathPrefix != NULL) {
1884        /*
1885         * An empty pattern.  This means 'pathPrefix' is actually
1886         * a full path of a file/directory we want to simply check
1887         * for existence and type.
1888         */
1889        if (types == NULL) {
1890            /*
1891             * We just want to check for existence.  In this case we
1892             * make it easy on Tcl_FSMatchInDirectory and its
1893             * sub-implementations by not bothering them (even though
1894             * they should support this situation) and we just use the
1895             * simple existence check with Tcl_FSAccess.
1896             */
1897            if (Tcl_FSAccess(pathPrefix, F_OK) == 0) {
1898                Tcl_ListObjAppendElement(interp, filenamesObj, pathPrefix);
1899            }
1900            result = TCL_OK;
1901        } else {
1902            /*
1903             * We want to check for the correct type.  Tcl_FSMatchInDirectory
1904             * is documented to do this for us, if we give it a NULL pattern.
1905             */
1906            result = Tcl_FSMatchInDirectory(interp, filenamesObj, pathPrefix,
1907                    NULL, types);
1908        }
1909    } else {
1910        result = DoGlob(interp, filenamesObj, separators, pathPrefix,
1911                globFlags & TCL_GLOBMODE_DIR, tail, types);
1912    }
1913
1914    /*
1915     * Check for errors...
1916     */
1917
1918    if (result != TCL_OK) {
1919        TclDecrRefCount(filenamesObj);
1920        TclDecrRefCount(savedResultObj);
1921        if (pathPrefix != NULL) {
1922            Tcl_DecrRefCount(pathPrefix);
1923        }
1924        return result;
1925    }
1926
1927    /*
1928     * If we only want the tails, we must strip off the prefix now. It may
1929     * seem more efficient to pass the tails flag down into DoGlob,
1930     * Tcl_FSMatchInDirectory, but those functions are continually adjusting
1931     * the prefix as the various pieces of the pattern are assimilated, so
1932     * that would add a lot of complexity to the code. This way is a little
1933     * slower (when the -tails flag is given), but much simpler to code.
1934     *
1935     * We do it by rewriting the result list in-place.
1936     */
1937
1938    if (globFlags & TCL_GLOBMODE_TAILS) {
1939        int objc, i;
1940        Tcl_Obj **objv;
1941        int prefixLen;
1942        const char *pre;
1943
1944        /*
1945         * If this length has never been set, set it here.
1946         */
1947
1948        if (pathPrefix == NULL) {
1949            Tcl_Panic("Called TclGlob with TCL_GLOBMODE_TAILS and pathPrefix==NULL");
1950        }
1951       
1952        pre = Tcl_GetStringFromObj(pathPrefix, &prefixLen);
1953        if (prefixLen > 0
1954                && (strchr(separators, pre[prefixLen-1]) == NULL)) {
1955            /*
1956             * If we're on Windows and the prefix is a volume relative one
1957             * like 'C:', then there won't be a path separator in between, so
1958             * no need to skip it here.
1959             */
1960
1961            if ((tclPlatform != TCL_PLATFORM_WINDOWS) || (prefixLen != 2)
1962                    || (pre[1] != ':')) {
1963                prefixLen++;
1964            }
1965        }
1966
1967        Tcl_ListObjGetElements(NULL, filenamesObj, &objc, &objv);
1968        for (i = 0; i< objc; i++) {
1969            int len;
1970            char *oldStr = Tcl_GetStringFromObj(objv[i], &len);
1971            Tcl_Obj* elems[1];
1972
1973            if (len == prefixLen) {
1974                if ((pattern[0] == '\0')
1975                        || (strchr(separators, pattern[0]) == NULL)) {
1976                    TclNewLiteralStringObj(elems[0], ".");
1977                } else {
1978                    TclNewLiteralStringObj(elems[0], "/");
1979                }
1980            } else {
1981                elems[0] = Tcl_NewStringObj(oldStr+prefixLen, len-prefixLen);
1982            }
1983            Tcl_ListObjReplace(interp, filenamesObj, i, 1, 1, elems);
1984        }
1985    }
1986
1987    /*
1988     * Now we have a list of discovered filenames in filenamesObj and a list
1989     * of previously discovered (saved earlier from the interpreter result) in
1990     * savedResultObj. Merge them and put them back in the interpreter result.
1991     */
1992
1993    if (Tcl_IsShared(savedResultObj)) {
1994        TclDecrRefCount(savedResultObj);
1995        savedResultObj = Tcl_DuplicateObj(savedResultObj);
1996        Tcl_IncrRefCount(savedResultObj);
1997    }
1998    if (Tcl_ListObjAppendList(interp, savedResultObj, filenamesObj) != TCL_OK){
1999        result = TCL_ERROR;
2000    } else {
2001        Tcl_SetObjResult(interp, savedResultObj);
2002    }
2003    TclDecrRefCount(savedResultObj);
2004    TclDecrRefCount(filenamesObj);
2005    if (pathPrefix != NULL) {
2006        Tcl_DecrRefCount(pathPrefix);
2007    }
2008
2009    return result;
2010}
2011
2012/*
2013 *----------------------------------------------------------------------
2014 *
2015 * SkipToChar --
2016 *
2017 *      This function traverses a glob pattern looking for the next unquoted
2018 *      occurance of the specified character at the same braces nesting level.
2019 *
2020 * Results:
2021 *      Updates stringPtr to point to the matching character, or to the end of
2022 *      the string if nothing matched. The return value is 1 if a match was
2023 *      found at the top level, otherwise it is 0.
2024 *
2025 * Side effects:
2026 *      None.
2027 *
2028 *----------------------------------------------------------------------
2029 */
2030
2031static int
2032SkipToChar(
2033    char **stringPtr,           /* Pointer string to check. */
2034    int match)                  /* Character to find. */
2035{
2036    int quoted, level;
2037    register char *p;
2038
2039    quoted = 0;
2040    level = 0;
2041
2042    for (p = *stringPtr; *p != '\0'; p++) {
2043        if (quoted) {
2044            quoted = 0;
2045            continue;
2046        }
2047        if ((level == 0) && (*p == match)) {
2048            *stringPtr = p;
2049            return 1;
2050        }
2051        if (*p == '{') {
2052            level++;
2053        } else if (*p == '}') {
2054            level--;
2055        } else if (*p == '\\') {
2056            quoted = 1;
2057        }
2058    }
2059    *stringPtr = p;
2060    return 0;
2061}
2062
2063/*
2064 *----------------------------------------------------------------------
2065 *
2066 * DoGlob --
2067 *
2068 *      This recursive procedure forms the heart of the globbing code. It
2069 *      performs a depth-first traversal of the tree given by the path name to
2070 *      be globbed and the pattern. The directory and remainder are assumed to
2071 *      be native format paths. The prefix contained in 'pathPtr' is either a
2072 *      directory or path from which to start the search (or NULL). If pathPtr
2073 *      is NULL, then the pattern must not start with an absolute path
2074 *      specification (that case should be handled by moving the absolute path
2075 *      prefix into pathPtr before calling DoGlob).
2076 *
2077 * Results:
2078 *      The return value is a standard Tcl result indicating whether an error
2079 *      occurred in globbing. After a normal return the result in interp will
2080 *      be set to hold all of the file names given by the dir and remaining
2081 *      arguments. After an error the result in interp will hold an error
2082 *      message.
2083 *
2084 * Side effects:
2085 *      None.
2086 *
2087 *----------------------------------------------------------------------
2088 */
2089
2090static int
2091DoGlob(
2092    Tcl_Interp *interp,         /* Interpreter to use for error reporting
2093                                 * (e.g. unmatched brace). */
2094    Tcl_Obj *matchesObj,        /* Unshared list object in which to place all
2095                                 * resulting filenames. Caller allocates and
2096                                 * deallocates; DoGlob must not touch the
2097                                 * refCount of this object. */
2098    const char *separators, /* String containing separator characters that
2099                                 * should be used to identify globbing
2100                                 * boundaries. */
2101    Tcl_Obj *pathPtr,           /* Completely expanded prefix. */
2102    int flags,                  /* If non-zero then pathPtr is a directory */
2103    char *pattern,              /* The pattern to match against. Must not be a
2104                                 * pointer to a static string. */
2105    Tcl_GlobTypeData *types)    /* List object containing list of acceptable
2106                                 * types. May be NULL. */
2107{
2108    int baseLength, quoted, count;
2109    int result = TCL_OK;
2110    char *name, *p, *openBrace, *closeBrace, *firstSpecialChar;
2111    Tcl_Obj *joinedPtr;
2112
2113    /*
2114     * Consume any leading directory separators, leaving pattern pointing just
2115     * past the last initial separator.
2116     */
2117
2118    count = 0;
2119    name = pattern;
2120    for (; *pattern != '\0'; pattern++) {
2121        if (*pattern == '\\') {
2122            /*
2123             * If the first character is escaped, either we have a directory
2124             * separator, or we have any other character. In the latter case
2125             * the rest is a pattern, and we must break from the loop. This
2126             * is particularly important on Windows where '\' is both the
2127             * escaping character and a directory separator.
2128             */
2129
2130            if (strchr(separators, pattern[1]) != NULL) {
2131                pattern++;
2132            } else {
2133                break;
2134            }
2135        } else if (strchr(separators, *pattern) == NULL) {
2136            break;
2137        }
2138        count++;
2139    }
2140
2141    /*
2142     * This block of code is not exercised by the Tcl test suite as of Tcl
2143     * 8.5a0. Simplifications to the calling paths suggest it may not be
2144     * necessary any more, since path separators are handled elsewhere. It is
2145     * left in place in case new bugs are reported.
2146     */
2147
2148#if 0 /* PROBABLY_OBSOLETE */
2149    /*
2150     * Deal with path separators.
2151     */
2152
2153    if (pathPtr == NULL) {
2154        /*
2155         * Length used to be the length of the prefix, and lastChar the
2156         * lastChar of the prefix. But, none of this is used any more.
2157         */
2158
2159        int length = 0;
2160        char lastChar = 0;
2161
2162        switch (tclPlatform) {
2163        case TCL_PLATFORM_WINDOWS:
2164            /*
2165             * If this is a drive relative path, add the colon and the
2166             * trailing slash if needed. Otherwise add the slash if this is
2167             * the first absolute element, or a later relative element. Add an
2168             * extra slash if this is a UNC path.
2169             */
2170
2171            if (*name == ':') {
2172                Tcl_DStringAppend(&append, ":", 1);
2173                if (count > 1) {
2174                    Tcl_DStringAppend(&append, "/", 1);
2175                }
2176            } else if ((*pattern != '\0') && (((length > 0)
2177                    && (strchr(separators, lastChar) == NULL))
2178                    || ((length == 0) && (count > 0)))) {
2179                Tcl_DStringAppend(&append, "/", 1);
2180                if ((length == 0) && (count > 1)) {
2181                    Tcl_DStringAppend(&append, "/", 1);
2182                }
2183            }
2184
2185            break;
2186        case TCL_PLATFORM_UNIX:
2187            /*
2188             * Add a separator if this is the first absolute element, or a
2189             * later relative element.
2190             */
2191
2192            if ((*pattern != '\0') && (((length > 0)
2193                    && (strchr(separators, lastChar) == NULL))
2194                    || ((length == 0) && (count > 0)))) {
2195                Tcl_DStringAppend(&append, "/", 1);
2196            }
2197            break;
2198        }
2199    }
2200#endif /* PROBABLY_OBSOLETE */
2201
2202    /*
2203     * Look for the first matching pair of braces or the first directory
2204     * separator that is not inside a pair of braces.
2205     */
2206
2207    openBrace = closeBrace = NULL;
2208    quoted = 0;
2209    for (p = pattern; *p != '\0'; p++) {
2210        if (quoted) {
2211            quoted = 0;
2212
2213        } else if (*p == '\\') {
2214            quoted = 1;
2215            if (strchr(separators, p[1]) != NULL) {
2216                /*
2217                 * Quoted directory separator.
2218                 */
2219                break;
2220            }
2221
2222        } else if (strchr(separators, *p) != NULL) {
2223            /*
2224             * Unquoted directory separator.
2225             */
2226            break;
2227
2228        } else if (*p == '{') {
2229            openBrace = p;
2230            p++;
2231            if (SkipToChar(&p, '}')) {
2232                /*
2233                 * Balanced braces.
2234                 */
2235
2236                closeBrace = p;
2237                break;
2238            }
2239            Tcl_SetResult(interp, "unmatched open-brace in file name",
2240                    TCL_STATIC);
2241            return TCL_ERROR;
2242
2243        } else if (*p == '}') {
2244            Tcl_SetResult(interp, "unmatched close-brace in file name",
2245                    TCL_STATIC);
2246            return TCL_ERROR;
2247        }
2248    }
2249
2250    /*
2251     * Substitute the alternate patterns from the braces and recurse.
2252     */
2253
2254    if (openBrace != NULL) {
2255        char *element;
2256
2257        Tcl_DString newName;
2258        Tcl_DStringInit(&newName);
2259
2260        /*
2261         * For each element within in the outermost pair of braces, append the
2262         * element and the remainder to the fixed portion before the first
2263         * brace and recursively call DoGlob.
2264         */
2265
2266        Tcl_DStringAppend(&newName, pattern, openBrace-pattern);
2267        baseLength = Tcl_DStringLength(&newName);
2268        *closeBrace = '\0';
2269        for (p = openBrace; p != closeBrace; ) {
2270            p++;
2271            element = p;
2272            SkipToChar(&p, ',');
2273            Tcl_DStringSetLength(&newName, baseLength);
2274            Tcl_DStringAppend(&newName, element, p-element);
2275            Tcl_DStringAppend(&newName, closeBrace+1, -1);
2276            result = DoGlob(interp, matchesObj, separators, pathPtr, flags,
2277                    Tcl_DStringValue(&newName), types);
2278            if (result != TCL_OK) {
2279                break;
2280            }
2281        }
2282        *closeBrace = '}';
2283        Tcl_DStringFree(&newName);
2284        return result;
2285    }
2286
2287    /*
2288     * At this point, there are no more brace substitutions to perform on this
2289     * path component. The variable p is pointing at a quoted or unquoted
2290     * directory separator or the end of the string. So we need to check for
2291     * special globbing characters in the current pattern. We avoid modifying
2292     * pattern if p is pointing at the end of the string.
2293     *
2294     * If we find any globbing characters, then we must call
2295     * Tcl_FSMatchInDirectory. If we're at the end of the string, then that's
2296     * all we need to do. If we're not at the end of the string, then we must
2297     * recurse, so we do that below.
2298     *
2299     * Alternatively, if there are no globbing characters then again there are
2300     * two cases. If we're at the end of the string, we just need to check for
2301     * the given path's existence and type. If we're not at the end of the
2302     * string, we recurse.
2303     */
2304
2305    if (*p != '\0') {
2306        /*
2307         * Note that we are modifying the string in place. This won't work if
2308         * the string is a static.
2309         */
2310
2311        char savedChar = *p;
2312        *p = '\0';
2313        firstSpecialChar = strpbrk(pattern, "*[]?\\");
2314        *p = savedChar;
2315    } else {
2316        firstSpecialChar = strpbrk(pattern, "*[]?\\");
2317    }
2318
2319    if (firstSpecialChar != NULL) {
2320        /*
2321         * Look for matching files in the given directory. The implementation
2322         * of this function is filesystem specific. For each file that
2323         * matches, it will add the match onto the resultPtr given.
2324         */
2325
2326        static Tcl_GlobTypeData dirOnly = {
2327            TCL_GLOB_TYPE_DIR, 0, NULL, NULL
2328        };
2329        char save = *p;
2330        Tcl_Obj* subdirsPtr;
2331
2332        if (*p == '\0') {
2333            return Tcl_FSMatchInDirectory(interp, matchesObj, pathPtr,
2334                    pattern, types);
2335        }
2336
2337        /*
2338         * We do the recursion ourselves. This makes implementing
2339         * Tcl_FSMatchInDirectory for each filesystem much easier.
2340         */
2341
2342        *p = '\0';
2343        TclNewObj(subdirsPtr);
2344        Tcl_IncrRefCount(subdirsPtr);
2345        result = Tcl_FSMatchInDirectory(interp, subdirsPtr, pathPtr,
2346                pattern, &dirOnly);
2347        *p = save;
2348        if (result == TCL_OK) {
2349            int subdirc, i;
2350            Tcl_Obj **subdirv;
2351
2352            result = Tcl_ListObjGetElements(interp, subdirsPtr,
2353                    &subdirc, &subdirv);
2354            for (i=0; result==TCL_OK && i<subdirc; i++) {
2355                result = DoGlob(interp, matchesObj, separators, subdirv[i],
2356                        1, p+1, types);
2357            }
2358        }
2359        TclDecrRefCount(subdirsPtr);
2360        return result;
2361    }
2362
2363    /*
2364     * We reach here with no pattern char in current section
2365     */
2366
2367    if (*p == '\0') {
2368        /*
2369         * This is the code path reached by a command like 'glob foo'.
2370         *
2371         * There are no more wildcards in the pattern and no more unprocessed
2372         * characters in the pattern, so now we can construct the path, and
2373         * pass it to Tcl_FSMatchInDirectory with an empty pattern to verify
2374         * the existence of the file and check it is of the correct type (if a
2375         * 'types' flag it given -- if no such flag was given, we could just
2376         * use 'Tcl_FSLStat', but for simplicity we keep to a common
2377         * approach).
2378         */
2379
2380        int length;
2381        Tcl_DString append;
2382
2383        Tcl_DStringInit(&append);
2384        Tcl_DStringAppend(&append, pattern, p-pattern);
2385
2386        if (pathPtr != NULL) {
2387            (void) Tcl_GetStringFromObj(pathPtr, &length);
2388        } else {
2389            length = 0;
2390        }
2391
2392        switch (tclPlatform) {
2393        case TCL_PLATFORM_WINDOWS:
2394            if (length == 0 && (Tcl_DStringLength(&append) == 0)) {
2395                if (((*name == '\\') && (name[1] == '/' ||
2396                        name[1] == '\\')) || (*name == '/')) {
2397                    Tcl_DStringAppend(&append, "/", 1);
2398                } else {
2399                    Tcl_DStringAppend(&append, ".", 1);
2400                }
2401            }
2402
2403#if defined(__CYGWIN__) && defined(__WIN32__)
2404            {
2405                extern int cygwin_conv_to_win32_path(const char *, char *);
2406                char winbuf[MAX_PATH+1];
2407
2408                cygwin_conv_to_win32_path(Tcl_DStringValue(&append), winbuf);
2409                Tcl_DStringFree(&append);
2410                Tcl_DStringAppend(&append, winbuf, -1);
2411            }
2412#endif /* __CYGWIN__ && __WIN32__ */
2413            break;
2414
2415        case TCL_PLATFORM_UNIX:
2416            if (length == 0 && (Tcl_DStringLength(&append) == 0)) {
2417                if ((*name == '\\' && name[1] == '/') || (*name == '/')) {
2418                    Tcl_DStringAppend(&append, "/", 1);
2419                } else {
2420                    Tcl_DStringAppend(&append, ".", 1);
2421                }
2422            }
2423            break;
2424        }
2425
2426        /*
2427         * Common for all platforms.
2428         */
2429
2430        if (pathPtr == NULL) {
2431            joinedPtr = Tcl_NewStringObj(Tcl_DStringValue(&append),
2432                    Tcl_DStringLength(&append));
2433        } else if (flags) {
2434            joinedPtr = TclNewFSPathObj(pathPtr, Tcl_DStringValue(&append),
2435                    Tcl_DStringLength(&append));
2436        } else {
2437            joinedPtr = Tcl_DuplicateObj(pathPtr);
2438            if (strchr(separators, Tcl_DStringValue(&append)[0]) == NULL) {
2439                /*
2440                 * The current prefix must end in a separator.
2441                 */
2442
2443                int len;
2444                const char *joined = Tcl_GetStringFromObj(joinedPtr,&len);
2445
2446                if (strchr(separators, joined[len-1]) == NULL) {
2447                    Tcl_AppendToObj(joinedPtr, "/", 1);
2448                }
2449            }
2450            Tcl_AppendToObj(joinedPtr, Tcl_DStringValue(&append),
2451                    Tcl_DStringLength(&append));
2452        }
2453        Tcl_IncrRefCount(joinedPtr);
2454        Tcl_DStringFree(&append);
2455        Tcl_FSMatchInDirectory(interp, matchesObj, joinedPtr, NULL, types);
2456        Tcl_DecrRefCount(joinedPtr);
2457        return TCL_OK;
2458    }
2459
2460    /*
2461     * If it's not the end of the string, we must recurse
2462     */
2463
2464    if (pathPtr == NULL) {
2465        joinedPtr = Tcl_NewStringObj(pattern, p-pattern);
2466    } else if (flags) {
2467        joinedPtr = TclNewFSPathObj(pathPtr, pattern, p-pattern);
2468    } else {
2469        joinedPtr = Tcl_DuplicateObj(pathPtr);
2470        if (strchr(separators, pattern[0]) == NULL) {
2471            /*
2472             * The current prefix must end in a separator, unless this is a
2473             * volume-relative path. In particular globbing in Windows shares,
2474             * when not using -dir or -path, e.g. 'glob [file join
2475             * //machine/share/subdir *]' requires adding a separator here.
2476             * This behaviour is not currently tested for in the test suite.
2477             */
2478
2479            int len;
2480            const char *joined = Tcl_GetStringFromObj(joinedPtr,&len);
2481
2482            if (strchr(separators, joined[len-1]) == NULL) {
2483                if (Tcl_FSGetPathType(pathPtr) != TCL_PATH_VOLUME_RELATIVE) {
2484                    Tcl_AppendToObj(joinedPtr, "/", 1);
2485                }
2486            }
2487        }
2488        Tcl_AppendToObj(joinedPtr, pattern, p-pattern);
2489    }
2490
2491    Tcl_IncrRefCount(joinedPtr);
2492    result = DoGlob(interp, matchesObj, separators, joinedPtr, 1, p, types);
2493    Tcl_DecrRefCount(joinedPtr);
2494
2495    return result;
2496}
2497
2498/*
2499 *---------------------------------------------------------------------------
2500 *
2501 * Tcl_AllocStatBuf --
2502 *
2503 *      This procedure allocates a Tcl_StatBuf on the heap. It exists so that
2504 *      extensions may be used unchanged on systems where largefile support is
2505 *      optional.
2506 *
2507 * Results:
2508 *      A pointer to a Tcl_StatBuf which may be deallocated by being passed to
2509 *      ckfree().
2510 *
2511 * Side effects:
2512 *      None.
2513 *
2514 *---------------------------------------------------------------------------
2515 */
2516
2517Tcl_StatBuf *
2518Tcl_AllocStatBuf(void)
2519{
2520    return (Tcl_StatBuf *) ckalloc(sizeof(Tcl_StatBuf));
2521}
2522
2523/*
2524 * Local Variables:
2525 * mode: c
2526 * c-basic-offset: 4
2527 * fill-column: 78
2528 * End:
2529 */
Note: See TracBrowser for help on using the repository browser.