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