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