/[dtapublic]/to_be_filed/sf_code/esrgpcpj/shared/tcl_base/tclfilename.c
ViewVC logotype

Contents of /to_be_filed/sf_code/esrgpcpj/shared/tcl_base/tclfilename.c

Parent Directory Parent Directory | Revision Log Revision Log


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

dashley@gmail.com
ViewVC Help
Powered by ViewVC 1.1.25