/[dtapublic]/projs/trunk/shared_source/c_tcl_base_7_5_w_mods/tclfilename.c
ViewVC logotype

Contents of /projs/trunk/shared_source/c_tcl_base_7_5_w_mods/tclfilename.c

Parent Directory Parent Directory | Revision Log Revision Log


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

Properties

Name Value
svn:keywords Header

dashley@gmail.com
ViewVC Help
Powered by ViewVC 1.1.25