1/* 2 * tclIOUtil.c -- 3 * 4 * This file contains the implementation of Tcl's generic 5 * filesystem code, which supports a pluggable filesystem 6 * architecture allowing both platform specific filesystems and 7 * 'virtual filesystems'. All filesystem access should go through 8 * the functions defined in this file. Most of this code was 9 * contributed by Vince Darley. 10 * 11 * Parts of this file are based on code contributed by Karl 12 * Lehenbauer, Mark Diekhans and Peter da Silva. 13 * 14 * Copyright (c) 1991-1994 The Regents of the University of California. 15 * Copyright (c) 1994-1997 Sun Microsystems, Inc. 16 * 17 * See the file "license.terms" for information on usage and redistribution 18 * of this file, and for a DISCLAIMER OF ALL WARRANTIES. 19 * 20 * RCS: @(#) $Id: tclIOUtil.c,v 1.77.2.35 2007/12/14 02:29:21 hobbs Exp $ 21 */ 22 23#include "tclInt.h" 24#include "tclPort.h" 25#ifdef MAC_TCL 26#include "tclMacInt.h" 27#endif 28#ifdef __WIN32__ 29/* for tclWinProcs->useWide */ 30#include "tclWinInt.h" 31#endif 32 33/* 34 * struct FilesystemRecord -- 35 * 36 * A filesystem record is used to keep track of each 37 * filesystem currently registered with the core, 38 * in a linked list. Pointers to these structures 39 * are also kept by each "path" Tcl_Obj, and we must 40 * retain a refCount on the number of such references. 41 */ 42typedef struct FilesystemRecord { 43 ClientData clientData; /* Client specific data for the new 44 * filesystem (can be NULL) */ 45 Tcl_Filesystem *fsPtr; /* Pointer to filesystem dispatch 46 * table. */ 47 int fileRefCount; /* How many Tcl_Obj's use this 48 * filesystem. */ 49 struct FilesystemRecord *nextPtr; 50 /* The next filesystem registered 51 * to Tcl, or NULL if no more. */ 52 struct FilesystemRecord *prevPtr; 53 /* The previous filesystem registered 54 * to Tcl, or NULL if no more. */ 55} FilesystemRecord; 56 57/* 58 * The internal TclFS API provides routines for handling and 59 * manipulating paths efficiently, taking direct advantage of 60 * the "path" Tcl_Obj type. 61 * 62 * These functions are not exported at all at present. 63 */ 64 65int TclFSCwdPointerEquals _ANSI_ARGS_((Tcl_Obj* objPtr)); 66int TclFSMakePathFromNormalized _ANSI_ARGS_((Tcl_Interp *interp, 67 Tcl_Obj *objPtr, ClientData clientData)); 68int TclFSNormalizeToUniquePath _ANSI_ARGS_((Tcl_Interp *interp, 69 Tcl_Obj *pathPtr, int startAt, ClientData *clientDataPtr)); 70Tcl_Obj* TclFSMakePathRelative _ANSI_ARGS_((Tcl_Interp *interp, 71 Tcl_Obj *objPtr, Tcl_Obj *cwdPtr)); 72Tcl_Obj* TclFSInternalToNormalized _ANSI_ARGS_(( 73 Tcl_Filesystem *fromFilesystem, ClientData clientData, 74 FilesystemRecord **fsRecPtrPtr)); 75int TclFSEnsureEpochOk _ANSI_ARGS_((Tcl_Obj* pathObjPtr, 76 Tcl_Filesystem **fsPtrPtr)); 77void TclFSSetPathDetails _ANSI_ARGS_((Tcl_Obj *pathObjPtr, 78 FilesystemRecord *fsRecPtr, ClientData clientData)); 79 80/* 81 * Private variables for use in this file 82 */ 83extern Tcl_Filesystem tclNativeFilesystem; 84extern int theFilesystemEpoch; 85 86/* 87 * Private functions for use in this file 88 */ 89static Tcl_PathType FSGetPathType _ANSI_ARGS_((Tcl_Obj *pathObjPtr, 90 Tcl_Filesystem **filesystemPtrPtr, 91 int *driveNameLengthPtr)); 92static Tcl_PathType GetPathType _ANSI_ARGS_((Tcl_Obj *pathObjPtr, 93 Tcl_Filesystem **filesystemPtrPtr, 94 int *driveNameLengthPtr, Tcl_Obj **driveNameRef)); 95static Tcl_FSPathInFilesystemProc NativePathInFilesystem; 96static Tcl_Obj* TclFSNormalizeAbsolutePath 97 _ANSI_ARGS_((Tcl_Interp* interp, Tcl_Obj *pathPtr, 98 ClientData *clientDataPtr)); 99/* 100 * Prototypes for procedures defined later in this file. 101 */ 102 103static FilesystemRecord* FsGetFirstFilesystem(void); 104static void FsThrExitProc(ClientData cd); 105static Tcl_Obj* FsListMounts _ANSI_ARGS_((Tcl_Obj *pathPtr, 106 CONST char *pattern)); 107static Tcl_Obj* FsAddMountsToGlobResult _ANSI_ARGS_((Tcl_Obj *result, 108 Tcl_Obj *pathPtr, CONST char *pattern, Tcl_GlobTypeData *types)); 109 110#ifdef TCL_THREADS 111static void FsRecacheFilesystemList(void); 112#endif 113 114/* 115 * These form part of the native filesystem support. They are needed 116 * here because we have a few native filesystem functions (which are 117 * the same for mac/win/unix) in this file. There is no need to place 118 * them in tclInt.h, because they are not (and should not be) used 119 * anywhere else. 120 */ 121extern CONST char * tclpFileAttrStrings[]; 122extern CONST TclFileAttrProcs tclpFileAttrProcs[]; 123 124/* 125 * The following functions are obsolete string based APIs, and should 126 * be removed in a future release (Tcl 9 would be a good time). 127 */ 128 129/* Obsolete */ 130int 131Tcl_Stat(path, oldStyleBuf) 132 CONST char *path; /* Path of file to stat (in current CP). */ 133 struct stat *oldStyleBuf; /* Filled with results of stat call. */ 134{ 135 int ret; 136 Tcl_StatBuf buf; 137 Tcl_Obj *pathPtr = Tcl_NewStringObj(path,-1); 138 139 Tcl_IncrRefCount(pathPtr); 140 ret = Tcl_FSStat(pathPtr, &buf); 141 Tcl_DecrRefCount(pathPtr); 142 if (ret != -1) { 143#ifndef TCL_WIDE_INT_IS_LONG 144# define OUT_OF_RANGE(x) \ 145 (((Tcl_WideInt)(x)) < Tcl_LongAsWide(LONG_MIN) || \ 146 ((Tcl_WideInt)(x)) > Tcl_LongAsWide(LONG_MAX)) 147#if defined(__GNUC__) && __GNUC__ >= 2 148/* 149 * Workaround gcc warning of "comparison is always false due to limited range of 150 * data type" in this macro by checking max type size, and when necessary ANDing 151 * with the complement of ULONG_MAX instead of the comparison: 152 */ 153# define OUT_OF_URANGE(x) \ 154 ((((Tcl_WideUInt)(~ (__typeof__(x)) 0)) > (Tcl_WideUInt)ULONG_MAX) && \ 155 (((Tcl_WideUInt)(x)) & ~(Tcl_WideUInt)ULONG_MAX)) 156#else 157# define OUT_OF_URANGE(x) \ 158 (((Tcl_WideUInt)(x)) > (Tcl_WideUInt)ULONG_MAX) 159#endif 160 161 /* 162 * Perform the result-buffer overflow check manually. 163 * 164 * Note that ino_t/ino64_t is unsigned... 165 */ 166 167 if (OUT_OF_URANGE(buf.st_ino) || OUT_OF_RANGE(buf.st_size) 168#ifdef HAVE_ST_BLOCKS 169 || OUT_OF_RANGE(buf.st_blocks) 170#endif 171 ) { 172#ifdef EFBIG 173 errno = EFBIG; 174#else 175# ifdef EOVERFLOW 176 errno = EOVERFLOW; 177# else 178# error "What status should be returned for file size out of range?" 179# endif 180#endif 181 return -1; 182 } 183 184# undef OUT_OF_RANGE 185# undef OUT_OF_URANGE 186#endif /* !TCL_WIDE_INT_IS_LONG */ 187 188 /* 189 * Copy across all supported fields, with possible type 190 * coercions on those fields that change between the normal 191 * and lf64 versions of the stat structure (on Solaris at 192 * least.) This is slow when the structure sizes coincide, 193 * but that's what you get for using an obsolete interface. 194 */ 195 196 oldStyleBuf->st_mode = buf.st_mode; 197 oldStyleBuf->st_ino = (ino_t) buf.st_ino; 198 oldStyleBuf->st_dev = buf.st_dev; 199 oldStyleBuf->st_rdev = buf.st_rdev; 200 oldStyleBuf->st_nlink = buf.st_nlink; 201 oldStyleBuf->st_uid = buf.st_uid; 202 oldStyleBuf->st_gid = buf.st_gid; 203 oldStyleBuf->st_size = (off_t) buf.st_size; 204 oldStyleBuf->st_atime = buf.st_atime; 205 oldStyleBuf->st_mtime = buf.st_mtime; 206 oldStyleBuf->st_ctime = buf.st_ctime; 207#ifdef HAVE_ST_BLOCKS 208 oldStyleBuf->st_blksize = buf.st_blksize; 209 oldStyleBuf->st_blocks = (blkcnt_t) buf.st_blocks; 210#endif 211 } 212 return ret; 213} 214 215/* Obsolete */ 216int 217Tcl_Access(path, mode) 218 CONST char *path; /* Path of file to access (in current CP). */ 219 int mode; /* Permission setting. */ 220{ 221 int ret; 222 Tcl_Obj *pathPtr = Tcl_NewStringObj(path,-1); 223 Tcl_IncrRefCount(pathPtr); 224 ret = Tcl_FSAccess(pathPtr,mode); 225 Tcl_DecrRefCount(pathPtr); 226 return ret; 227} 228 229/* Obsolete */ 230Tcl_Channel 231Tcl_OpenFileChannel(interp, path, modeString, permissions) 232 Tcl_Interp *interp; /* Interpreter for error reporting; 233 * can be NULL. */ 234 CONST char *path; /* Name of file to open. */ 235 CONST char *modeString; /* A list of POSIX open modes or 236 * a string such as "rw". */ 237 int permissions; /* If the open involves creating a 238 * file, with what modes to create 239 * it? */ 240{ 241 Tcl_Channel ret; 242 Tcl_Obj *pathPtr = Tcl_NewStringObj(path,-1); 243 Tcl_IncrRefCount(pathPtr); 244 ret = Tcl_FSOpenFileChannel(interp, pathPtr, modeString, permissions); 245 Tcl_DecrRefCount(pathPtr); 246 return ret; 247 248} 249 250/* Obsolete */ 251int 252Tcl_Chdir(dirName) 253 CONST char *dirName; 254{ 255 int ret; 256 Tcl_Obj *pathPtr = Tcl_NewStringObj(dirName,-1); 257 Tcl_IncrRefCount(pathPtr); 258 ret = Tcl_FSChdir(pathPtr); 259 Tcl_DecrRefCount(pathPtr); 260 return ret; 261} 262 263/* Obsolete */ 264char * 265Tcl_GetCwd(interp, cwdPtr) 266 Tcl_Interp *interp; 267 Tcl_DString *cwdPtr; 268{ 269 Tcl_Obj *cwd; 270 cwd = Tcl_FSGetCwd(interp); 271 if (cwd == NULL) { 272 return NULL; 273 } else { 274 Tcl_DStringInit(cwdPtr); 275 Tcl_DStringAppend(cwdPtr, Tcl_GetString(cwd), -1); 276 Tcl_DecrRefCount(cwd); 277 return Tcl_DStringValue(cwdPtr); 278 } 279} 280 281/* Obsolete */ 282int 283Tcl_EvalFile(interp, fileName) 284 Tcl_Interp *interp; /* Interpreter in which to process file. */ 285 CONST char *fileName; /* Name of file to process. Tilde-substitution 286 * will be performed on this name. */ 287{ 288 int ret; 289 Tcl_Obj *pathPtr = Tcl_NewStringObj(fileName,-1); 290 Tcl_IncrRefCount(pathPtr); 291 ret = Tcl_FSEvalFile(interp, pathPtr); 292 Tcl_DecrRefCount(pathPtr); 293 return ret; 294} 295 296 297/* 298 * The 3 hooks for Stat, Access and OpenFileChannel are obsolete. The 299 * complete, general hooked filesystem APIs should be used instead. 300 * This define decides whether to include the obsolete hooks and 301 * related code. If these are removed, we'll also want to remove them 302 * from stubs/tclInt. The only known users of these APIs are prowrap 303 * and mktclapp. New code/extensions should not use them, since they 304 * do not provide as full support as the full filesystem API. 305 * 306 * As soon as prowrap and mktclapp are updated to use the full 307 * filesystem support, I suggest all these hooks are removed. 308 */ 309#define USE_OBSOLETE_FS_HOOKS 310 311 312#ifdef USE_OBSOLETE_FS_HOOKS 313/* 314 * The following typedef declarations allow for hooking into the chain 315 * of functions maintained for 'Tcl_Stat(...)', 'Tcl_Access(...)' & 316 * 'Tcl_OpenFileChannel(...)'. Basically for each hookable function 317 * a linked list is defined. 318 */ 319 320typedef struct StatProc { 321 TclStatProc_ *proc; /* Function to process a 'stat()' call */ 322 struct StatProc *nextPtr; /* The next 'stat()' function to call */ 323} StatProc; 324 325typedef struct AccessProc { 326 TclAccessProc_ *proc; /* Function to process a 'access()' call */ 327 struct AccessProc *nextPtr; /* The next 'access()' function to call */ 328} AccessProc; 329 330typedef struct OpenFileChannelProc { 331 TclOpenFileChannelProc_ *proc; /* Function to process a 332 * 'Tcl_OpenFileChannel()' call */ 333 struct OpenFileChannelProc *nextPtr; 334 /* The next 'Tcl_OpenFileChannel()' 335 * function to call */ 336} OpenFileChannelProc; 337 338/* 339 * For each type of (obsolete) hookable function, a static node is 340 * declared to hold the function pointer for the "built-in" routine 341 * (e.g. 'TclpStat(...)') and the respective list is initialized as a 342 * pointer to that node. 343 * 344 * The "delete" functions (e.g. 'TclStatDeleteProc(...)') ensure that 345 * these statically declared list entry cannot be inadvertently removed. 346 * 347 * This method avoids the need to call any sort of "initialization" 348 * function. 349 * 350 * All three lists are protected by a global obsoleteFsHookMutex. 351 */ 352 353static StatProc *statProcList = NULL; 354static AccessProc *accessProcList = NULL; 355static OpenFileChannelProc *openFileChannelProcList = NULL; 356 357TCL_DECLARE_MUTEX(obsoleteFsHookMutex) 358 359#endif /* USE_OBSOLETE_FS_HOOKS */ 360 361/* 362 * Declare the native filesystem support. These functions should 363 * be considered private to Tcl, and should really not be called 364 * directly by any code other than this file (i.e. neither by 365 * Tcl's core nor by extensions). Similarly, the old string-based 366 * Tclp... native filesystem functions should not be called. 367 * 368 * The correct API to use now is the Tcl_FS... set of functions, 369 * which ensure correct and complete virtual filesystem support. 370 * 371 * We cannot make all of these static, since some of them 372 * are implemented in the platform-specific directories. 373 */ 374static Tcl_FSFilesystemSeparatorProc NativeFilesystemSeparator; 375static Tcl_FSFreeInternalRepProc NativeFreeInternalRep; 376static Tcl_FSCreateInternalRepProc NativeCreateNativeRep; 377static Tcl_FSFileAttrStringsProc NativeFileAttrStrings; 378static Tcl_FSFileAttrsGetProc NativeFileAttrsGet; 379static Tcl_FSFileAttrsSetProc NativeFileAttrsSet; 380 381/* 382 * The only reason these functions are not static is that they 383 * are either called by code in the native (win/unix/mac) directories 384 * or they are actually implemented in those directories. They 385 * should simply not be called by code outside Tcl's native 386 * filesystem core. i.e. they should be considered 'static' to 387 * Tcl's filesystem code (if we ever built the native filesystem 388 * support into a separate code library, this could actually be 389 * enforced). 390 */ 391Tcl_FSFilesystemPathTypeProc TclpFilesystemPathType; 392Tcl_FSInternalToNormalizedProc TclpNativeToNormalized; 393Tcl_FSStatProc TclpObjStat; 394Tcl_FSAccessProc TclpObjAccess; 395Tcl_FSMatchInDirectoryProc TclpMatchInDirectory; 396Tcl_FSGetCwdProc TclpObjGetCwd; 397Tcl_FSChdirProc TclpObjChdir; 398Tcl_FSLstatProc TclpObjLstat; 399Tcl_FSCopyFileProc TclpObjCopyFile; 400Tcl_FSDeleteFileProc TclpObjDeleteFile; 401Tcl_FSRenameFileProc TclpObjRenameFile; 402Tcl_FSCreateDirectoryProc TclpObjCreateDirectory; 403Tcl_FSCopyDirectoryProc TclpObjCopyDirectory; 404Tcl_FSRemoveDirectoryProc TclpObjRemoveDirectory; 405Tcl_FSUnloadFileProc TclpUnloadFile; 406Tcl_FSLinkProc TclpObjLink; 407Tcl_FSListVolumesProc TclpObjListVolumes; 408 409/* 410 * Define the native filesystem dispatch table. If necessary, it 411 * is ok to make this non-static, but it should only be accessed 412 * by the functions actually listed within it (or perhaps other 413 * helper functions of them). Anything which is not part of this 414 * 'native filesystem implementation' should not be delving inside 415 * here! 416 */ 417Tcl_Filesystem tclNativeFilesystem = { 418 "native", 419 sizeof(Tcl_Filesystem), 420 TCL_FILESYSTEM_VERSION_1, 421 &NativePathInFilesystem, 422 &TclNativeDupInternalRep, 423 &NativeFreeInternalRep, 424 &TclpNativeToNormalized, 425 &NativeCreateNativeRep, 426 &TclpObjNormalizePath, 427 &TclpFilesystemPathType, 428 &NativeFilesystemSeparator, 429 &TclpObjStat, 430 &TclpObjAccess, 431 &TclpOpenFileChannel, 432 &TclpMatchInDirectory, 433 &TclpUtime, 434#ifndef S_IFLNK 435 NULL, 436#else 437 &TclpObjLink, 438#endif /* S_IFLNK */ 439 &TclpObjListVolumes, 440 &NativeFileAttrStrings, 441 &NativeFileAttrsGet, 442 &NativeFileAttrsSet, 443 &TclpObjCreateDirectory, 444 &TclpObjRemoveDirectory, 445 &TclpObjDeleteFile, 446 &TclpObjCopyFile, 447 &TclpObjRenameFile, 448 &TclpObjCopyDirectory, 449 &TclpObjLstat, 450 &TclpDlopen, 451 &TclpObjGetCwd, 452 &TclpObjChdir 453}; 454 455/* 456 * Define the tail of the linked list. Note that for unconventional 457 * uses of Tcl without a native filesystem, we may in the future wish 458 * to modify the current approach of hard-coding the native filesystem 459 * in the lookup list 'filesystemList' below. 460 * 461 * We initialize the record so that it thinks one file uses it. This 462 * means it will never be freed. 463 */ 464static FilesystemRecord nativeFilesystemRecord = { 465 NULL, 466 &tclNativeFilesystem, 467 1, 468 NULL 469}; 470 471/* 472 * This is incremented each time we modify the linked list of 473 * filesystems. Any time it changes, all cached filesystem 474 * representations are suspect and must be freed. 475 * For multithreading builds, change of the filesystem epoch 476 * will trigger cache cleanup in all threads. 477 */ 478int theFilesystemEpoch = 0; 479 480/* 481 * Stores the linked list of filesystems. A 1:1 copy of this 482 * list is also maintained in the TSD for each thread. This 483 * is to avoid synchronization issues. 484 */ 485static FilesystemRecord *filesystemList = &nativeFilesystemRecord; 486 487TCL_DECLARE_MUTEX(filesystemMutex) 488 489/* 490 * Used to implement Tcl_FSGetCwd in a file-system independent way. 491 */ 492static Tcl_Obj* cwdPathPtr = NULL; 493static int cwdPathEpoch = 0; 494TCL_DECLARE_MUTEX(cwdMutex) 495 496/* 497 * This structure holds per-thread private copies of 498 * some global data. This way we avoid most of the 499 * synchronization calls which boosts performance, at 500 * cost of having to update this information each 501 * time the corresponding epoch counter changes. 502 * 503 */ 504typedef struct ThreadSpecificData { 505 int initialized; 506 int cwdPathEpoch; 507 int filesystemEpoch; 508 Tcl_Obj *cwdPathPtr; 509 FilesystemRecord *filesystemList; 510} ThreadSpecificData; 511 512static Tcl_ThreadDataKey dataKey; 513 514/* 515 * Declare fallback support function and 516 * information for Tcl_FSLoadFile 517 */ 518static Tcl_FSUnloadFileProc FSUnloadTempFile; 519 520/* 521 * One of these structures is used each time we successfully load a 522 * file from a file system by way of making a temporary copy of the 523 * file on the native filesystem. We need to store both the actual 524 * unloadProc/clientData combination which was used, and the original 525 * and modified filenames, so that we can correctly undo the entire 526 * operation when we want to unload the code. 527 */ 528typedef struct FsDivertLoad { 529 Tcl_LoadHandle loadHandle; 530 Tcl_FSUnloadFileProc *unloadProcPtr; 531 Tcl_Obj *divertedFile; 532 Tcl_Filesystem *divertedFilesystem; 533 ClientData divertedFileNativeRep; 534} FsDivertLoad; 535 536/* Now move on to the basic filesystem implementation */ 537 538static void 539FsThrExitProc(cd) 540 ClientData cd; 541{ 542 ThreadSpecificData *tsdPtr = (ThreadSpecificData*)cd; 543 FilesystemRecord *fsRecPtr = NULL, *tmpFsRecPtr = NULL; 544 545 /* Trash the cwd copy */ 546 if (tsdPtr->cwdPathPtr != NULL) { 547 Tcl_DecrRefCount(tsdPtr->cwdPathPtr); 548 tsdPtr->cwdPathPtr = NULL; 549 } 550 /* Trash the filesystems cache */ 551 fsRecPtr = tsdPtr->filesystemList; 552 while (fsRecPtr != NULL) { 553 tmpFsRecPtr = fsRecPtr->nextPtr; 554 if (--fsRecPtr->fileRefCount <= 0) { 555 ckfree((char *)fsRecPtr); 556 } 557 fsRecPtr = tmpFsRecPtr; 558 } 559 tsdPtr->initialized = 0; 560} 561 562int 563TclFSCwdPointerEquals(objPtr) 564 Tcl_Obj* objPtr; 565{ 566 ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey); 567 568 Tcl_MutexLock(&cwdMutex); 569 if (tsdPtr->cwdPathPtr == NULL) { 570 if (cwdPathPtr == NULL) { 571 tsdPtr->cwdPathPtr = NULL; 572 } else { 573 tsdPtr->cwdPathPtr = Tcl_DuplicateObj(cwdPathPtr); 574 Tcl_IncrRefCount(tsdPtr->cwdPathPtr); 575 } 576 tsdPtr->cwdPathEpoch = cwdPathEpoch; 577 } else if (tsdPtr->cwdPathEpoch != cwdPathEpoch) { 578 Tcl_DecrRefCount(tsdPtr->cwdPathPtr); 579 if (cwdPathPtr == NULL) { 580 tsdPtr->cwdPathPtr = NULL; 581 } else { 582 tsdPtr->cwdPathPtr = Tcl_DuplicateObj(cwdPathPtr); 583 Tcl_IncrRefCount(tsdPtr->cwdPathPtr); 584 } 585 } 586 Tcl_MutexUnlock(&cwdMutex); 587 588 if (tsdPtr->initialized == 0) { 589 Tcl_CreateThreadExitHandler(FsThrExitProc, (ClientData)tsdPtr); 590 tsdPtr->initialized = 1; 591 } 592 return (tsdPtr->cwdPathPtr == objPtr); 593} 594#ifdef TCL_THREADS 595 596static void 597FsRecacheFilesystemList(void) 598{ 599 ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey); 600 FilesystemRecord *fsRecPtr, *tmpFsRecPtr = NULL; 601 602 /* Trash the current cache */ 603 fsRecPtr = tsdPtr->filesystemList; 604 while (fsRecPtr != NULL) { 605 tmpFsRecPtr = fsRecPtr->nextPtr; 606 if (--fsRecPtr->fileRefCount <= 0) { 607 ckfree((char *)fsRecPtr); 608 } 609 fsRecPtr = tmpFsRecPtr; 610 } 611 tsdPtr->filesystemList = NULL; 612 613 /* 614 * Code below operates on shared data. We 615 * are already called under mutex lock so 616 * we can safely proceed. 617 */ 618 619 /* Locate tail of the global filesystem list */ 620 fsRecPtr = filesystemList; 621 while (fsRecPtr != NULL) { 622 tmpFsRecPtr = fsRecPtr; 623 fsRecPtr = fsRecPtr->nextPtr; 624 } 625 626 /* Refill the cache honouring the order */ 627 fsRecPtr = tmpFsRecPtr; 628 while (fsRecPtr != NULL) { 629 tmpFsRecPtr = (FilesystemRecord *)ckalloc(sizeof(FilesystemRecord)); 630 *tmpFsRecPtr = *fsRecPtr; 631 tmpFsRecPtr->nextPtr = tsdPtr->filesystemList; 632 tmpFsRecPtr->prevPtr = NULL; 633 if (tsdPtr->filesystemList) { 634 tsdPtr->filesystemList->prevPtr = tmpFsRecPtr; 635 } 636 tsdPtr->filesystemList = tmpFsRecPtr; 637 fsRecPtr = fsRecPtr->prevPtr; 638 } 639 640 /* Make sure the above gets released on thread exit */ 641 if (tsdPtr->initialized == 0) { 642 Tcl_CreateThreadExitHandler(FsThrExitProc, (ClientData)tsdPtr); 643 tsdPtr->initialized = 1; 644 } 645} 646#endif 647 648static FilesystemRecord * 649FsGetFirstFilesystem(void) { 650 ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey); 651 FilesystemRecord *fsRecPtr; 652#ifndef TCL_THREADS 653 tsdPtr->filesystemEpoch = theFilesystemEpoch; 654 fsRecPtr = filesystemList; 655#else 656 Tcl_MutexLock(&filesystemMutex); 657 if (tsdPtr->filesystemList == NULL 658 || (tsdPtr->filesystemEpoch != theFilesystemEpoch)) { 659 FsRecacheFilesystemList(); 660 tsdPtr->filesystemEpoch = theFilesystemEpoch; 661 } 662 Tcl_MutexUnlock(&filesystemMutex); 663 fsRecPtr = tsdPtr->filesystemList; 664#endif 665 return fsRecPtr; 666} 667 668static void 669FsUpdateCwd(cwdObj) 670 Tcl_Obj *cwdObj; 671{ 672 int len; 673 char *str = NULL; 674 ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey); 675 676 if (cwdObj != NULL) { 677 str = Tcl_GetStringFromObj(cwdObj, &len); 678 } 679 680 Tcl_MutexLock(&cwdMutex); 681 if (cwdPathPtr != NULL) { 682 Tcl_DecrRefCount(cwdPathPtr); 683 } 684 if (cwdObj == NULL) { 685 cwdPathPtr = NULL; 686 } else { 687 /* This MUST be stored as string object! */ 688 cwdPathPtr = Tcl_NewStringObj(str, len); 689 Tcl_IncrRefCount(cwdPathPtr); 690 } 691 cwdPathEpoch++; 692 tsdPtr->cwdPathEpoch = cwdPathEpoch; 693 Tcl_MutexUnlock(&cwdMutex); 694 695 if (tsdPtr->cwdPathPtr) { 696 Tcl_DecrRefCount(tsdPtr->cwdPathPtr); 697 } 698 if (cwdObj == NULL) { 699 tsdPtr->cwdPathPtr = NULL; 700 } else { 701 tsdPtr->cwdPathPtr = Tcl_NewStringObj(str, len); 702 Tcl_IncrRefCount(tsdPtr->cwdPathPtr); 703 } 704} 705 706/* 707 *---------------------------------------------------------------------- 708 * 709 * TclFinalizeFilesystem -- 710 * 711 * Clean up the filesystem. After this, calls to all Tcl_FS... 712 * functions will fail. 713 * 714 * We will later call TclResetFilesystem to restore the FS 715 * to a pristine state. 716 * 717 * Results: 718 * None. 719 * 720 * Side effects: 721 * Frees any memory allocated by the filesystem. 722 * 723 *---------------------------------------------------------------------- 724 */ 725 726void 727TclFinalizeFilesystem() 728{ 729 FilesystemRecord *fsRecPtr; 730 731 /* 732 * Assumption that only one thread is active now. Otherwise 733 * we would need to put various mutexes around this code. 734 */ 735 736 if (cwdPathPtr != NULL) { 737 Tcl_DecrRefCount(cwdPathPtr); 738 cwdPathPtr = NULL; 739 cwdPathEpoch = 0; 740 } 741 742 /* 743 * Remove all filesystems, freeing any allocated memory 744 * that is no longer needed 745 */ 746 747 fsRecPtr = filesystemList; 748 while (fsRecPtr != NULL) { 749 FilesystemRecord *tmpFsRecPtr = fsRecPtr->nextPtr; 750 if (fsRecPtr->fileRefCount <= 0) { 751 /* The native filesystem is static, so we don't free it */ 752 if (fsRecPtr->fsPtr != &tclNativeFilesystem) { 753 ckfree((char *)fsRecPtr); 754 } 755 } 756 fsRecPtr = tmpFsRecPtr; 757 } 758 filesystemList = NULL; 759 760 /* 761 * Now filesystemList is NULL. This means that any attempt 762 * to use the filesystem is likely to fail. 763 */ 764 765 statProcList = NULL; 766 accessProcList = NULL; 767 openFileChannelProcList = NULL; 768#ifdef __WIN32__ 769 TclWinEncodingsCleanup(); 770#endif 771} 772 773/* 774 *---------------------------------------------------------------------- 775 * 776 * TclResetFilesystem -- 777 * 778 * Restore the filesystem to a pristine state. 779 * 780 * Results: 781 * None. 782 * 783 * Side effects: 784 * None. 785 * 786 *---------------------------------------------------------------------- 787 */ 788 789void 790TclResetFilesystem() 791{ 792 filesystemList = &nativeFilesystemRecord; 793 794 /* 795 * Note, at this point, I believe nativeFilesystemRecord -> 796 * fileRefCount should equal 1 and if not, we should try to track 797 * down the cause. 798 */ 799 800#ifdef __WIN32__ 801 /* 802 * Cleans up the win32 API filesystem proc lookup table. This must 803 * happen very late in finalization so that deleting of copied 804 * dlls can occur. 805 */ 806 TclWinResetInterfaces(); 807#endif 808} 809 810/* 811 *---------------------------------------------------------------------- 812 * 813 * Tcl_FSRegister -- 814 * 815 * Insert the filesystem function table at the head of the list of 816 * functions which are used during calls to all file-system 817 * operations. The filesystem will be added even if it is 818 * already in the list. (You can use Tcl_FSData to 819 * check if it is in the list, provided the ClientData used was 820 * not NULL). 821 * 822 * Note that the filesystem handling is head-to-tail of the list. 823 * Each filesystem is asked in turn whether it can handle a 824 * particular request, _until_ one of them says 'yes'. At that 825 * point no further filesystems are asked. 826 * 827 * In particular this means if you want to add a diagnostic 828 * filesystem (which simply reports all fs activity), it must be 829 * at the head of the list: i.e. it must be the last registered. 830 * 831 * Results: 832 * Normally TCL_OK; TCL_ERROR if memory for a new node in the list 833 * could not be allocated. 834 * 835 * Side effects: 836 * Memory allocated and modifies the link list for filesystems. 837 * 838 *---------------------------------------------------------------------- 839 */ 840 841int 842Tcl_FSRegister(clientData, fsPtr) 843 ClientData clientData; /* Client specific data for this fs */ 844 Tcl_Filesystem *fsPtr; /* The filesystem record for the new fs. */ 845{ 846 FilesystemRecord *newFilesystemPtr; 847 848 if (fsPtr == NULL) { 849 return TCL_ERROR; 850 } 851 852 newFilesystemPtr = (FilesystemRecord *) ckalloc(sizeof(FilesystemRecord)); 853 854 newFilesystemPtr->clientData = clientData; 855 newFilesystemPtr->fsPtr = fsPtr; 856 /* 857 * We start with a refCount of 1. If this drops to zero, then 858 * anyone is welcome to ckfree us. 859 */ 860 newFilesystemPtr->fileRefCount = 1; 861 862 /* 863 * Is this lock and wait strictly speaking necessary? Since any 864 * iterators out there will have grabbed a copy of the head of 865 * the list and be iterating away from that, if we add a new 866 * element to the head of the list, it can't possibly have any 867 * effect on any of their loops. In fact it could be better not 868 * to wait, since we are adjusting the filesystem epoch, any 869 * cached representations calculated by existing iterators are 870 * going to have to be thrown away anyway. 871 * 872 * However, since registering and unregistering filesystems is 873 * a very rare action, this is not a very important point. 874 */ 875 Tcl_MutexLock(&filesystemMutex); 876 877 newFilesystemPtr->nextPtr = filesystemList; 878 newFilesystemPtr->prevPtr = NULL; 879 if (filesystemList) { 880 filesystemList->prevPtr = newFilesystemPtr; 881 } 882 filesystemList = newFilesystemPtr; 883 884 /* 885 * Increment the filesystem epoch counter, since existing paths 886 * might conceivably now belong to different filesystems. 887 */ 888 theFilesystemEpoch++; 889 Tcl_MutexUnlock(&filesystemMutex); 890 891 return TCL_OK; 892} 893 894/* 895 *---------------------------------------------------------------------- 896 * 897 * Tcl_FSUnregister -- 898 * 899 * Remove the passed filesystem from the list of filesystem 900 * function tables. It also ensures that the built-in 901 * (native) filesystem is not removable, although we may wish 902 * to change that decision in the future to allow a smaller 903 * Tcl core, in which the native filesystem is not used at 904 * all (we could, say, initialise Tcl completely over a network 905 * connection). 906 * 907 * Results: 908 * TCL_OK if the procedure pointer was successfully removed, 909 * TCL_ERROR otherwise. 910 * 911 * Side effects: 912 * Memory may be deallocated (or will be later, once no "path" 913 * objects refer to this filesystem), but the list of registered 914 * filesystems is updated immediately. 915 * 916 *---------------------------------------------------------------------- 917 */ 918 919int 920Tcl_FSUnregister(fsPtr) 921 Tcl_Filesystem *fsPtr; /* The filesystem record to remove. */ 922{ 923 int retVal = TCL_ERROR; 924 FilesystemRecord *fsRecPtr; 925 926 Tcl_MutexLock(&filesystemMutex); 927 928 /* 929 * Traverse the 'filesystemList' looking for the particular node 930 * whose 'fsPtr' member matches 'fsPtr' and remove that one from 931 * the list. Ensure that the "default" node cannot be removed. 932 */ 933 934 fsRecPtr = filesystemList; 935 while ((retVal == TCL_ERROR) && (fsRecPtr->fsPtr != &tclNativeFilesystem)) { 936 if (fsRecPtr->fsPtr == fsPtr) { 937 if (fsRecPtr->prevPtr) { 938 fsRecPtr->prevPtr->nextPtr = fsRecPtr->nextPtr; 939 } else { 940 filesystemList = fsRecPtr->nextPtr; 941 } 942 if (fsRecPtr->nextPtr) { 943 fsRecPtr->nextPtr->prevPtr = fsRecPtr->prevPtr; 944 } 945 /* 946 * Increment the filesystem epoch counter, since existing 947 * paths might conceivably now belong to different 948 * filesystems. This should also ensure that paths which 949 * have cached the filesystem which is about to be deleted 950 * do not reference that filesystem (which would of course 951 * lead to memory exceptions). 952 */ 953 theFilesystemEpoch++; 954 955 fsRecPtr->fileRefCount--; 956 if (fsRecPtr->fileRefCount <= 0) { 957 ckfree((char *)fsRecPtr); 958 } 959 960 retVal = TCL_OK; 961 } else { 962 fsRecPtr = fsRecPtr->nextPtr; 963 } 964 } 965 966 Tcl_MutexUnlock(&filesystemMutex); 967 return (retVal); 968} 969 970/* 971 *---------------------------------------------------------------------- 972 * 973 * Tcl_FSMatchInDirectory -- 974 * 975 * This routine is used by the globbing code to search a directory 976 * for all files which match a given pattern. The appropriate 977 * function for the filesystem to which pathPtr belongs will be 978 * called. If pathPtr does not belong to any filesystem and if it 979 * is NULL or the empty string, then we assume the pattern is to be 980 * matched in the current working directory. To avoid each 981 * filesystem's Tcl_FSMatchInDirectoryProc having to deal with this 982 * issue, we create a pathPtr on the fly (equal to the cwd), and 983 * then remove it from the results returned. This makes filesystems 984 * easy to write, since they can assume the pathPtr passed to them 985 * is an ordinary path. In fact this means we could remove such 986 * special case handling from Tcl's native filesystems. 987 * 988 * If 'pattern' is NULL, then pathPtr is assumed to be a fully 989 * specified path of a single file/directory which must be 990 * checked for existence and correct type. 991 * 992 * Results: 993 * 994 * The return value is a standard Tcl result indicating whether an 995 * error occurred in globbing. Error messages are placed in 996 * interp, but good results are placed in the resultPtr given. 997 * 998 * Recursive searches, e.g. 999 * 1000 * glob -dir $dir -join * pkgIndex.tcl 1001 * 1002 * which must recurse through each directory matching '*' are 1003 * handled internally by Tcl, by passing specific flags in a 1004 * modified 'types' parameter. This means the actual filesystem 1005 * only ever sees patterns which match in a single directory. 1006 * 1007 * Side effects: 1008 * The interpreter may have an error message inserted into it. 1009 * 1010 *---------------------------------------------------------------------- 1011 */ 1012 1013int 1014Tcl_FSMatchInDirectory(interp, result, pathPtr, pattern, types) 1015 Tcl_Interp *interp; /* Interpreter to receive error messages. */ 1016 Tcl_Obj *result; /* List object to receive results. */ 1017 Tcl_Obj *pathPtr; /* Contains path to directory to search. */ 1018 CONST char *pattern; /* Pattern to match against. */ 1019 Tcl_GlobTypeData *types; /* Object containing list of acceptable types. 1020 * May be NULL. In particular the directory 1021 * flag is very important. */ 1022{ 1023 Tcl_Filesystem *fsPtr = Tcl_FSGetFileSystemForPath(pathPtr); 1024 if (fsPtr != NULL) { 1025 Tcl_FSMatchInDirectoryProc *proc = fsPtr->matchInDirectoryProc; 1026 if (proc != NULL) { 1027 int ret = (*proc)(interp, result, pathPtr, pattern, types); 1028 if (ret == TCL_OK && pattern != NULL) { 1029 result = FsAddMountsToGlobResult(result, pathPtr, 1030 pattern, types); 1031 } 1032 return ret; 1033 } 1034 } else { 1035 Tcl_Obj* cwd; 1036 int ret = -1; 1037 if (pathPtr != NULL) { 1038 int len; 1039 Tcl_GetStringFromObj(pathPtr,&len); 1040 if (len != 0) { 1041 /* 1042 * We have no idea how to match files in a directory 1043 * which belongs to no known filesystem 1044 */ 1045 Tcl_SetErrno(ENOENT); 1046 return -1; 1047 } 1048 } 1049 /* 1050 * We have an empty or NULL path. This is defined to mean we 1051 * must search for files within the current 'cwd'. We 1052 * therefore use that, but then since the proc we call will 1053 * return results which include the cwd we must then trim it 1054 * off the front of each path in the result. We choose to deal 1055 * with this here (in the generic code), since if we don't, 1056 * every single filesystem's implementation of 1057 * Tcl_FSMatchInDirectory will have to deal with it for us. 1058 */ 1059 cwd = Tcl_FSGetCwd(NULL); 1060 if (cwd == NULL) { 1061 if (interp != NULL) { 1062 Tcl_SetResult(interp, "glob couldn't determine " 1063 "the current working directory", TCL_STATIC); 1064 } 1065 return TCL_ERROR; 1066 } 1067 fsPtr = Tcl_FSGetFileSystemForPath(cwd); 1068 if (fsPtr != NULL) { 1069 Tcl_FSMatchInDirectoryProc *proc = fsPtr->matchInDirectoryProc; 1070 if (proc != NULL) { 1071 Tcl_Obj* tmpResultPtr = Tcl_NewListObj(0, NULL); 1072 Tcl_IncrRefCount(tmpResultPtr); 1073 ret = (*proc)(interp, tmpResultPtr, cwd, pattern, types); 1074 if (ret == TCL_OK) { 1075 int resLength; 1076 1077 tmpResultPtr = FsAddMountsToGlobResult(tmpResultPtr, cwd, 1078 pattern, types); 1079 1080 ret = Tcl_ListObjLength(interp, tmpResultPtr, &resLength); 1081 if (ret == TCL_OK) { 1082 int i; 1083 1084 for (i = 0; i < resLength; i++) { 1085 Tcl_Obj *elt; 1086 1087 Tcl_ListObjIndex(interp, tmpResultPtr, i, &elt); 1088 Tcl_ListObjAppendElement(interp, result, 1089 TclFSMakePathRelative(interp, elt, cwd)); 1090 } 1091 } 1092 } 1093 Tcl_DecrRefCount(tmpResultPtr); 1094 } 1095 } 1096 Tcl_DecrRefCount(cwd); 1097 return ret; 1098 } 1099 Tcl_SetErrno(ENOENT); 1100 return -1; 1101} 1102 1103/* 1104 *---------------------------------------------------------------------- 1105 * 1106 * FsAddMountsToGlobResult -- 1107 * 1108 * This routine is used by the globbing code to take the results 1109 * of a directory listing and add any mounted paths to that 1110 * listing. This is required so that simple things like 1111 * 'glob *' merge mounts and listings correctly. 1112 * 1113 * Results: 1114 * 1115 * The passed in 'result' may be modified (in place, if 1116 * necessary), and the correct list is returned. 1117 * 1118 * Side effects: 1119 * None. 1120 * 1121 *---------------------------------------------------------------------- 1122 */ 1123static Tcl_Obj* 1124FsAddMountsToGlobResult(result, pathPtr, pattern, types) 1125 Tcl_Obj *result; /* The current list of matching paths */ 1126 Tcl_Obj *pathPtr; /* The directory in question */ 1127 CONST char *pattern; 1128 Tcl_GlobTypeData *types; 1129{ 1130 int mLength, gLength, i; 1131 int dir = (types == NULL || (types->type & TCL_GLOB_TYPE_DIR)); 1132 Tcl_Obj *mounts = FsListMounts(pathPtr, pattern); 1133 1134 if (mounts == NULL) return result; 1135 1136 if (Tcl_ListObjLength(NULL, mounts, &mLength) != TCL_OK || mLength == 0) { 1137 goto endOfMounts; 1138 } 1139 if (Tcl_ListObjLength(NULL, result, &gLength) != TCL_OK) { 1140 goto endOfMounts; 1141 } 1142 for (i = 0; i < mLength; i++) { 1143 Tcl_Obj *mElt; 1144 int j; 1145 int found = 0; 1146 1147 Tcl_ListObjIndex(NULL, mounts, i, &mElt); 1148 1149 for (j = 0; j < gLength; j++) { 1150 Tcl_Obj *gElt; 1151 Tcl_ListObjIndex(NULL, result, j, &gElt); 1152 if (Tcl_FSEqualPaths(mElt, gElt)) { 1153 found = 1; 1154 if (!dir) { 1155 /* We don't want to list this */ 1156 if (Tcl_IsShared(result)) { 1157 Tcl_Obj *newList; 1158 newList = Tcl_DuplicateObj(result); 1159 Tcl_DecrRefCount(result); 1160 result = newList; 1161 } 1162 Tcl_ListObjReplace(NULL, result, j, 1, 0, NULL); 1163 gLength--; 1164 } 1165 /* Break out of for loop */ 1166 break; 1167 } 1168 } 1169 if (!found && dir) { 1170 if (Tcl_IsShared(result)) { 1171 Tcl_Obj *newList; 1172 newList = Tcl_DuplicateObj(result); 1173 Tcl_DecrRefCount(result); 1174 result = newList; 1175 } 1176 Tcl_ListObjAppendElement(NULL, result, mElt); 1177 /* 1178 * No need to increment gLength, since we 1179 * don't want to compare mounts against 1180 * mounts. 1181 */ 1182 } 1183 } 1184 endOfMounts: 1185 Tcl_DecrRefCount(mounts); 1186 return result; 1187} 1188 1189/* 1190 *---------------------------------------------------------------------- 1191 * 1192 * Tcl_FSMountsChanged -- 1193 * 1194 * Notify the filesystem that the available mounted filesystems 1195 * (or within any one filesystem type, the number or location of 1196 * mount points) have changed. 1197 * 1198 * Results: 1199 * None. 1200 * 1201 * Side effects: 1202 * The global filesystem variable 'theFilesystemEpoch' is 1203 * incremented. The effect of this is to make all cached 1204 * path representations invalid. Clearly it should only therefore 1205 * be called when it is really required! There are a few 1206 * circumstances when it should be called: 1207 * 1208 * (1) when a new filesystem is registered or unregistered. 1209 * Strictly speaking this is only necessary if the new filesystem 1210 * accepts file paths as is (normally the filesystem itself is 1211 * really a shell which hasn't yet had any mount points established 1212 * and so its 'pathInFilesystem' proc will always fail). However, 1213 * for safety, Tcl always calls this for you in these circumstances. 1214 * 1215 * (2) when additional mount points are established inside any 1216 * existing filesystem (except the native fs) 1217 * 1218 * (3) when any filesystem (except the native fs) changes the list 1219 * of available volumes. 1220 * 1221 * (4) when the mapping from a string representation of a file to 1222 * a full, normalized path changes. For example, if 'env(HOME)' 1223 * is modified, then any path containing '~' will map to a different 1224 * filesystem location. Therefore all such paths need to have 1225 * their internal representation invalidated. 1226 * 1227 * Tcl has no control over (2) and (3), so any registered filesystem 1228 * must make sure it calls this function when those situations 1229 * occur. 1230 * 1231 * (Note: the reason for the exception in 2,3 for the native 1232 * filesystem is that the native filesystem by default claims all 1233 * unknown files even if it really doesn't understand them or if 1234 * they don't exist). 1235 * 1236 *---------------------------------------------------------------------- 1237 */ 1238 1239void 1240Tcl_FSMountsChanged(fsPtr) 1241 Tcl_Filesystem *fsPtr; 1242{ 1243 /* 1244 * We currently don't do anything with this parameter. We 1245 * could in the future only invalidate files for this filesystem 1246 * or otherwise take more advanced action. 1247 */ 1248 (void)fsPtr; 1249 /* 1250 * Increment the filesystem epoch counter, since existing paths 1251 * might now belong to different filesystems. 1252 */ 1253 Tcl_MutexLock(&filesystemMutex); 1254 theFilesystemEpoch++; 1255 Tcl_MutexUnlock(&filesystemMutex); 1256} 1257 1258/* 1259 *---------------------------------------------------------------------- 1260 * 1261 * Tcl_FSData -- 1262 * 1263 * Retrieve the clientData field for the filesystem given, 1264 * or NULL if that filesystem is not registered. 1265 * 1266 * Results: 1267 * A clientData value, or NULL. Note that if the filesystem 1268 * was registered with a NULL clientData field, this function 1269 * will return that NULL value. 1270 * 1271 * Side effects: 1272 * None. 1273 * 1274 *---------------------------------------------------------------------- 1275 */ 1276 1277ClientData 1278Tcl_FSData(fsPtr) 1279 Tcl_Filesystem *fsPtr; /* The filesystem record to query. */ 1280{ 1281 ClientData retVal = NULL; 1282 FilesystemRecord *fsRecPtr = FsGetFirstFilesystem(); 1283 1284 /* 1285 * Traverse the 'filesystemList' looking for the particular node 1286 * whose 'fsPtr' member matches 'fsPtr' and remove that one from 1287 * the list. Ensure that the "default" node cannot be removed. 1288 */ 1289 1290 while ((retVal == NULL) && (fsRecPtr != NULL)) { 1291 if (fsRecPtr->fsPtr == fsPtr) { 1292 retVal = fsRecPtr->clientData; 1293 } 1294 fsRecPtr = fsRecPtr->nextPtr; 1295 } 1296 1297 return retVal; 1298} 1299 1300/* 1301 *--------------------------------------------------------------------------- 1302 * 1303 * TclFSNormalizeAbsolutePath -- 1304 * 1305 * Description: 1306 * Takes an absolute path specification and computes a 'normalized' 1307 * path from it. 1308 * 1309 * A normalized path is one which has all '../', './' removed. 1310 * Also it is one which is in the 'standard' format for the native 1311 * platform. On MacOS, Unix, this means the path must be free of 1312 * symbolic links/aliases, and on Windows it means we want the 1313 * long form, with that long form's case-dependence (which gives 1314 * us a unique, case-dependent path). 1315 * 1316 * The behaviour of this function if passed a non-absolute path 1317 * is NOT defined. 1318 * 1319 * Results: 1320 * The result is returned in a Tcl_Obj with a refCount of 1, 1321 * which is therefore owned by the caller. It must be 1322 * freed (with Tcl_DecrRefCount) by the caller when no longer needed. 1323 * 1324 * Side effects: 1325 * None (beyond the memory allocation for the result). 1326 * 1327 * Special note: 1328 * This code is based on code from Matt Newman and Jean-Claude 1329 * Wippler, with additions from Vince Darley and is copyright 1330 * those respective authors. 1331 * 1332 *--------------------------------------------------------------------------- 1333 */ 1334static Tcl_Obj * 1335TclFSNormalizeAbsolutePath(interp, pathPtr, clientDataPtr) 1336 Tcl_Interp* interp; /* Interpreter to use */ 1337 Tcl_Obj *pathPtr; /* Absolute path to normalize */ 1338 ClientData *clientDataPtr; 1339{ 1340 int splen = 0, nplen, eltLen, i; 1341 char *eltName; 1342 Tcl_Obj *retVal; 1343 Tcl_Obj *split; 1344 Tcl_Obj *elt; 1345 1346 /* Split has refCount zero */ 1347 split = Tcl_FSSplitPath(pathPtr, &splen); 1348 1349 /* 1350 * Modify the list of entries in place, by removing '.', and 1351 * removing '..' and the entry before -- unless that entry before 1352 * is the top-level entry, i.e. the name of a volume. 1353 */ 1354 nplen = 0; 1355 for (i = 0; i < splen; i++) { 1356 Tcl_ListObjIndex(NULL, split, nplen, &elt); 1357 eltName = Tcl_GetStringFromObj(elt, &eltLen); 1358 1359 if ((eltLen == 1) && (eltName[0] == '.')) { 1360 Tcl_ListObjReplace(NULL, split, nplen, 1, 0, NULL); 1361 } else if ((eltLen == 2) 1362 && (eltName[0] == '.') && (eltName[1] == '.')) { 1363 if (nplen > 1) { 1364 nplen--; 1365 Tcl_ListObjReplace(NULL, split, nplen, 2, 0, NULL); 1366 } else { 1367 Tcl_ListObjReplace(NULL, split, nplen, 1, 0, NULL); 1368 } 1369 } else { 1370 nplen++; 1371 } 1372 } 1373 if (nplen > 0) { 1374 ClientData clientData = NULL; 1375 1376 retVal = Tcl_FSJoinPath(split, nplen); 1377 /* 1378 * Now we have an absolute path, with no '..', '.' sequences, 1379 * but it still may not be in 'unique' form, depending on the 1380 * platform. For instance, Unix is case-sensitive, so the 1381 * path is ok. Windows is case-insensitive, and also has the 1382 * weird 'longname/shortname' thing (e.g. C:/Program Files/ and 1383 * C:/Progra~1/ are equivalent). MacOS is case-insensitive. 1384 * 1385 * Virtual file systems which may be registered may have 1386 * other criteria for normalizing a path. 1387 */ 1388 Tcl_IncrRefCount(retVal); 1389 TclFSNormalizeToUniquePath(interp, retVal, 0, &clientData); 1390 /* 1391 * Since we know it is a normalized path, we can 1392 * actually convert this object into an "path" object for 1393 * greater efficiency 1394 */ 1395 TclFSMakePathFromNormalized(interp, retVal, clientData); 1396 if (clientDataPtr != NULL) { 1397 *clientDataPtr = clientData; 1398 } 1399 } else { 1400 /* Init to an empty string */ 1401 retVal = Tcl_NewStringObj("",0); 1402 Tcl_IncrRefCount(retVal); 1403 } 1404 /* 1405 * We increment and then decrement the refCount of split to free 1406 * it. We do this right at the end, in case there are 1407 * optimisations in Tcl_FSJoinPath(split, nplen) above which would 1408 * let it make use of split more effectively if it has a refCount 1409 * of zero. Also we can't just decrement the ref count, in case 1410 * 'split' was actually returned by the join call above, in a 1411 * single-element optimisation when nplen == 1. 1412 */ 1413 Tcl_IncrRefCount(split); 1414 Tcl_DecrRefCount(split); 1415 1416 /* This has a refCount of 1 for the caller */ 1417 return retVal; 1418} 1419 1420/* 1421 *--------------------------------------------------------------------------- 1422 * 1423 * TclFSNormalizeToUniquePath -- 1424 * 1425 * Description: 1426 * Takes a path specification containing no ../, ./ sequences, 1427 * and converts it into a unique path for the given platform. 1428 * On MacOS, Unix, this means the path must be free of 1429 * symbolic links/aliases, and on Windows it means we want the 1430 * long form, with that long form's case-dependence (which gives 1431 * us a unique, case-dependent path). 1432 * 1433 * Results: 1434 * The pathPtr is modified in place. The return value is 1435 * the last byte offset which was recognised in the path 1436 * string. 1437 * 1438 * Side effects: 1439 * None (beyond the memory allocation for the result). 1440 * 1441 * Special notes: 1442 * If the filesystem-specific normalizePathProcs can re-introduce 1443 * ../, ./ sequences into the path, then this function will 1444 * not return the correct result. This may be possible with 1445 * symbolic links on unix/macos. 1446 * 1447 * Important assumption: if startAt is non-zero, it must point 1448 * to a directory separator that we know exists and is already 1449 * normalized (so it is important not to point to the char just 1450 * after the separator). 1451 *--------------------------------------------------------------------------- 1452 */ 1453int 1454TclFSNormalizeToUniquePath(interp, pathPtr, startAt, clientDataPtr) 1455 Tcl_Interp *interp; 1456 Tcl_Obj *pathPtr; 1457 int startAt; 1458 ClientData *clientDataPtr; 1459{ 1460 FilesystemRecord *fsRecPtr, *firstFsRecPtr; 1461 /* Ignore this variable */ 1462 (void)clientDataPtr; 1463 1464 /* 1465 * Call each of the "normalise path" functions in succession. This is 1466 * a special case, in which if we have a native filesystem handler, 1467 * we call it first. This is because the root of Tcl's filesystem 1468 * is always a native filesystem (i.e. '/' on unix is native). 1469 */ 1470 1471 firstFsRecPtr = FsGetFirstFilesystem(); 1472 1473 fsRecPtr = firstFsRecPtr; 1474 while (fsRecPtr != NULL) { 1475 if (fsRecPtr->fsPtr == &tclNativeFilesystem) { 1476 Tcl_FSNormalizePathProc *proc = fsRecPtr->fsPtr->normalizePathProc; 1477 if (proc != NULL) { 1478 startAt = (*proc)(interp, pathPtr, startAt); 1479 } 1480 break; 1481 } 1482 fsRecPtr = fsRecPtr->nextPtr; 1483 } 1484 1485 fsRecPtr = firstFsRecPtr; 1486 while (fsRecPtr != NULL) { 1487 /* Skip the native system next time through */ 1488 if (fsRecPtr->fsPtr != &tclNativeFilesystem) { 1489 Tcl_FSNormalizePathProc *proc = fsRecPtr->fsPtr->normalizePathProc; 1490 if (proc != NULL) { 1491 startAt = (*proc)(interp, pathPtr, startAt); 1492 } 1493 /* 1494 * We could add an efficiency check like this: 1495 * 1496 * if (retVal == length-of(pathPtr)) {break;} 1497 * 1498 * but there's not much benefit. 1499 */ 1500 } 1501 fsRecPtr = fsRecPtr->nextPtr; 1502 } 1503 1504 return startAt; 1505} 1506 1507/* 1508 *--------------------------------------------------------------------------- 1509 * 1510 * TclGetOpenMode -- 1511 * 1512 * Description: 1513 * Computes a POSIX mode mask for opening a file, from a given string, 1514 * and also sets a flag to indicate whether the caller should seek to 1515 * EOF after opening the file. 1516 * 1517 * Results: 1518 * On success, returns mode to pass to "open". If an error occurs, the 1519 * return value is -1 and if interp is not NULL, sets interp's result 1520 * object to an error message. 1521 * 1522 * Side effects: 1523 * Sets the integer referenced by seekFlagPtr to 1 to tell the caller 1524 * to seek to EOF after opening the file. 1525 * 1526 * Special note: 1527 * This code is based on a prototype implementation contributed 1528 * by Mark Diekhans. 1529 * 1530 *--------------------------------------------------------------------------- 1531 */ 1532 1533int 1534TclGetOpenMode(interp, string, seekFlagPtr) 1535 Tcl_Interp *interp; /* Interpreter to use for error 1536 * reporting - may be NULL. */ 1537 CONST char *string; /* Mode string, e.g. "r+" or 1538 * "RDONLY CREAT". */ 1539 int *seekFlagPtr; /* Set this to 1 if the caller 1540 * should seek to EOF during the 1541 * opening of the file. */ 1542{ 1543 int mode, modeArgc, c, i, gotRW; 1544 CONST char **modeArgv, *flag; 1545#define RW_MODES (O_RDONLY|O_WRONLY|O_RDWR) 1546 1547 /* 1548 * Check for the simpler fopen-like access modes (e.g. "r"). They 1549 * are distinguished from the POSIX access modes by the presence 1550 * of a lower-case first letter. 1551 */ 1552 1553 *seekFlagPtr = 0; 1554 mode = 0; 1555 1556 /* 1557 * Guard against international characters before using byte oriented 1558 * routines. 1559 */ 1560 1561 if (!(string[0] & 0x80) 1562 && islower(UCHAR(string[0]))) { /* INTL: ISO only. */ 1563 switch (string[0]) { 1564 case 'r': 1565 mode = O_RDONLY; 1566 break; 1567 case 'w': 1568 mode = O_WRONLY|O_CREAT|O_TRUNC; 1569 break; 1570 case 'a': 1571 /* [Bug 680143]. 1572 * Added O_APPEND for proper automatic 1573 * seek-to-end-on-write by the OS. 1574 */ 1575 mode = O_WRONLY|O_CREAT|O_APPEND; 1576 *seekFlagPtr = 1; 1577 break; 1578 default: 1579 error: 1580 if (interp != (Tcl_Interp *) NULL) { 1581 Tcl_AppendResult(interp, 1582 "illegal access mode \"", string, "\"", 1583 (char *) NULL); 1584 } 1585 return -1; 1586 } 1587 if (string[1] == '+') { 1588 /* 1589 * Must remove the O_APPEND flag so that the seek command 1590 * works. [Bug 1773127] 1591 */ 1592 mode &= ~(O_RDONLY|O_WRONLY|O_APPEND); 1593 mode |= O_RDWR; 1594 if (string[2] != 0) { 1595 goto error; 1596 } 1597 } else if (string[1] != 0) { 1598 goto error; 1599 } 1600 return mode; 1601 } 1602 1603 /* 1604 * The access modes are specified using a list of POSIX modes 1605 * such as O_CREAT. 1606 * 1607 * IMPORTANT NOTE: We rely on Tcl_SplitList working correctly when 1608 * a NULL interpreter is passed in. 1609 */ 1610 1611 if (Tcl_SplitList(interp, string, &modeArgc, &modeArgv) != TCL_OK) { 1612 if (interp != (Tcl_Interp *) NULL) { 1613 Tcl_AddErrorInfo(interp, 1614 "\n while processing open access modes \""); 1615 Tcl_AddErrorInfo(interp, string); 1616 Tcl_AddErrorInfo(interp, "\""); 1617 } 1618 return -1; 1619 } 1620 1621 gotRW = 0; 1622 for (i = 0; i < modeArgc; i++) { 1623 flag = modeArgv[i]; 1624 c = flag[0]; 1625 if ((c == 'R') && (strcmp(flag, "RDONLY") == 0)) { 1626 mode = (mode & ~RW_MODES) | O_RDONLY; 1627 gotRW = 1; 1628 } else if ((c == 'W') && (strcmp(flag, "WRONLY") == 0)) { 1629 mode = (mode & ~RW_MODES) | O_WRONLY; 1630 gotRW = 1; 1631 } else if ((c == 'R') && (strcmp(flag, "RDWR") == 0)) { 1632 mode = (mode & ~RW_MODES) | O_RDWR; 1633 gotRW = 1; 1634 } else if ((c == 'A') && (strcmp(flag, "APPEND") == 0)) { 1635 mode |= O_APPEND; 1636 *seekFlagPtr = 1; 1637 } else if ((c == 'C') && (strcmp(flag, "CREAT") == 0)) { 1638 mode |= O_CREAT; 1639 } else if ((c == 'E') && (strcmp(flag, "EXCL") == 0)) { 1640 mode |= O_EXCL; 1641 } else if ((c == 'N') && (strcmp(flag, "NOCTTY") == 0)) { 1642#ifdef O_NOCTTY 1643 mode |= O_NOCTTY; 1644#else 1645 if (interp != (Tcl_Interp *) NULL) { 1646 Tcl_AppendResult(interp, "access mode \"", flag, 1647 "\" not supported by this system", (char *) NULL); 1648 } 1649 ckfree((char *) modeArgv); 1650 return -1; 1651#endif 1652 } else if ((c == 'N') && (strcmp(flag, "NONBLOCK") == 0)) { 1653#if defined(O_NDELAY) || defined(O_NONBLOCK) 1654# ifdef O_NONBLOCK 1655 mode |= O_NONBLOCK; 1656# else 1657 mode |= O_NDELAY; 1658# endif 1659#else 1660 if (interp != (Tcl_Interp *) NULL) { 1661 Tcl_AppendResult(interp, "access mode \"", flag, 1662 "\" not supported by this system", (char *) NULL); 1663 } 1664 ckfree((char *) modeArgv); 1665 return -1; 1666#endif 1667 } else if ((c == 'T') && (strcmp(flag, "TRUNC") == 0)) { 1668 mode |= O_TRUNC; 1669 } else { 1670 if (interp != (Tcl_Interp *) NULL) { 1671 Tcl_AppendResult(interp, "invalid access mode \"", flag, 1672 "\": must be RDONLY, WRONLY, RDWR, APPEND, CREAT", 1673 " EXCL, NOCTTY, NONBLOCK, or TRUNC", (char *) NULL); 1674 } 1675 ckfree((char *) modeArgv); 1676 return -1; 1677 } 1678 } 1679 ckfree((char *) modeArgv); 1680 if (!gotRW) { 1681 if (interp != (Tcl_Interp *) NULL) { 1682 Tcl_AppendResult(interp, "access mode must include either", 1683 " RDONLY, WRONLY, or RDWR", (char *) NULL); 1684 } 1685 return -1; 1686 } 1687 return mode; 1688} 1689 1690/* 1691 *---------------------------------------------------------------------- 1692 * 1693 * Tcl_FSEvalFile -- 1694 * 1695 * Read in a file and process the entire file as one gigantic 1696 * Tcl command. 1697 * 1698 * Results: 1699 * A standard Tcl result, which is either the result of executing 1700 * the file or an error indicating why the file couldn't be read. 1701 * 1702 * Side effects: 1703 * Depends on the commands in the file. During the evaluation 1704 * of the contents of the file, iPtr->scriptFile is made to 1705 * point to pathPtr (the old value is cached and replaced when 1706 * this function returns). 1707 * 1708 *---------------------------------------------------------------------- 1709 */ 1710 1711int 1712Tcl_FSEvalFile(interp, pathPtr) 1713 Tcl_Interp *interp; /* Interpreter in which to process file. */ 1714 Tcl_Obj *pathPtr; /* Path of file to process. Tilde-substitution 1715 * will be performed on this name. */ 1716{ 1717 int result, length; 1718 Tcl_StatBuf statBuf; 1719 Tcl_Obj *oldScriptFile; 1720 Interp *iPtr; 1721 char *string; 1722 Tcl_Channel chan; 1723 Tcl_Obj *objPtr; 1724 1725 if (Tcl_FSGetNormalizedPath(interp, pathPtr) == NULL) { 1726 return TCL_ERROR; 1727 } 1728 1729 result = TCL_ERROR; 1730 objPtr = Tcl_NewObj(); 1731 Tcl_IncrRefCount(objPtr); 1732 1733 if (Tcl_FSStat(pathPtr, &statBuf) == -1) { 1734 Tcl_SetErrno(errno); 1735 Tcl_AppendResult(interp, "couldn't read file \"", 1736 Tcl_GetString(pathPtr), 1737 "\": ", Tcl_PosixError(interp), (char *) NULL); 1738 goto end; 1739 } 1740 chan = Tcl_FSOpenFileChannel(interp, pathPtr, "r", 0644); 1741 if (chan == (Tcl_Channel) NULL) { 1742 Tcl_ResetResult(interp); 1743 Tcl_AppendResult(interp, "couldn't read file \"", 1744 Tcl_GetString(pathPtr), 1745 "\": ", Tcl_PosixError(interp), (char *) NULL); 1746 goto end; 1747 } 1748 /* 1749 * The eofchar is \32 (^Z). This is the usual on Windows, but we 1750 * effect this cross-platform to allow for scripted documents. 1751 * [Bug: 2040] 1752 */ 1753 Tcl_SetChannelOption(interp, chan, "-eofchar", "\32"); 1754 if (Tcl_ReadChars(chan, objPtr, -1, 0) < 0) { 1755 Tcl_Close(interp, chan); 1756 Tcl_AppendResult(interp, "couldn't read file \"", 1757 Tcl_GetString(pathPtr), 1758 "\": ", Tcl_PosixError(interp), (char *) NULL); 1759 goto end; 1760 } 1761 if (Tcl_Close(interp, chan) != TCL_OK) { 1762 goto end; 1763 } 1764 1765 iPtr = (Interp *) interp; 1766 oldScriptFile = iPtr->scriptFile; 1767 iPtr->scriptFile = pathPtr; 1768 Tcl_IncrRefCount(iPtr->scriptFile); 1769 string = Tcl_GetStringFromObj(objPtr, &length); 1770 1771#ifdef TCL_TIP280 1772 /* TIP #280 Force the evaluator to open a frame for a sourced 1773 * file. */ 1774 iPtr->evalFlags |= TCL_EVAL_FILE; 1775#endif 1776 result = Tcl_EvalEx(interp, string, length, 0); 1777 /* 1778 * Now we have to be careful; the script may have changed the 1779 * iPtr->scriptFile value, so we must reset it without 1780 * assuming it still points to 'pathPtr'. 1781 */ 1782 if (iPtr->scriptFile != NULL) { 1783 Tcl_DecrRefCount(iPtr->scriptFile); 1784 } 1785 iPtr->scriptFile = oldScriptFile; 1786 1787 if (result == TCL_RETURN) { 1788 result = TclUpdateReturnInfo(iPtr); 1789 } else if (result == TCL_ERROR) { 1790 char msg[200 + TCL_INTEGER_SPACE]; 1791 1792 /* 1793 * Record information telling where the error occurred. 1794 */ 1795 1796 sprintf(msg, "\n (file \"%.150s\" line %d)", Tcl_GetString(pathPtr), 1797 interp->errorLine); 1798 Tcl_AddErrorInfo(interp, msg); 1799 } 1800 1801 end: 1802 Tcl_DecrRefCount(objPtr); 1803 return result; 1804} 1805 1806/* 1807 *---------------------------------------------------------------------- 1808 * 1809 * Tcl_GetErrno -- 1810 * 1811 * Gets the current value of the Tcl error code variable. This is 1812 * currently the global variable "errno" but could in the future 1813 * change to something else. 1814 * 1815 * Results: 1816 * The value of the Tcl error code variable. 1817 * 1818 * Side effects: 1819 * None. Note that the value of the Tcl error code variable is 1820 * UNDEFINED if a call to Tcl_SetErrno did not precede this call. 1821 * 1822 *---------------------------------------------------------------------- 1823 */ 1824 1825int 1826Tcl_GetErrno() 1827{ 1828 return errno; 1829} 1830 1831/* 1832 *---------------------------------------------------------------------- 1833 * 1834 * Tcl_SetErrno -- 1835 * 1836 * Sets the Tcl error code variable to the supplied value. 1837 * 1838 * Results: 1839 * None. 1840 * 1841 * Side effects: 1842 * Modifies the value of the Tcl error code variable. 1843 * 1844 *---------------------------------------------------------------------- 1845 */ 1846 1847void 1848Tcl_SetErrno(err) 1849 int err; /* The new value. */ 1850{ 1851 errno = err; 1852} 1853 1854/* 1855 *---------------------------------------------------------------------- 1856 * 1857 * Tcl_PosixError -- 1858 * 1859 * This procedure is typically called after UNIX kernel calls 1860 * return errors. It stores machine-readable information about 1861 * the error in $errorCode returns an information string for 1862 * the caller's use. 1863 * 1864 * Results: 1865 * The return value is a human-readable string describing the 1866 * error. 1867 * 1868 * Side effects: 1869 * The global variable $errorCode is reset. 1870 * 1871 *---------------------------------------------------------------------- 1872 */ 1873 1874CONST char * 1875Tcl_PosixError(interp) 1876 Tcl_Interp *interp; /* Interpreter whose $errorCode variable 1877 * is to be changed. */ 1878{ 1879 CONST char *id, *msg; 1880 1881 msg = Tcl_ErrnoMsg(errno); 1882 id = Tcl_ErrnoId(); 1883 if (interp) { 1884 Tcl_SetErrorCode(interp, "POSIX", id, msg, (char *) NULL); 1885 } 1886 return msg; 1887} 1888 1889/* 1890 *---------------------------------------------------------------------- 1891 * 1892 * Tcl_FSStat -- 1893 * 1894 * This procedure replaces the library version of stat and lsat. 1895 * 1896 * The appropriate function for the filesystem to which pathPtr 1897 * belongs will be called. 1898 * 1899 * Results: 1900 * See stat documentation. 1901 * 1902 * Side effects: 1903 * See stat documentation. 1904 * 1905 *---------------------------------------------------------------------- 1906 */ 1907 1908int 1909Tcl_FSStat(pathPtr, buf) 1910 Tcl_Obj *pathPtr; /* Path of file to stat (in current CP). */ 1911 Tcl_StatBuf *buf; /* Filled with results of stat call. */ 1912{ 1913 Tcl_Filesystem *fsPtr; 1914#ifdef USE_OBSOLETE_FS_HOOKS 1915 struct stat oldStyleStatBuffer; 1916 int retVal = -1; 1917 1918 /* 1919 * Call each of the "stat" function in succession. A non-return 1920 * value of -1 indicates the particular function has succeeded. 1921 */ 1922 1923 Tcl_MutexLock(&obsoleteFsHookMutex); 1924 1925 if (statProcList != NULL) { 1926 StatProc *statProcPtr; 1927 char *path; 1928 Tcl_Obj *transPtr = Tcl_FSGetTranslatedPath(NULL, pathPtr); 1929 if (transPtr == NULL) { 1930 path = NULL; 1931 } else { 1932 path = Tcl_GetString(transPtr); 1933 } 1934 1935 statProcPtr = statProcList; 1936 while ((retVal == -1) && (statProcPtr != NULL)) { 1937 retVal = (*statProcPtr->proc)(path, &oldStyleStatBuffer); 1938 statProcPtr = statProcPtr->nextPtr; 1939 } 1940 if (transPtr != NULL) { 1941 Tcl_DecrRefCount(transPtr); 1942 } 1943 } 1944 1945 Tcl_MutexUnlock(&obsoleteFsHookMutex); 1946 if (retVal != -1) { 1947 /* 1948 * Note that EOVERFLOW is not a problem here, and these 1949 * assignments should all be widening (if not identity.) 1950 */ 1951 buf->st_mode = oldStyleStatBuffer.st_mode; 1952 buf->st_ino = oldStyleStatBuffer.st_ino; 1953 buf->st_dev = oldStyleStatBuffer.st_dev; 1954 buf->st_rdev = oldStyleStatBuffer.st_rdev; 1955 buf->st_nlink = oldStyleStatBuffer.st_nlink; 1956 buf->st_uid = oldStyleStatBuffer.st_uid; 1957 buf->st_gid = oldStyleStatBuffer.st_gid; 1958 buf->st_size = Tcl_LongAsWide(oldStyleStatBuffer.st_size); 1959 buf->st_atime = oldStyleStatBuffer.st_atime; 1960 buf->st_mtime = oldStyleStatBuffer.st_mtime; 1961 buf->st_ctime = oldStyleStatBuffer.st_ctime; 1962#ifdef HAVE_ST_BLOCKS 1963 buf->st_blksize = oldStyleStatBuffer.st_blksize; 1964 buf->st_blocks = Tcl_LongAsWide(oldStyleStatBuffer.st_blocks); 1965#endif 1966 return retVal; 1967 } 1968#endif /* USE_OBSOLETE_FS_HOOKS */ 1969 fsPtr = Tcl_FSGetFileSystemForPath(pathPtr); 1970 if (fsPtr != NULL) { 1971 Tcl_FSStatProc *proc = fsPtr->statProc; 1972 if (proc != NULL) { 1973 return (*proc)(pathPtr, buf); 1974 } 1975 } 1976 Tcl_SetErrno(ENOENT); 1977 return -1; 1978} 1979 1980/* 1981 *---------------------------------------------------------------------- 1982 * 1983 * Tcl_FSLstat -- 1984 * 1985 * This procedure replaces the library version of lstat. 1986 * The appropriate function for the filesystem to which pathPtr 1987 * belongs will be called. If no 'lstat' function is listed, 1988 * but a 'stat' function is, then Tcl will fall back on the 1989 * stat function. 1990 * 1991 * Results: 1992 * See lstat documentation. 1993 * 1994 * Side effects: 1995 * See lstat documentation. 1996 * 1997 *---------------------------------------------------------------------- 1998 */ 1999 2000int 2001Tcl_FSLstat(pathPtr, buf) 2002 Tcl_Obj *pathPtr; /* Path of file to stat (in current CP). */ 2003 Tcl_StatBuf *buf; /* Filled with results of stat call. */ 2004{ 2005 Tcl_Filesystem *fsPtr = Tcl_FSGetFileSystemForPath(pathPtr); 2006 if (fsPtr != NULL) { 2007 Tcl_FSLstatProc *proc = fsPtr->lstatProc; 2008 if (proc != NULL) { 2009 return (*proc)(pathPtr, buf); 2010 } else { 2011 Tcl_FSStatProc *sproc = fsPtr->statProc; 2012 if (sproc != NULL) { 2013 return (*sproc)(pathPtr, buf); 2014 } 2015 } 2016 } 2017 Tcl_SetErrno(ENOENT); 2018 return -1; 2019} 2020 2021/* 2022 *---------------------------------------------------------------------- 2023 * 2024 * Tcl_FSAccess -- 2025 * 2026 * This procedure replaces the library version of access. 2027 * The appropriate function for the filesystem to which pathPtr 2028 * belongs will be called. 2029 * 2030 * Results: 2031 * See access documentation. 2032 * 2033 * Side effects: 2034 * See access documentation. 2035 * 2036 *---------------------------------------------------------------------- 2037 */ 2038 2039int 2040Tcl_FSAccess(pathPtr, mode) 2041 Tcl_Obj *pathPtr; /* Path of file to access (in current CP). */ 2042 int mode; /* Permission setting. */ 2043{ 2044 Tcl_Filesystem *fsPtr; 2045#ifdef USE_OBSOLETE_FS_HOOKS 2046 int retVal = -1; 2047 2048 /* 2049 * Call each of the "access" function in succession. A non-return 2050 * value of -1 indicates the particular function has succeeded. 2051 */ 2052 2053 Tcl_MutexLock(&obsoleteFsHookMutex); 2054 2055 if (accessProcList != NULL) { 2056 AccessProc *accessProcPtr; 2057 char *path; 2058 Tcl_Obj *transPtr = Tcl_FSGetTranslatedPath(NULL, pathPtr); 2059 if (transPtr == NULL) { 2060 path = NULL; 2061 } else { 2062 path = Tcl_GetString(transPtr); 2063 } 2064 2065 accessProcPtr = accessProcList; 2066 while ((retVal == -1) && (accessProcPtr != NULL)) { 2067 retVal = (*accessProcPtr->proc)(path, mode); 2068 accessProcPtr = accessProcPtr->nextPtr; 2069 } 2070 if (transPtr != NULL) { 2071 Tcl_DecrRefCount(transPtr); 2072 } 2073 } 2074 2075 Tcl_MutexUnlock(&obsoleteFsHookMutex); 2076 if (retVal != -1) { 2077 return retVal; 2078 } 2079#endif /* USE_OBSOLETE_FS_HOOKS */ 2080 fsPtr = Tcl_FSGetFileSystemForPath(pathPtr); 2081 if (fsPtr != NULL) { 2082 Tcl_FSAccessProc *proc = fsPtr->accessProc; 2083 if (proc != NULL) { 2084 return (*proc)(pathPtr, mode); 2085 } 2086 } 2087 2088 Tcl_SetErrno(ENOENT); 2089 return -1; 2090} 2091 2092/* 2093 *---------------------------------------------------------------------- 2094 * 2095 * Tcl_FSOpenFileChannel -- 2096 * 2097 * The appropriate function for the filesystem to which pathPtr 2098 * belongs will be called. 2099 * 2100 * Results: 2101 * The new channel or NULL, if the named file could not be opened. 2102 * 2103 * Side effects: 2104 * May open the channel and may cause creation of a file on the 2105 * file system. 2106 * 2107 *---------------------------------------------------------------------- 2108 */ 2109 2110Tcl_Channel 2111Tcl_FSOpenFileChannel(interp, pathPtr, modeString, permissions) 2112 Tcl_Interp *interp; /* Interpreter for error reporting; 2113 * can be NULL. */ 2114 Tcl_Obj *pathPtr; /* Name of file to open. */ 2115 CONST char *modeString; /* A list of POSIX open modes or 2116 * a string such as "rw". */ 2117 int permissions; /* If the open involves creating a 2118 * file, with what modes to create 2119 * it? */ 2120{ 2121 Tcl_Filesystem *fsPtr; 2122#ifdef USE_OBSOLETE_FS_HOOKS 2123 Tcl_Channel retVal = NULL; 2124 2125 /* 2126 * Call each of the "Tcl_OpenFileChannel" functions in succession. 2127 * A non-NULL return value indicates the particular function has 2128 * succeeded. 2129 */ 2130 2131 Tcl_MutexLock(&obsoleteFsHookMutex); 2132 if (openFileChannelProcList != NULL) { 2133 OpenFileChannelProc *openFileChannelProcPtr; 2134 char *path; 2135 Tcl_Obj *transPtr = Tcl_FSGetTranslatedPath(interp, pathPtr); 2136 2137 if (transPtr == NULL) { 2138 path = NULL; 2139 } else { 2140 path = Tcl_GetString(transPtr); 2141 } 2142 2143 openFileChannelProcPtr = openFileChannelProcList; 2144 2145 while ((retVal == NULL) && (openFileChannelProcPtr != NULL)) { 2146 retVal = (*openFileChannelProcPtr->proc)(interp, path, 2147 modeString, permissions); 2148 openFileChannelProcPtr = openFileChannelProcPtr->nextPtr; 2149 } 2150 if (transPtr != NULL) { 2151 Tcl_DecrRefCount(transPtr); 2152 } 2153 } 2154 Tcl_MutexUnlock(&obsoleteFsHookMutex); 2155 if (retVal != NULL) { 2156 return retVal; 2157 } 2158#endif /* USE_OBSOLETE_FS_HOOKS */ 2159 2160 /* 2161 * We need this just to ensure we return the correct error messages 2162 * under some circumstances. 2163 */ 2164 if (Tcl_FSGetNormalizedPath(interp, pathPtr) == NULL) { 2165 return NULL; 2166 } 2167 2168 fsPtr = Tcl_FSGetFileSystemForPath(pathPtr); 2169 if (fsPtr != NULL) { 2170 Tcl_FSOpenFileChannelProc *proc = fsPtr->openFileChannelProc; 2171 if (proc != NULL) { 2172 int mode, seekFlag; 2173 mode = TclGetOpenMode(interp, modeString, &seekFlag); 2174 if (mode == -1) { 2175 return NULL; 2176 } 2177 retVal = (*proc)(interp, pathPtr, mode, permissions); 2178 if (retVal != NULL) { 2179 if (seekFlag) { 2180 if (Tcl_Seek(retVal, (Tcl_WideInt)0, 2181 SEEK_END) < (Tcl_WideInt)0) { 2182 if (interp != (Tcl_Interp *) NULL) { 2183 Tcl_AppendResult(interp, 2184 "could not seek to end of file while opening \"", 2185 Tcl_GetString(pathPtr), "\": ", 2186 Tcl_PosixError(interp), (char *) NULL); 2187 } 2188 Tcl_Close(NULL, retVal); 2189 return NULL; 2190 } 2191 } 2192 } 2193 return retVal; 2194 } 2195 } 2196 /* File doesn't belong to any filesystem that can open it */ 2197 Tcl_SetErrno(ENOENT); 2198 if (interp != NULL) { 2199 Tcl_AppendResult(interp, "couldn't open \"", 2200 Tcl_GetString(pathPtr), "\": ", 2201 Tcl_PosixError(interp), (char *) NULL); 2202 } 2203 return NULL; 2204} 2205 2206/* 2207 *---------------------------------------------------------------------- 2208 * 2209 * Tcl_FSUtime -- 2210 * 2211 * This procedure replaces the library version of utime. 2212 * The appropriate function for the filesystem to which pathPtr 2213 * belongs will be called. 2214 * 2215 * Results: 2216 * See utime documentation. 2217 * 2218 * Side effects: 2219 * See utime documentation. 2220 * 2221 *---------------------------------------------------------------------- 2222 */ 2223 2224int 2225Tcl_FSUtime (pathPtr, tval) 2226 Tcl_Obj *pathPtr; /* File to change access/modification times */ 2227 struct utimbuf *tval; /* Structure containing access/modification 2228 * times to use. Should not be modified. */ 2229{ 2230 Tcl_Filesystem *fsPtr = Tcl_FSGetFileSystemForPath(pathPtr); 2231 if (fsPtr != NULL) { 2232 Tcl_FSUtimeProc *proc = fsPtr->utimeProc; 2233 if (proc != NULL) { 2234 return (*proc)(pathPtr, tval); 2235 } 2236 } 2237 return -1; 2238} 2239 2240/* 2241 *---------------------------------------------------------------------- 2242 * 2243 * NativeFileAttrStrings -- 2244 * 2245 * This procedure implements the platform dependent 'file 2246 * attributes' subcommand, for the native filesystem, for listing 2247 * the set of possible attribute strings. This function is part 2248 * of Tcl's native filesystem support, and is placed here because 2249 * it is shared by Unix, MacOS and Windows code. 2250 * 2251 * Results: 2252 * An array of strings 2253 * 2254 * Side effects: 2255 * None. 2256 * 2257 *---------------------------------------------------------------------- 2258 */ 2259 2260static CONST char** 2261NativeFileAttrStrings(pathPtr, objPtrRef) 2262 Tcl_Obj *pathPtr; 2263 Tcl_Obj** objPtrRef; 2264{ 2265 return tclpFileAttrStrings; 2266} 2267 2268/* 2269 *---------------------------------------------------------------------- 2270 * 2271 * NativeFileAttrsGet -- 2272 * 2273 * This procedure implements the platform dependent 2274 * 'file attributes' subcommand, for the native 2275 * filesystem, for 'get' operations. This function is part 2276 * of Tcl's native filesystem support, and is placed here 2277 * because it is shared by Unix, MacOS and Windows code. 2278 * 2279 * Results: 2280 * Standard Tcl return code. The object placed in objPtrRef 2281 * (if TCL_OK was returned) is likely to have a refCount of zero. 2282 * Either way we must either store it somewhere (e.g. the Tcl 2283 * result), or Incr/Decr its refCount to ensure it is properly 2284 * freed. 2285 * 2286 * Side effects: 2287 * None. 2288 * 2289 *---------------------------------------------------------------------- 2290 */ 2291 2292static int 2293NativeFileAttrsGet(interp, index, pathPtr, objPtrRef) 2294 Tcl_Interp *interp; /* The interpreter for error reporting. */ 2295 int index; /* index of the attribute command. */ 2296 Tcl_Obj *pathPtr; /* path of file we are operating on. */ 2297 Tcl_Obj **objPtrRef; /* for output. */ 2298{ 2299 return (*tclpFileAttrProcs[index].getProc)(interp, index, 2300 pathPtr, objPtrRef); 2301} 2302 2303/* 2304 *---------------------------------------------------------------------- 2305 * 2306 * NativeFileAttrsSet -- 2307 * 2308 * This procedure implements the platform dependent 2309 * 'file attributes' subcommand, for the native 2310 * filesystem, for 'set' operations. This function is part 2311 * of Tcl's native filesystem support, and is placed here 2312 * because it is shared by Unix, MacOS and Windows code. 2313 * 2314 * Results: 2315 * Standard Tcl return code. 2316 * 2317 * Side effects: 2318 * None. 2319 * 2320 *---------------------------------------------------------------------- 2321 */ 2322 2323static int 2324NativeFileAttrsSet(interp, index, pathPtr, objPtr) 2325 Tcl_Interp *interp; /* The interpreter for error reporting. */ 2326 int index; /* index of the attribute command. */ 2327 Tcl_Obj *pathPtr; /* path of file we are operating on. */ 2328 Tcl_Obj *objPtr; /* set to this value. */ 2329{ 2330 return (*tclpFileAttrProcs[index].setProc)(interp, index, 2331 pathPtr, objPtr); 2332} 2333 2334/* 2335 *---------------------------------------------------------------------- 2336 * 2337 * Tcl_FSFileAttrStrings -- 2338 * 2339 * This procedure implements part of the hookable 'file 2340 * attributes' subcommand. The appropriate function for the 2341 * filesystem to which pathPtr belongs will be called. 2342 * 2343 * Results: 2344 * The called procedure may either return an array of strings, 2345 * or may instead return NULL and place a Tcl list into the 2346 * given objPtrRef. Tcl will take that list and first increment 2347 * its refCount before using it. On completion of that use, Tcl 2348 * will decrement its refCount. Hence if the list should be 2349 * disposed of by Tcl when done, it should have a refCount of zero, 2350 * and if the list should not be disposed of, the filesystem 2351 * should ensure it retains a refCount on the object. 2352 * 2353 * Side effects: 2354 * None. 2355 * 2356 *---------------------------------------------------------------------- 2357 */ 2358 2359CONST char ** 2360Tcl_FSFileAttrStrings(pathPtr, objPtrRef) 2361 Tcl_Obj* pathPtr; 2362 Tcl_Obj** objPtrRef; 2363{ 2364 Tcl_Filesystem *fsPtr = Tcl_FSGetFileSystemForPath(pathPtr); 2365 if (fsPtr != NULL) { 2366 Tcl_FSFileAttrStringsProc *proc = fsPtr->fileAttrStringsProc; 2367 if (proc != NULL) { 2368 return (*proc)(pathPtr, objPtrRef); 2369 } 2370 } 2371 Tcl_SetErrno(ENOENT); 2372 return NULL; 2373} 2374 2375/* 2376 *---------------------------------------------------------------------- 2377 * 2378 * Tcl_FSFileAttrsGet -- 2379 * 2380 * This procedure implements read access for the hookable 'file 2381 * attributes' subcommand. The appropriate function for the 2382 * filesystem to which pathPtr belongs will be called. 2383 * 2384 * Results: 2385 * Standard Tcl return code. The object placed in objPtrRef 2386 * (if TCL_OK was returned) is likely to have a refCount of zero. 2387 * Either way we must either store it somewhere (e.g. the Tcl 2388 * result), or Incr/Decr its refCount to ensure it is properly 2389 * freed. 2390 2391 * 2392 * Side effects: 2393 * None. 2394 * 2395 *---------------------------------------------------------------------- 2396 */ 2397 2398int 2399Tcl_FSFileAttrsGet(interp, index, pathPtr, objPtrRef) 2400 Tcl_Interp *interp; /* The interpreter for error reporting. */ 2401 int index; /* index of the attribute command. */ 2402 Tcl_Obj *pathPtr; /* filename we are operating on. */ 2403 Tcl_Obj **objPtrRef; /* for output. */ 2404{ 2405 Tcl_Filesystem *fsPtr = Tcl_FSGetFileSystemForPath(pathPtr); 2406 if (fsPtr != NULL) { 2407 Tcl_FSFileAttrsGetProc *proc = fsPtr->fileAttrsGetProc; 2408 if (proc != NULL) { 2409 return (*proc)(interp, index, pathPtr, objPtrRef); 2410 } 2411 } 2412 Tcl_SetErrno(ENOENT); 2413 return -1; 2414} 2415 2416/* 2417 *---------------------------------------------------------------------- 2418 * 2419 * Tcl_FSFileAttrsSet -- 2420 * 2421 * This procedure implements write access for the hookable 'file 2422 * attributes' subcommand. The appropriate function for the 2423 * filesystem to which pathPtr belongs will be called. 2424 * 2425 * Results: 2426 * Standard Tcl return code. 2427 * 2428 * Side effects: 2429 * None. 2430 * 2431 *---------------------------------------------------------------------- 2432 */ 2433 2434int 2435Tcl_FSFileAttrsSet(interp, index, pathPtr, objPtr) 2436 Tcl_Interp *interp; /* The interpreter for error reporting. */ 2437 int index; /* index of the attribute command. */ 2438 Tcl_Obj *pathPtr; /* filename we are operating on. */ 2439 Tcl_Obj *objPtr; /* Input value. */ 2440{ 2441 Tcl_Filesystem *fsPtr = Tcl_FSGetFileSystemForPath(pathPtr); 2442 if (fsPtr != NULL) { 2443 Tcl_FSFileAttrsSetProc *proc = fsPtr->fileAttrsSetProc; 2444 if (proc != NULL) { 2445 return (*proc)(interp, index, pathPtr, objPtr); 2446 } 2447 } 2448 Tcl_SetErrno(ENOENT); 2449 return -1; 2450} 2451 2452/* 2453 *---------------------------------------------------------------------- 2454 * 2455 * Tcl_FSGetCwd -- 2456 * 2457 * This function replaces the library version of getcwd(). 2458 * 2459 * Most VFS's will *not* implement a 'cwdProc'. Tcl now maintains 2460 * its own record (in a Tcl_Obj) of the cwd, and an attempt 2461 * is made to synchronise this with the cwd's containing filesystem, 2462 * if that filesystem provides a cwdProc (e.g. the native filesystem). 2463 * 2464 * Note that if Tcl's cwd is not in the native filesystem, then of 2465 * course Tcl's cwd and the native cwd are different: extensions 2466 * should therefore ensure they only access the cwd through this 2467 * function to avoid confusion. 2468 * 2469 * If a global cwdPathPtr already exists, it is cached in the thread's 2470 * private data structures and reference to the cached copy is returned, 2471 * subject to a synchronisation attempt in that cwdPathPtr's fs. 2472 * 2473 * Otherwise, the chain of functions that have been "inserted" 2474 * into the filesystem will be called in succession until either a 2475 * value other than NULL is returned, or the entire list is 2476 * visited. 2477 * 2478 * Results: 2479 * The result is a pointer to a Tcl_Obj specifying the current 2480 * directory, or NULL if the current directory could not be 2481 * determined. If NULL is returned, an error message is left in the 2482 * interp's result. 2483 * 2484 * The result already has its refCount incremented for the caller. 2485 * When it is no longer needed, that refCount should be decremented. 2486 * 2487 * Side effects: 2488 * Various objects may be freed and allocated. 2489 * 2490 *---------------------------------------------------------------------- 2491 */ 2492 2493Tcl_Obj* 2494Tcl_FSGetCwd(interp) 2495 Tcl_Interp *interp; 2496{ 2497 ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey); 2498 2499 if (TclFSCwdPointerEquals(NULL)) { 2500 FilesystemRecord *fsRecPtr; 2501 Tcl_Obj *retVal = NULL; 2502 2503 /* 2504 * We've never been called before, try to find a cwd. Call 2505 * each of the "Tcl_GetCwd" function in succession. A non-NULL 2506 * return value indicates the particular function has 2507 * succeeded. 2508 */ 2509 2510 fsRecPtr = FsGetFirstFilesystem(); 2511 while ((retVal == NULL) && (fsRecPtr != NULL)) { 2512 Tcl_FSGetCwdProc *proc = fsRecPtr->fsPtr->getCwdProc; 2513 if (proc != NULL) { 2514 retVal = (*proc)(interp); 2515 } 2516 fsRecPtr = fsRecPtr->nextPtr; 2517 } 2518 /* 2519 * Now the 'cwd' may NOT be normalized, at least on some 2520 * platforms. For the sake of efficiency, we want a completely 2521 * normalized cwd at all times. 2522 * 2523 * Finally, if retVal is NULL, we do not have a cwd, which 2524 * could be problematic. 2525 */ 2526 if (retVal != NULL) { 2527 Tcl_Obj *norm = TclFSNormalizeAbsolutePath(interp, retVal, NULL); 2528 if (norm != NULL) { 2529 /* 2530 * We found a cwd, which is now in our global storage. 2531 * We must make a copy. Norm already has a refCount of 1. 2532 * 2533 * Threading issue: note that multiple threads at system 2534 * startup could in principle call this procedure 2535 * simultaneously. They will therefore each set the 2536 * cwdPathPtr independently. That behaviour is a bit 2537 * peculiar, but should be fine. Once we have a cwd, 2538 * we'll always be in the 'else' branch below which 2539 * is simpler. 2540 */ 2541 FsUpdateCwd(norm); 2542 Tcl_DecrRefCount(norm); 2543 } 2544 Tcl_DecrRefCount(retVal); 2545 } 2546 } else { 2547 /* 2548 * We already have a cwd cached, but we want to give the 2549 * filesystem it is in a chance to check whether that cwd 2550 * has changed, or is perhaps no longer accessible. This 2551 * allows an error to be thrown if, say, the permissions on 2552 * that directory have changed. 2553 */ 2554 Tcl_Filesystem *fsPtr = Tcl_FSGetFileSystemForPath(tsdPtr->cwdPathPtr); 2555 /* 2556 * If the filesystem couldn't be found, or if no cwd function 2557 * exists for this filesystem, then we simply assume the cached 2558 * cwd is ok. If we do call a cwd, we must watch for errors 2559 * (if the cwd returns NULL). This ensures that, say, on Unix 2560 * if the permissions of the cwd change, 'pwd' does actually 2561 * throw the correct error in Tcl. (This is tested for in the 2562 * test suite on unix). 2563 */ 2564 if (fsPtr != NULL) { 2565 Tcl_FSGetCwdProc *proc = fsPtr->getCwdProc; 2566 if (proc != NULL) { 2567 Tcl_Obj *retVal = (*proc)(interp); 2568 if (retVal != NULL) { 2569 Tcl_Obj *norm = TclFSNormalizeAbsolutePath(interp, retVal, NULL); 2570 /* 2571 * Check whether cwd has changed from the value 2572 * previously stored in cwdPathPtr. Really 'norm' 2573 * shouldn't be null, but we are careful. 2574 */ 2575 if (norm == NULL) { 2576 /* Do nothing */ 2577 } else if (Tcl_FSEqualPaths(tsdPtr->cwdPathPtr, norm)) { 2578 /* 2579 * If the paths were equal, we can be more 2580 * efficient and retain the old path object 2581 * which will probably already be shared. In 2582 * this case we can simply free the normalized 2583 * path we just calculated. 2584 */ 2585 Tcl_DecrRefCount(norm); 2586 } else { 2587 FsUpdateCwd(norm); 2588 Tcl_DecrRefCount(norm); 2589 } 2590 Tcl_DecrRefCount(retVal); 2591 } else { 2592 /* The 'cwd' function returned an error; reset the cwd */ 2593 FsUpdateCwd(NULL); 2594 } 2595 } 2596 } 2597 } 2598 2599 if (tsdPtr->cwdPathPtr != NULL) { 2600 Tcl_IncrRefCount(tsdPtr->cwdPathPtr); 2601 } 2602 2603 return tsdPtr->cwdPathPtr; 2604} 2605 2606/* 2607 *---------------------------------------------------------------------- 2608 * 2609 * Tcl_FSChdir -- 2610 * 2611 * This function replaces the library version of chdir(). 2612 * 2613 * The path is normalized and then passed to the filesystem 2614 * which claims it. 2615 * 2616 * Results: 2617 * See chdir() documentation. If successful, we keep a 2618 * record of the successful path in cwdPathPtr for subsequent 2619 * calls to getcwd. 2620 * 2621 * Side effects: 2622 * See chdir() documentation. The global cwdPathPtr may 2623 * change value. 2624 * 2625 *---------------------------------------------------------------------- 2626 */ 2627int 2628Tcl_FSChdir(pathPtr) 2629 Tcl_Obj *pathPtr; 2630{ 2631 Tcl_Filesystem *fsPtr; 2632 int retVal = -1; 2633 2634#ifdef WIN32 2635 /* 2636 * This complete hack addresses the bug tested in winFCmd-16.12, 2637 * where having your HOME as "C:" (IOW, a seemingly path relative 2638 * dir) would cause a crash when you cd'd to it and requested 'pwd'. 2639 * The work-around is to force such a dir into an absolute path by 2640 * tacking on '/'. 2641 * 2642 * We check for '~' specifically because that's what Tcl_CdObjCmd 2643 * passes in that triggers the bug. A direct 'cd C:' call will not 2644 * because that gets the volumerelative pwd. 2645 * 2646 * This is not an issue for 8.5 as that has a more elaborate change 2647 * that requires the use of TCL_FILESYSTEM_VERSION_2. 2648 */ 2649 Tcl_Obj *objPtr = NULL; 2650 if (pathPtr->bytes && pathPtr->length == 1 && pathPtr->bytes[0] == '~') { 2651 int len; 2652 char *str; 2653 2654 objPtr = Tcl_FSGetTranslatedPath(NULL, pathPtr); 2655 if (objPtr == NULL) { 2656 Tcl_SetErrno(ENOENT); 2657 return -1; 2658 } 2659 Tcl_IncrRefCount(objPtr); 2660 str = Tcl_GetStringFromObj(objPtr, &len); 2661 if (len == 2 && str[1] == ':') { 2662 pathPtr = Tcl_NewStringObj(str, len); 2663 Tcl_AppendToObj(pathPtr, "/", 1); 2664 Tcl_IncrRefCount(pathPtr); 2665 Tcl_DecrRefCount(objPtr); 2666 objPtr = pathPtr; 2667 } else { 2668 Tcl_DecrRefCount(objPtr); 2669 objPtr = NULL; 2670 } 2671 } 2672#endif 2673 if (Tcl_FSGetNormalizedPath(NULL, pathPtr) == NULL) { 2674#ifdef WIN32 2675 if (objPtr) { Tcl_DecrRefCount(objPtr); } 2676#endif 2677 Tcl_SetErrno(ENOENT); 2678 return -1; 2679 } 2680 2681 fsPtr = Tcl_FSGetFileSystemForPath(pathPtr); 2682 if (fsPtr != NULL) { 2683 Tcl_FSChdirProc *proc = fsPtr->chdirProc; 2684 if (proc != NULL) { 2685 retVal = (*proc)(pathPtr); 2686 } else { 2687 /* Fallback on stat-based implementation */ 2688 Tcl_StatBuf buf; 2689 /* If the file can be stat'ed and is a directory and 2690 * is readable, then we can chdir. */ 2691 if ((Tcl_FSStat(pathPtr, &buf) == 0) 2692 && (S_ISDIR(buf.st_mode)) 2693 && (Tcl_FSAccess(pathPtr, R_OK) == 0)) { 2694 /* We allow the chdir */ 2695 retVal = 0; 2696 } 2697 } 2698 } 2699 2700 if (retVal != -1) { 2701 /* 2702 * The cwd changed, or an error was thrown. If an error was 2703 * thrown, we can just continue (and that will report the error 2704 * to the user). If there was no error we must assume that the 2705 * cwd was actually changed to the normalized value we 2706 * calculated above, and we must therefore cache that 2707 * information. 2708 */ 2709 if (retVal == 0) { 2710 /* 2711 * Note that this normalized path may be different to what 2712 * we found above (or at least a different object), if the 2713 * filesystem epoch changed recently. This can actually 2714 * happen with scripted documents very easily. Therefore 2715 * we ask for the normalized path again (the correct value 2716 * will have been cached as a result of the 2717 * Tcl_FSGetFileSystemForPath call above anyway). 2718 */ 2719 Tcl_Obj *normDirName = Tcl_FSGetNormalizedPath(NULL, pathPtr); 2720 if (normDirName == NULL) { 2721#ifdef WIN32 2722 if (objPtr) { Tcl_DecrRefCount(objPtr); } 2723#endif 2724 Tcl_SetErrno(ENOENT); 2725 return -1; 2726 } 2727 FsUpdateCwd(normDirName); 2728 } 2729 } else { 2730 Tcl_SetErrno(ENOENT); 2731 } 2732 2733#ifdef WIN32 2734 if (objPtr) { Tcl_DecrRefCount(objPtr); } 2735#endif 2736 return (retVal); 2737} 2738 2739/* 2740 *---------------------------------------------------------------------- 2741 * 2742 * Tcl_FSLoadFile -- 2743 * 2744 * Dynamically loads a binary code file into memory and returns 2745 * the addresses of two procedures within that file, if they are 2746 * defined. The appropriate function for the filesystem to which 2747 * pathPtr belongs will be called. 2748 * 2749 * Note that the native filesystem doesn't actually assume 2750 * 'pathPtr' is a path. Rather it assumes filename is either 2751 * a path or just the name of a file which can be found somewhere 2752 * in the environment's loadable path. This behaviour is not 2753 * very compatible with virtual filesystems (and has other problems 2754 * documented in the load man-page), so it is advised that full 2755 * paths are always used. 2756 * 2757 * Results: 2758 * A standard Tcl completion code. If an error occurs, an error 2759 * message is left in the interp's result. 2760 * 2761 * Side effects: 2762 * New code suddenly appears in memory. This may later be 2763 * unloaded by passing the clientData to the unloadProc. 2764 * 2765 *---------------------------------------------------------------------- 2766 */ 2767 2768int 2769Tcl_FSLoadFile(interp, pathPtr, sym1, sym2, proc1Ptr, proc2Ptr, 2770 handlePtr, unloadProcPtr) 2771 Tcl_Interp *interp; /* Used for error reporting. */ 2772 Tcl_Obj *pathPtr; /* Name of the file containing the desired 2773 * code. */ 2774 CONST char *sym1, *sym2; /* Names of two procedures to look up in 2775 * the file's symbol table. */ 2776 Tcl_PackageInitProc **proc1Ptr, **proc2Ptr; 2777 /* Where to return the addresses corresponding 2778 * to sym1 and sym2. */ 2779 Tcl_LoadHandle *handlePtr; /* Filled with token for dynamically loaded 2780 * file which will be passed back to 2781 * (*unloadProcPtr)() to unload the file. */ 2782 Tcl_FSUnloadFileProc **unloadProcPtr; 2783 /* Filled with address of Tcl_FSUnloadFileProc 2784 * function which should be used for 2785 * this file. */ 2786{ 2787 Tcl_Filesystem *fsPtr = Tcl_FSGetFileSystemForPath(pathPtr); 2788 if (fsPtr != NULL) { 2789 Tcl_FSLoadFileProc *proc = fsPtr->loadFileProc; 2790 if (proc != NULL) { 2791 int retVal = (*proc)(interp, pathPtr, handlePtr, unloadProcPtr); 2792 if (retVal != TCL_OK) { 2793 return retVal; 2794 } 2795 if (*handlePtr == NULL) { 2796 return TCL_ERROR; 2797 } 2798 if (sym1 != NULL) { 2799 *proc1Ptr = TclpFindSymbol(interp, *handlePtr, sym1); 2800 } 2801 if (sym2 != NULL) { 2802 *proc2Ptr = TclpFindSymbol(interp, *handlePtr, sym2); 2803 } 2804 return retVal; 2805 } else { 2806 Tcl_Filesystem *copyFsPtr; 2807 Tcl_Obj *copyToPtr; 2808 2809 /* First check if it is readable -- and exists! */ 2810 if (Tcl_FSAccess(pathPtr, R_OK) != 0) { 2811 Tcl_AppendResult(interp, "couldn't load library \"", 2812 Tcl_GetString(pathPtr), "\": ", 2813 Tcl_PosixError(interp), (char *) NULL); 2814 return TCL_ERROR; 2815 } 2816 2817#ifdef TCL_LOAD_FROM_MEMORY 2818 /* 2819 * The platform supports loading code from memory, so ask for a 2820 * buffer of the appropriate size, read the file into it and 2821 * load the code from the buffer: 2822 */ 2823 do { 2824 int ret, size; 2825 void *buffer; 2826 Tcl_StatBuf statBuf; 2827 Tcl_Channel data; 2828 2829 ret = Tcl_FSStat(pathPtr, &statBuf); 2830 if (ret < 0) { 2831 break; 2832 } 2833 size = (int) statBuf.st_size; 2834 /* Tcl_Read takes an int: check that file size isn't wide */ 2835 if (size != (Tcl_WideInt)statBuf.st_size) { 2836 break; 2837 } 2838 data = Tcl_FSOpenFileChannel(interp, pathPtr, "r", 0666); 2839 if (!data) { 2840 break; 2841 } 2842 buffer = TclpLoadMemoryGetBuffer(interp, size); 2843 if (!buffer) { 2844 Tcl_Close(interp, data); 2845 break; 2846 } 2847 Tcl_SetChannelOption(interp, data, "-translation", "binary"); 2848 ret = Tcl_Read(data, buffer, size); 2849 Tcl_Close(interp, data); 2850 ret = TclpLoadMemory(interp, buffer, size, ret, handlePtr, unloadProcPtr); 2851 if (ret == TCL_OK) { 2852 if (*handlePtr == NULL) { 2853 break; 2854 } 2855 if (sym1 != NULL) { 2856 *proc1Ptr = TclpFindSymbol(interp, *handlePtr, sym1); 2857 } 2858 if (sym2 != NULL) { 2859 *proc2Ptr = TclpFindSymbol(interp, *handlePtr, sym2); 2860 } 2861 return TCL_OK; 2862 } 2863 } while (0); 2864 Tcl_ResetResult(interp); 2865#endif 2866 2867 /* 2868 * Get a temporary filename to use, first to 2869 * copy the file into, and then to load. 2870 */ 2871 copyToPtr = TclpTempFileName(); 2872 if (copyToPtr == NULL) { 2873 return -1; 2874 } 2875 Tcl_IncrRefCount(copyToPtr); 2876 2877 copyFsPtr = Tcl_FSGetFileSystemForPath(copyToPtr); 2878 if ((copyFsPtr == NULL) || (copyFsPtr == fsPtr)) { 2879 /* 2880 * We already know we can't use Tcl_FSLoadFile from 2881 * this filesystem, and we must avoid a possible 2882 * infinite loop. Try to delete the file we 2883 * probably created, and then exit. 2884 */ 2885 Tcl_FSDeleteFile(copyToPtr); 2886 Tcl_DecrRefCount(copyToPtr); 2887 return -1; 2888 } 2889 2890 if (TclCrossFilesystemCopy(interp, pathPtr, 2891 copyToPtr) == TCL_OK) { 2892 Tcl_LoadHandle newLoadHandle = NULL; 2893 Tcl_FSUnloadFileProc *newUnloadProcPtr = NULL; 2894 FsDivertLoad *tvdlPtr; 2895 int retVal; 2896 2897#if !defined(__WIN32__) && !defined(MAC_TCL) 2898 /* 2899 * Do we need to set appropriate permissions 2900 * on the file? This may be required on some 2901 * systems. On Unix we could loop over 2902 * the file attributes, and set any that are 2903 * called "-permissions" to 0700. However, 2904 * we just do this directly, like this: 2905 */ 2906 2907 Tcl_Obj* perm = Tcl_NewStringObj("0700",-1); 2908 Tcl_IncrRefCount(perm); 2909 Tcl_FSFileAttrsSet(NULL, 2, copyToPtr, perm); 2910 Tcl_DecrRefCount(perm); 2911#endif 2912 2913 /* 2914 * We need to reset the result now, because the cross- 2915 * filesystem copy may have stored the number of bytes 2916 * in the result 2917 */ 2918 Tcl_ResetResult(interp); 2919 2920 retVal = Tcl_FSLoadFile(interp, copyToPtr, sym1, sym2, 2921 proc1Ptr, proc2Ptr, 2922 &newLoadHandle, 2923 &newUnloadProcPtr); 2924 if (retVal != TCL_OK) { 2925 /* The file didn't load successfully */ 2926 Tcl_FSDeleteFile(copyToPtr); 2927 Tcl_DecrRefCount(copyToPtr); 2928 return retVal; 2929 } 2930 /* 2931 * Try to delete the file immediately -- this is 2932 * possible in some OSes, and avoids any worries 2933 * about leaving the copy laying around on exit. 2934 */ 2935 if (Tcl_FSDeleteFile(copyToPtr) == TCL_OK) { 2936 Tcl_DecrRefCount(copyToPtr); 2937 /* 2938 * We tell our caller about the real shared 2939 * library which was loaded. Note that this 2940 * does mean that the package list maintained 2941 * by 'load' will store the original (vfs) 2942 * path alongside the temporary load handle 2943 * and unload proc ptr. 2944 */ 2945 (*handlePtr) = newLoadHandle; 2946 (*unloadProcPtr) = newUnloadProcPtr; 2947 return TCL_OK; 2948 } 2949 /* 2950 * When we unload this file, we need to divert the 2951 * unloading so we can unload and cleanup the 2952 * temporary file correctly. 2953 */ 2954 tvdlPtr = (FsDivertLoad*) ckalloc(sizeof(FsDivertLoad)); 2955 2956 /* 2957 * Remember three pieces of information. This allows 2958 * us to cleanup the diverted load completely, on 2959 * platforms which allow proper unloading of code. 2960 */ 2961 tvdlPtr->loadHandle = newLoadHandle; 2962 tvdlPtr->unloadProcPtr = newUnloadProcPtr; 2963 2964 if (copyFsPtr != &tclNativeFilesystem) { 2965 /* copyToPtr is already incremented for this reference */ 2966 tvdlPtr->divertedFile = copyToPtr; 2967 2968 /* 2969 * This is the filesystem we loaded it into. Since 2970 * we have a reference to 'copyToPtr', we already 2971 * have a refCount on this filesystem, so we don't 2972 * need to worry about it disappearing on us. 2973 */ 2974 tvdlPtr->divertedFilesystem = copyFsPtr; 2975 tvdlPtr->divertedFileNativeRep = NULL; 2976 } else { 2977 /* We need the native rep */ 2978 tvdlPtr->divertedFileNativeRep = 2979 TclNativeDupInternalRep(Tcl_FSGetInternalRep(copyToPtr, 2980 copyFsPtr)); 2981 /* 2982 * We don't need or want references to the copied 2983 * Tcl_Obj or the filesystem if it is the native 2984 * one. 2985 */ 2986 tvdlPtr->divertedFile = NULL; 2987 tvdlPtr->divertedFilesystem = NULL; 2988 Tcl_DecrRefCount(copyToPtr); 2989 } 2990 2991 copyToPtr = NULL; 2992 (*handlePtr) = (Tcl_LoadHandle) tvdlPtr; 2993 (*unloadProcPtr) = &FSUnloadTempFile; 2994 return retVal; 2995 } else { 2996 /* Cross-platform copy failed */ 2997 Tcl_FSDeleteFile(copyToPtr); 2998 Tcl_DecrRefCount(copyToPtr); 2999 return TCL_ERROR; 3000 } 3001 } 3002 } 3003 Tcl_SetErrno(ENOENT); 3004 return -1; 3005} 3006/* 3007 * This function used to be in the platform specific directories, but it 3008 * has now been made to work cross-platform 3009 */ 3010int 3011TclpLoadFile(interp, pathPtr, sym1, sym2, proc1Ptr, proc2Ptr, 3012 clientDataPtr, unloadProcPtr) 3013 Tcl_Interp *interp; /* Used for error reporting. */ 3014 Tcl_Obj *pathPtr; /* Name of the file containing the desired 3015 * code (UTF-8). */ 3016 CONST char *sym1, *sym2; /* Names of two procedures to look up in 3017 * the file's symbol table. */ 3018 Tcl_PackageInitProc **proc1Ptr, **proc2Ptr; 3019 /* Where to return the addresses corresponding 3020 * to sym1 and sym2. */ 3021 ClientData *clientDataPtr; /* Filled with token for dynamically loaded 3022 * file which will be passed back to 3023 * (*unloadProcPtr)() to unload the file. */ 3024 Tcl_FSUnloadFileProc **unloadProcPtr; 3025 /* Filled with address of Tcl_FSUnloadFileProc 3026 * function which should be used for 3027 * this file. */ 3028{ 3029 Tcl_LoadHandle handle = NULL; 3030 int res; 3031 3032 res = TclpDlopen(interp, pathPtr, &handle, unloadProcPtr); 3033 3034 if (res != TCL_OK) { 3035 return res; 3036 } 3037 3038 if (handle == NULL) { 3039 return TCL_ERROR; 3040 } 3041 3042 *clientDataPtr = (ClientData)handle; 3043 3044 *proc1Ptr = TclpFindSymbol(interp, handle, sym1); 3045 *proc2Ptr = TclpFindSymbol(interp, handle, sym2); 3046 return TCL_OK; 3047} 3048 3049/* 3050 *--------------------------------------------------------------------------- 3051 * 3052 * FSUnloadTempFile -- 3053 * 3054 * This function is called when we loaded a library of code via 3055 * an intermediate temporary file. This function ensures 3056 * the library is correctly unloaded and the temporary file 3057 * is correctly deleted. 3058 * 3059 * Results: 3060 * None. 3061 * 3062 * Side effects: 3063 * The effects of the 'unload' function called, and of course 3064 * the temporary file will be deleted. 3065 * 3066 *--------------------------------------------------------------------------- 3067 */ 3068static void 3069FSUnloadTempFile(loadHandle) 3070 Tcl_LoadHandle loadHandle; /* loadHandle returned by a previous call 3071 * to Tcl_FSLoadFile(). The loadHandle is 3072 * a token that represents the loaded 3073 * file. */ 3074{ 3075 FsDivertLoad *tvdlPtr = (FsDivertLoad*)loadHandle; 3076 /* 3077 * This test should never trigger, since we give 3078 * the client data in the function above. 3079 */ 3080 if (tvdlPtr == NULL) { return; } 3081 3082 /* 3083 * Call the real 'unloadfile' proc we actually used. It is very 3084 * important that we call this first, so that the shared library 3085 * is actually unloaded by the OS. Otherwise, the following 3086 * 'delete' may well fail because the shared library is still in 3087 * use. 3088 */ 3089 if (tvdlPtr->unloadProcPtr != NULL) { 3090 (*tvdlPtr->unloadProcPtr)(tvdlPtr->loadHandle); 3091 } 3092 3093 if (tvdlPtr->divertedFilesystem == NULL) { 3094 /* 3095 * It was the native filesystem, and we have a special 3096 * function available just for this purpose, which we 3097 * know works even at this late stage. 3098 */ 3099 TclpDeleteFile(tvdlPtr->divertedFileNativeRep); 3100 NativeFreeInternalRep(tvdlPtr->divertedFileNativeRep); 3101 } else { 3102 /* 3103 * Remove the temporary file we created. Note, we may crash 3104 * here because encodings have been taken down already. 3105 */ 3106 if (tvdlPtr->divertedFilesystem->deleteFileProc(tvdlPtr->divertedFile) 3107 != TCL_OK) { 3108 /* 3109 * The above may have failed because the filesystem, or something 3110 * it depends upon (e.g. encodings) have been taken down because 3111 * Tcl is exiting. 3112 * 3113 * We may need to work out how to delete this file more 3114 * robustly (or give the filesystem the information it needs 3115 * to delete the file more robustly). 3116 * 3117 * In particular, one problem might be that the filesystem 3118 * cannot extract the information it needs from the above 3119 * path object because Tcl's entire filesystem apparatus 3120 * (the code in this file) has been finalized, and it 3121 * refuses to pass the internal representation to the 3122 * filesystem. 3123 */ 3124 } 3125 3126 /* 3127 * And free up the allocations. This will also of course remove 3128 * a refCount from the Tcl_Filesystem to which this file belongs, 3129 * which could then free up the filesystem if we are exiting. 3130 */ 3131 Tcl_DecrRefCount(tvdlPtr->divertedFile); 3132 } 3133 3134 ckfree((char*)tvdlPtr); 3135} 3136 3137/* 3138 *--------------------------------------------------------------------------- 3139 * 3140 * Tcl_FSLink -- 3141 * 3142 * This function replaces the library version of readlink() and 3143 * can also be used to make links. The appropriate function for 3144 * the filesystem to which pathPtr belongs will be called. 3145 * 3146 * Results: 3147 * If toPtr is NULL, then the result is a Tcl_Obj specifying the 3148 * contents of the symbolic link given by 'pathPtr', or NULL if 3149 * the symbolic link could not be read. The result is owned by 3150 * the caller, which should call Tcl_DecrRefCount when the result 3151 * is no longer needed. 3152 * 3153 * If toPtr is non-NULL, then the result is toPtr if the link action 3154 * was successful, or NULL if not. In this case the result has no 3155 * additional reference count, and need not be freed. The actual 3156 * action to perform is given by the 'linkAction' flags, which is 3157 * an or'd combination of: 3158 * 3159 * TCL_CREATE_SYMBOLIC_LINK 3160 * TCL_CREATE_HARD_LINK 3161 * 3162 * Note that most filesystems will not support linking across 3163 * to different filesystems, so this function will usually 3164 * fail unless toPtr is in the same FS as pathPtr. 3165 * 3166 * Side effects: 3167 * See readlink() documentation. A new filesystem link 3168 * object may appear 3169 * 3170 *--------------------------------------------------------------------------- 3171 */ 3172 3173Tcl_Obj * 3174Tcl_FSLink(pathPtr, toPtr, linkAction) 3175 Tcl_Obj *pathPtr; /* Path of file to readlink or link */ 3176 Tcl_Obj *toPtr; /* NULL or path to be linked to */ 3177 int linkAction; /* Action to perform */ 3178{ 3179 Tcl_Filesystem *fsPtr = Tcl_FSGetFileSystemForPath(pathPtr); 3180 if (fsPtr != NULL) { 3181 Tcl_FSLinkProc *proc = fsPtr->linkProc; 3182 if (proc != NULL) { 3183 return (*proc)(pathPtr, toPtr, linkAction); 3184 } 3185 } 3186 /* 3187 * If S_IFLNK isn't defined it means that the machine doesn't 3188 * support symbolic links, so the file can't possibly be a 3189 * symbolic link. Generate an EINVAL error, which is what 3190 * happens on machines that do support symbolic links when 3191 * you invoke readlink on a file that isn't a symbolic link. 3192 */ 3193#ifndef S_IFLNK 3194 errno = EINVAL; 3195#else 3196 Tcl_SetErrno(ENOENT); 3197#endif /* S_IFLNK */ 3198 return NULL; 3199} 3200 3201/* 3202 *--------------------------------------------------------------------------- 3203 * 3204 * Tcl_FSListVolumes -- 3205 * 3206 * Lists the currently mounted volumes. The chain of functions 3207 * that have been "inserted" into the filesystem will be called in 3208 * succession; each may return a list of volumes, all of which are 3209 * added to the result until all mounted file systems are listed. 3210 * 3211 * Notice that we assume the lists returned by each filesystem 3212 * (if non NULL) have been given a refCount for us already. 3213 * However, we are NOT allowed to hang on to the list itself 3214 * (it belongs to the filesystem we called). Therefore we 3215 * quite naturally add its contents to the result we are 3216 * building, and then decrement the refCount. 3217 * 3218 * Results: 3219 * The list of volumes, in an object which has refCount 0. 3220 * 3221 * Side effects: 3222 * None 3223 * 3224 *--------------------------------------------------------------------------- 3225 */ 3226 3227Tcl_Obj* 3228Tcl_FSListVolumes(void) 3229{ 3230 FilesystemRecord *fsRecPtr; 3231 Tcl_Obj *resultPtr = Tcl_NewObj(); 3232 3233 /* 3234 * Call each of the "listVolumes" function in succession. 3235 * A non-NULL return value indicates the particular function has 3236 * succeeded. We call all the functions registered, since we want 3237 * a list of all drives from all filesystems. 3238 */ 3239 3240 fsRecPtr = FsGetFirstFilesystem(); 3241 while (fsRecPtr != NULL) { 3242 Tcl_FSListVolumesProc *proc = fsRecPtr->fsPtr->listVolumesProc; 3243 if (proc != NULL) { 3244 Tcl_Obj *thisFsVolumes = (*proc)(); 3245 if (thisFsVolumes != NULL) { 3246 Tcl_ListObjAppendList(NULL, resultPtr, thisFsVolumes); 3247 Tcl_DecrRefCount(thisFsVolumes); 3248 } 3249 } 3250 fsRecPtr = fsRecPtr->nextPtr; 3251 } 3252 3253 return resultPtr; 3254} 3255 3256/* 3257 *--------------------------------------------------------------------------- 3258 * 3259 * FsListMounts -- 3260 * 3261 * List all mounts within the given directory, which match the 3262 * given pattern. 3263 * 3264 * Results: 3265 * The list of mounts, in a list object which has refCount 0, or 3266 * NULL if we didn't even find any filesystems to try to list 3267 * mounts. 3268 * 3269 * Side effects: 3270 * None 3271 * 3272 *--------------------------------------------------------------------------- 3273 */ 3274 3275static Tcl_Obj* 3276FsListMounts(pathPtr, pattern) 3277 Tcl_Obj *pathPtr; /* Contains path to directory to search. */ 3278 CONST char *pattern; /* Pattern to match against. */ 3279{ 3280 FilesystemRecord *fsRecPtr; 3281 Tcl_GlobTypeData mountsOnly = { TCL_GLOB_TYPE_MOUNT, 0, NULL, NULL }; 3282 Tcl_Obj *resultPtr = NULL; 3283 3284 /* 3285 * Call each of the "listMounts" functions in succession. 3286 * A non-NULL return value indicates the particular function has 3287 * succeeded. We call all the functions registered, since we want 3288 * a list from each filesystems. 3289 */ 3290 3291 fsRecPtr = FsGetFirstFilesystem(); 3292 while (fsRecPtr != NULL) { 3293 if (fsRecPtr->fsPtr != &tclNativeFilesystem) { 3294 Tcl_FSMatchInDirectoryProc *proc = 3295 fsRecPtr->fsPtr->matchInDirectoryProc; 3296 if (proc != NULL) { 3297 if (resultPtr == NULL) { 3298 resultPtr = Tcl_NewObj(); 3299 } 3300 (*proc)(NULL, resultPtr, pathPtr, pattern, &mountsOnly); 3301 } 3302 } 3303 fsRecPtr = fsRecPtr->nextPtr; 3304 } 3305 3306 return resultPtr; 3307} 3308 3309/* 3310 *--------------------------------------------------------------------------- 3311 * 3312 * Tcl_FSSplitPath -- 3313 * 3314 * This function takes the given Tcl_Obj, which should be a valid 3315 * path, and returns a Tcl List object containing each segment of 3316 * that path as an element. 3317 * 3318 * Results: 3319 * Returns list object with refCount of zero. If the passed in 3320 * lenPtr is non-NULL, we use it to return the number of elements 3321 * in the returned list. 3322 * 3323 * Side effects: 3324 * None. 3325 * 3326 *--------------------------------------------------------------------------- 3327 */ 3328 3329Tcl_Obj* 3330Tcl_FSSplitPath(pathPtr, lenPtr) 3331 Tcl_Obj *pathPtr; /* Path to split. */ 3332 int *lenPtr; /* int to store number of path elements. */ 3333{ 3334 Tcl_Obj *result = NULL; /* Needed only to prevent gcc warnings. */ 3335 Tcl_Filesystem *fsPtr; 3336 char separator = '/'; 3337 int driveNameLength; 3338 char *p; 3339 3340 /* 3341 * Perform platform specific splitting. 3342 */ 3343 3344 if (FSGetPathType(pathPtr, &fsPtr, &driveNameLength) 3345 == TCL_PATH_ABSOLUTE) { 3346 if (fsPtr == &tclNativeFilesystem) { 3347 return TclpNativeSplitPath(pathPtr, lenPtr); 3348 } 3349 } else { 3350 return TclpNativeSplitPath(pathPtr, lenPtr); 3351 } 3352 3353 /* We assume separators are single characters */ 3354 if (fsPtr->filesystemSeparatorProc != NULL) { 3355 Tcl_Obj *sep = (*fsPtr->filesystemSeparatorProc)(pathPtr); 3356 if (sep != NULL) { 3357 separator = Tcl_GetString(sep)[0]; 3358 } 3359 } 3360 3361 /* 3362 * Place the drive name as first element of the 3363 * result list. The drive name may contain strange 3364 * characters, like colons and multiple forward slashes 3365 * (for example 'ftp://' is a valid vfs drive name) 3366 */ 3367 result = Tcl_NewObj(); 3368 p = Tcl_GetString(pathPtr); 3369 Tcl_ListObjAppendElement(NULL, result, 3370 Tcl_NewStringObj(p, driveNameLength)); 3371 p+= driveNameLength; 3372 3373 /* Add the remaining path elements to the list */ 3374 for (;;) { 3375 char *elementStart = p; 3376 int length; 3377 while ((*p != '\0') && (*p != separator)) { 3378 p++; 3379 } 3380 length = p - elementStart; 3381 if (length > 0) { 3382 Tcl_Obj *nextElt; 3383 if (elementStart[0] == '~') { 3384 nextElt = Tcl_NewStringObj("./",2); 3385 Tcl_AppendToObj(nextElt, elementStart, length); 3386 } else { 3387 nextElt = Tcl_NewStringObj(elementStart, length); 3388 } 3389 Tcl_ListObjAppendElement(NULL, result, nextElt); 3390 } 3391 if (*p++ == '\0') { 3392 break; 3393 } 3394 } 3395 3396 /* 3397 * Compute the number of elements in the result. 3398 */ 3399 3400 if (lenPtr != NULL) { 3401 Tcl_ListObjLength(NULL, result, lenPtr); 3402 } 3403 return result; 3404} 3405 3406/* Simple helper function */ 3407Tcl_Obj* 3408TclFSInternalToNormalized(fromFilesystem, clientData, fsRecPtrPtr) 3409 Tcl_Filesystem *fromFilesystem; 3410 ClientData clientData; 3411 FilesystemRecord **fsRecPtrPtr; 3412{ 3413 FilesystemRecord *fsRecPtr = FsGetFirstFilesystem(); 3414 3415 while (fsRecPtr != NULL) { 3416 if (fsRecPtr->fsPtr == fromFilesystem) { 3417 *fsRecPtrPtr = fsRecPtr; 3418 break; 3419 } 3420 fsRecPtr = fsRecPtr->nextPtr; 3421 } 3422 3423 if ((fsRecPtr != NULL) 3424 && (fromFilesystem->internalToNormalizedProc != NULL)) { 3425 return (*fromFilesystem->internalToNormalizedProc)(clientData); 3426 } else { 3427 return NULL; 3428 } 3429} 3430 3431/* 3432 *---------------------------------------------------------------------- 3433 * 3434 * GetPathType -- 3435 * 3436 * Helper function used by FSGetPathType. 3437 * 3438 * Results: 3439 * Returns one of TCL_PATH_ABSOLUTE, TCL_PATH_RELATIVE, or 3440 * TCL_PATH_VOLUME_RELATIVE. The filesystem reference will 3441 * be set if and only if it is non-NULL and the function's 3442 * return value is TCL_PATH_ABSOLUTE. 3443 * 3444 * Side effects: 3445 * None. 3446 * 3447 *---------------------------------------------------------------------- 3448 */ 3449 3450static Tcl_PathType 3451GetPathType(pathObjPtr, filesystemPtrPtr, driveNameLengthPtr, driveNameRef) 3452 Tcl_Obj *pathObjPtr; 3453 Tcl_Filesystem **filesystemPtrPtr; 3454 int *driveNameLengthPtr; 3455 Tcl_Obj **driveNameRef; 3456{ 3457 FilesystemRecord *fsRecPtr; 3458 int pathLen; 3459 char *path; 3460 Tcl_PathType type = TCL_PATH_RELATIVE; 3461 3462 path = Tcl_GetStringFromObj(pathObjPtr, &pathLen); 3463 3464 /* 3465 * Call each of the "listVolumes" function in succession, checking 3466 * whether the given path is an absolute path on any of the volumes 3467 * returned (this is done by checking whether the path's prefix 3468 * matches). 3469 */ 3470 3471 fsRecPtr = FsGetFirstFilesystem(); 3472 while (fsRecPtr != NULL) { 3473 Tcl_FSListVolumesProc *proc = fsRecPtr->fsPtr->listVolumesProc; 3474 /* 3475 * We want to skip the native filesystem in this loop because 3476 * otherwise we won't necessarily pass all the Tcl testsuite -- 3477 * this is because some of the tests artificially change the 3478 * current platform (between mac, win, unix) but the list 3479 * of volumes we get by calling (*proc) will reflect the current 3480 * (real) platform only and this may cause some tests to fail. 3481 * In particular, on unix '/' will match the beginning of 3482 * certain absolute Windows paths starting '//' and those tests 3483 * will go wrong. 3484 * 3485 * Besides these test-suite issues, there is one other reason 3486 * to skip the native filesystem --- since the tclFilename.c 3487 * code has nice fast 'absolute path' checkers, we don't want 3488 * to waste time repeating that effort here, and this 3489 * function is actually called quite often, so if we can 3490 * save the overhead of the native filesystem returning us 3491 * a list of volumes all the time, it is better. 3492 */ 3493 if ((fsRecPtr->fsPtr != &tclNativeFilesystem) && (proc != NULL)) { 3494 int numVolumes; 3495 Tcl_Obj *thisFsVolumes = (*proc)(); 3496 if (thisFsVolumes != NULL) { 3497 if (Tcl_ListObjLength(NULL, thisFsVolumes, 3498 &numVolumes) != TCL_OK) { 3499 /* 3500 * This is VERY bad; the Tcl_FSListVolumesProc 3501 * didn't return a valid list. Set numVolumes to 3502 * -1 so that we skip the while loop below and just 3503 * return with the current value of 'type'. 3504 * 3505 * It would be better if we could signal an error 3506 * here (but panic seems a bit excessive). 3507 */ 3508 numVolumes = -1; 3509 } 3510 while (numVolumes > 0) { 3511 Tcl_Obj *vol; 3512 int len; 3513 char *strVol; 3514 3515 numVolumes--; 3516 Tcl_ListObjIndex(NULL, thisFsVolumes, numVolumes, &vol); 3517 strVol = Tcl_GetStringFromObj(vol,&len); 3518 if (pathLen < len) { 3519 continue; 3520 } 3521 if (strncmp(strVol, path, (size_t) len) == 0) { 3522 type = TCL_PATH_ABSOLUTE; 3523 if (filesystemPtrPtr != NULL) { 3524 *filesystemPtrPtr = fsRecPtr->fsPtr; 3525 } 3526 if (driveNameLengthPtr != NULL) { 3527 *driveNameLengthPtr = len; 3528 } 3529 if (driveNameRef != NULL) { 3530 *driveNameRef = vol; 3531 Tcl_IncrRefCount(vol); 3532 } 3533 break; 3534 } 3535 } 3536 Tcl_DecrRefCount(thisFsVolumes); 3537 if (type == TCL_PATH_ABSOLUTE) { 3538 /* We don't need to examine any more filesystems */ 3539 break; 3540 } 3541 } 3542 } 3543 fsRecPtr = fsRecPtr->nextPtr; 3544 } 3545 3546 if (type != TCL_PATH_ABSOLUTE) { 3547 type = TclpGetNativePathType(pathObjPtr, driveNameLengthPtr, 3548 driveNameRef); 3549 if ((type == TCL_PATH_ABSOLUTE) && (filesystemPtrPtr != NULL)) { 3550 *filesystemPtrPtr = &tclNativeFilesystem; 3551 } 3552 } 3553 return type; 3554} 3555 3556/* 3557 *--------------------------------------------------------------------------- 3558 * 3559 * Tcl_FSRenameFile -- 3560 * 3561 * If the two paths given belong to the same filesystem, we call 3562 * that filesystems rename function. Otherwise we simply 3563 * return the posix error 'EXDEV', and -1. 3564 * 3565 * Results: 3566 * Standard Tcl error code if a function was called. 3567 * 3568 * Side effects: 3569 * A file may be renamed. 3570 * 3571 *--------------------------------------------------------------------------- 3572 */ 3573 3574int 3575Tcl_FSRenameFile(srcPathPtr, destPathPtr) 3576 Tcl_Obj* srcPathPtr; /* Pathname of file or dir to be renamed 3577 * (UTF-8). */ 3578 Tcl_Obj *destPathPtr; /* New pathname of file or directory 3579 * (UTF-8). */ 3580{ 3581 int retVal = -1; 3582 Tcl_Filesystem *fsPtr, *fsPtr2; 3583 fsPtr = Tcl_FSGetFileSystemForPath(srcPathPtr); 3584 fsPtr2 = Tcl_FSGetFileSystemForPath(destPathPtr); 3585 3586 if (fsPtr == fsPtr2 && fsPtr != NULL) { 3587 Tcl_FSRenameFileProc *proc = fsPtr->renameFileProc; 3588 if (proc != NULL) { 3589 retVal = (*proc)(srcPathPtr, destPathPtr); 3590 } 3591 } 3592 if (retVal == -1) { 3593 Tcl_SetErrno(EXDEV); 3594 } 3595 return retVal; 3596} 3597 3598/* 3599 *--------------------------------------------------------------------------- 3600 * 3601 * Tcl_FSCopyFile -- 3602 * 3603 * If the two paths given belong to the same filesystem, we call 3604 * that filesystem's copy function. Otherwise we simply 3605 * return the posix error 'EXDEV', and -1. 3606 * 3607 * Note that in the native filesystems, 'copyFileProc' is defined 3608 * to copy soft links (i.e. it copies the links themselves, not 3609 * the things they point to). 3610 * 3611 * Results: 3612 * Standard Tcl error code if a function was called. 3613 * 3614 * Side effects: 3615 * A file may be copied. 3616 * 3617 *--------------------------------------------------------------------------- 3618 */ 3619 3620int 3621Tcl_FSCopyFile(srcPathPtr, destPathPtr) 3622 Tcl_Obj* srcPathPtr; /* Pathname of file to be copied (UTF-8). */ 3623 Tcl_Obj *destPathPtr; /* Pathname of file to copy to (UTF-8). */ 3624{ 3625 int retVal = -1; 3626 Tcl_Filesystem *fsPtr, *fsPtr2; 3627 fsPtr = Tcl_FSGetFileSystemForPath(srcPathPtr); 3628 fsPtr2 = Tcl_FSGetFileSystemForPath(destPathPtr); 3629 3630 if (fsPtr == fsPtr2 && fsPtr != NULL) { 3631 Tcl_FSCopyFileProc *proc = fsPtr->copyFileProc; 3632 if (proc != NULL) { 3633 retVal = (*proc)(srcPathPtr, destPathPtr); 3634 } 3635 } 3636 if (retVal == -1) { 3637 Tcl_SetErrno(EXDEV); 3638 } 3639 return retVal; 3640} 3641 3642/* 3643 *--------------------------------------------------------------------------- 3644 * 3645 * TclCrossFilesystemCopy -- 3646 * 3647 * Helper for above function, and for Tcl_FSLoadFile, to copy 3648 * files from one filesystem to another. This function will 3649 * overwrite the target file if it already exists. 3650 * 3651 * Results: 3652 * Standard Tcl error code. 3653 * 3654 * Side effects: 3655 * A file may be created. 3656 * 3657 *--------------------------------------------------------------------------- 3658 */ 3659int 3660TclCrossFilesystemCopy(interp, source, target) 3661 Tcl_Interp *interp; /* For error messages */ 3662 Tcl_Obj *source; /* Pathname of file to be copied (UTF-8). */ 3663 Tcl_Obj *target; /* Pathname of file to copy to (UTF-8). */ 3664{ 3665 int result = TCL_ERROR; 3666 int prot = 0666; 3667 3668 Tcl_Channel out = Tcl_FSOpenFileChannel(interp, target, "w", prot); 3669 if (out != NULL) { 3670 /* It looks like we can copy it over */ 3671 Tcl_Channel in = Tcl_FSOpenFileChannel(interp, source, 3672 "r", prot); 3673 if (in == NULL) { 3674 /* This is very strange, we checked this above */ 3675 Tcl_Close(interp, out); 3676 } else { 3677 Tcl_StatBuf sourceStatBuf; 3678 struct utimbuf tval; 3679 /* 3680 * Copy it synchronously. We might wish to add an 3681 * asynchronous option to support vfs's which are 3682 * slow (e.g. network sockets). 3683 */ 3684 Tcl_SetChannelOption(interp, in, "-translation", "binary"); 3685 Tcl_SetChannelOption(interp, out, "-translation", "binary"); 3686 3687 if (TclCopyChannel(interp, in, out, -1, NULL) == TCL_OK) { 3688 result = TCL_OK; 3689 } 3690 /* 3691 * If the copy failed, assume that copy channel left 3692 * a good error message. 3693 */ 3694 Tcl_Close(interp, in); 3695 Tcl_Close(interp, out); 3696 3697 /* Set modification date of copied file */ 3698 if (Tcl_FSLstat(source, &sourceStatBuf) == 0) { 3699 tval.actime = sourceStatBuf.st_atime; 3700 tval.modtime = sourceStatBuf.st_mtime; 3701 Tcl_FSUtime(target, &tval); 3702 } 3703 } 3704 } 3705 return result; 3706} 3707 3708/* 3709 *--------------------------------------------------------------------------- 3710 * 3711 * Tcl_FSDeleteFile -- 3712 * 3713 * The appropriate function for the filesystem to which pathPtr 3714 * belongs will be called. 3715 * 3716 * Results: 3717 * Standard Tcl error code. 3718 * 3719 * Side effects: 3720 * A file may be deleted. 3721 * 3722 *--------------------------------------------------------------------------- 3723 */ 3724 3725int 3726Tcl_FSDeleteFile(pathPtr) 3727 Tcl_Obj *pathPtr; /* Pathname of file to be removed (UTF-8). */ 3728{ 3729 Tcl_Filesystem *fsPtr = Tcl_FSGetFileSystemForPath(pathPtr); 3730 if (fsPtr != NULL) { 3731 Tcl_FSDeleteFileProc *proc = fsPtr->deleteFileProc; 3732 if (proc != NULL) { 3733 return (*proc)(pathPtr); 3734 } 3735 } 3736 Tcl_SetErrno(ENOENT); 3737 return -1; 3738} 3739 3740/* 3741 *--------------------------------------------------------------------------- 3742 * 3743 * Tcl_FSCreateDirectory -- 3744 * 3745 * The appropriate function for the filesystem to which pathPtr 3746 * belongs will be called. 3747 * 3748 * Results: 3749 * Standard Tcl error code. 3750 * 3751 * Side effects: 3752 * A directory may be created. 3753 * 3754 *--------------------------------------------------------------------------- 3755 */ 3756 3757int 3758Tcl_FSCreateDirectory(pathPtr) 3759 Tcl_Obj *pathPtr; /* Pathname of directory to create (UTF-8). */ 3760{ 3761 Tcl_Filesystem *fsPtr = Tcl_FSGetFileSystemForPath(pathPtr); 3762 if (fsPtr != NULL) { 3763 Tcl_FSCreateDirectoryProc *proc = fsPtr->createDirectoryProc; 3764 if (proc != NULL) { 3765 return (*proc)(pathPtr); 3766 } 3767 } 3768 Tcl_SetErrno(ENOENT); 3769 return -1; 3770} 3771 3772/* 3773 *--------------------------------------------------------------------------- 3774 * 3775 * Tcl_FSCopyDirectory -- 3776 * 3777 * If the two paths given belong to the same filesystem, we call 3778 * that filesystems copy-directory function. Otherwise we simply 3779 * return the posix error 'EXDEV', and -1. 3780 * 3781 * Results: 3782 * Standard Tcl error code if a function was called. 3783 * 3784 * Side effects: 3785 * A directory may be copied. 3786 * 3787 *--------------------------------------------------------------------------- 3788 */ 3789 3790int 3791Tcl_FSCopyDirectory(srcPathPtr, destPathPtr, errorPtr) 3792 Tcl_Obj* srcPathPtr; /* Pathname of directory to be copied 3793 * (UTF-8). */ 3794 Tcl_Obj *destPathPtr; /* Pathname of target directory (UTF-8). */ 3795 Tcl_Obj **errorPtr; /* If non-NULL, then will be set to a 3796 * new object containing name of file 3797 * causing error, with refCount 1. */ 3798{ 3799 int retVal = -1; 3800 Tcl_Filesystem *fsPtr, *fsPtr2; 3801 fsPtr = Tcl_FSGetFileSystemForPath(srcPathPtr); 3802 fsPtr2 = Tcl_FSGetFileSystemForPath(destPathPtr); 3803 3804 if (fsPtr == fsPtr2 && fsPtr != NULL) { 3805 Tcl_FSCopyDirectoryProc *proc = fsPtr->copyDirectoryProc; 3806 if (proc != NULL) { 3807 retVal = (*proc)(srcPathPtr, destPathPtr, errorPtr); 3808 } 3809 } 3810 if (retVal == -1) { 3811 Tcl_SetErrno(EXDEV); 3812 } 3813 return retVal; 3814} 3815 3816/* 3817 *--------------------------------------------------------------------------- 3818 * 3819 * Tcl_FSRemoveDirectory -- 3820 * 3821 * The appropriate function for the filesystem to which pathPtr 3822 * belongs will be called. 3823 * 3824 * Results: 3825 * Standard Tcl error code. 3826 * 3827 * Side effects: 3828 * A directory may be deleted. 3829 * 3830 *--------------------------------------------------------------------------- 3831 */ 3832 3833int 3834Tcl_FSRemoveDirectory(pathPtr, recursive, errorPtr) 3835 Tcl_Obj *pathPtr; /* Pathname of directory to be removed 3836 * (UTF-8). */ 3837 int recursive; /* If non-zero, removes directories that 3838 * are nonempty. Otherwise, will only remove 3839 * empty directories. */ 3840 Tcl_Obj **errorPtr; /* If non-NULL, then will be set to a 3841 * new object containing name of file 3842 * causing error, with refCount 1. */ 3843{ 3844 Tcl_Filesystem *fsPtr = Tcl_FSGetFileSystemForPath(pathPtr); 3845 if (fsPtr != NULL) { 3846 Tcl_FSRemoveDirectoryProc *proc = fsPtr->removeDirectoryProc; 3847 if (proc != NULL) { 3848 if (recursive) { 3849 /* 3850 * We check whether the cwd lies inside this directory 3851 * and move it if it does. 3852 */ 3853 Tcl_Obj *cwdPtr = Tcl_FSGetCwd(NULL); 3854 if (cwdPtr != NULL) { 3855 char *cwdStr, *normPathStr; 3856 int cwdLen, normLen; 3857 Tcl_Obj *normPath = Tcl_FSGetNormalizedPath(NULL, pathPtr); 3858 if (normPath != NULL) { 3859 normPathStr = Tcl_GetStringFromObj(normPath, &normLen); 3860 cwdStr = Tcl_GetStringFromObj(cwdPtr, &cwdLen); 3861 if ((cwdLen >= normLen) && (strncmp(normPathStr, 3862 cwdStr, (size_t) normLen) == 0)) { 3863 /* 3864 * the cwd is inside the directory, so we 3865 * perform a 'cd [file dirname $path]' 3866 */ 3867 Tcl_Obj *dirPtr = TclFileDirname(NULL, pathPtr); 3868 Tcl_FSChdir(dirPtr); 3869 Tcl_DecrRefCount(dirPtr); 3870 } 3871 } 3872 Tcl_DecrRefCount(cwdPtr); 3873 } 3874 } 3875 return (*proc)(pathPtr, recursive, errorPtr); 3876 } 3877 } 3878 Tcl_SetErrno(ENOENT); 3879 return -1; 3880} 3881 3882/* 3883 *--------------------------------------------------------------------------- 3884 * 3885 * Tcl_FSGetFileSystemForPath -- 3886 * 3887 * This function determines which filesystem to use for a 3888 * particular path object, and returns the filesystem which 3889 * accepts this file. If no filesystem will accept this object 3890 * as a valid file path, then NULL is returned. 3891 * 3892 * Results: 3893.* NULL or a filesystem which will accept this path. 3894 * 3895 * Side effects: 3896 * The object may be converted to a path type. 3897 * 3898 *--------------------------------------------------------------------------- 3899 */ 3900 3901Tcl_Filesystem* 3902Tcl_FSGetFileSystemForPath(pathObjPtr) 3903 Tcl_Obj* pathObjPtr; 3904{ 3905 FilesystemRecord *fsRecPtr; 3906 Tcl_Filesystem* retVal = NULL; 3907 3908 /* 3909 * If the object has a refCount of zero, we reject it. This 3910 * is to avoid possible segfaults or nondeterministic memory 3911 * leaks (i.e. the user doesn't know if they should decrement 3912 * the ref count on return or not). 3913 */ 3914 3915 if (pathObjPtr->refCount == 0) { 3916 panic("Tcl_FSGetFileSystemForPath called with object with refCount == 0"); 3917 return NULL; 3918 } 3919 3920 /* 3921 * Check if the filesystem has changed in some way since 3922 * this object's internal representation was calculated. 3923 * Before doing that, assure we have the most up-to-date 3924 * copy of the master filesystem. This is accomplished 3925 * by the FsGetFirstFilesystem() call. 3926 */ 3927 3928 fsRecPtr = FsGetFirstFilesystem(); 3929 3930 if (TclFSEnsureEpochOk(pathObjPtr, &retVal) != TCL_OK) { 3931 return NULL; 3932 } 3933 3934 /* 3935 * Call each of the "pathInFilesystem" functions in succession. A 3936 * non-return value of -1 indicates the particular function has 3937 * succeeded. 3938 */ 3939 3940 while ((retVal == NULL) && (fsRecPtr != NULL)) { 3941 Tcl_FSPathInFilesystemProc *proc = fsRecPtr->fsPtr->pathInFilesystemProc; 3942 if (proc != NULL) { 3943 ClientData clientData = NULL; 3944 int ret = (*proc)(pathObjPtr, &clientData); 3945 if (ret != -1) { 3946 /* 3947 * We assume the type of pathObjPtr hasn't been changed 3948 * by the above call to the pathInFilesystemProc. 3949 */ 3950 TclFSSetPathDetails(pathObjPtr, fsRecPtr, clientData); 3951 retVal = fsRecPtr->fsPtr; 3952 } 3953 } 3954 fsRecPtr = fsRecPtr->nextPtr; 3955 } 3956 3957 return retVal; 3958} 3959 3960/* 3961 *--------------------------------------------------------------------------- 3962 * 3963 * Tcl_FSGetNativePath -- 3964 * 3965 * This function is for use by the Win/Unix/MacOS native filesystems, 3966 * so that they can easily retrieve the native (char* or TCHAR*) 3967 * representation of a path. Other filesystems will probably 3968 * want to implement similar functions. They basically act as a 3969 * safety net around Tcl_FSGetInternalRep. Normally your file- 3970 * system procedures will always be called with path objects 3971 * already converted to the correct filesystem, but if for 3972 * some reason they are called directly (i.e. by procedures 3973 * not in this file), then one cannot necessarily guarantee that 3974 * the path object pointer is from the correct filesystem. 3975 * 3976 * Note: in the future it might be desireable to have separate 3977 * versions of this function with different signatures, for 3978 * example Tcl_FSGetNativeMacPath, Tcl_FSGetNativeUnixPath etc. 3979 * Right now, since native paths are all string based, we use just 3980 * one function. On MacOS we could possibly use an FSSpec or 3981 * FSRef as the native representation. 3982 * 3983 * Results: 3984 * NULL or a valid native path. 3985 * 3986 * Side effects: 3987 * See Tcl_FSGetInternalRep. 3988 * 3989 *--------------------------------------------------------------------------- 3990 */ 3991 3992CONST char * 3993Tcl_FSGetNativePath(pathObjPtr) 3994 Tcl_Obj *pathObjPtr; 3995{ 3996 return (CONST char *)Tcl_FSGetInternalRep(pathObjPtr, &tclNativeFilesystem); 3997} 3998 3999/* 4000 *--------------------------------------------------------------------------- 4001 * 4002 * NativeCreateNativeRep -- 4003 * 4004 * Create a native representation for the given path. 4005 * 4006 * Results: 4007 * None. 4008 * 4009 * Side effects: 4010 * None. 4011 * 4012 *--------------------------------------------------------------------------- 4013 */ 4014static ClientData 4015NativeCreateNativeRep(pathObjPtr) 4016 Tcl_Obj* pathObjPtr; 4017{ 4018 char *nativePathPtr; 4019 Tcl_DString ds; 4020 Tcl_Obj* validPathObjPtr; 4021 int len; 4022 char *str; 4023 4024 /* Make sure the normalized path is set */ 4025 validPathObjPtr = Tcl_FSGetNormalizedPath(NULL, pathObjPtr); 4026 if (validPathObjPtr == NULL) { 4027 return NULL; 4028 } 4029 4030 str = Tcl_GetStringFromObj(validPathObjPtr, &len); 4031#ifdef __WIN32__ 4032 Tcl_WinUtfToTChar(str, len, &ds); 4033 if (tclWinProcs->useWide) { 4034 len = Tcl_DStringLength(&ds) + sizeof(WCHAR); 4035 } else { 4036 len = Tcl_DStringLength(&ds) + sizeof(char); 4037 } 4038#else 4039 Tcl_UtfToExternalDString(NULL, str, len, &ds); 4040 len = Tcl_DStringLength(&ds) + sizeof(char); 4041#endif 4042 nativePathPtr = ckalloc((unsigned) len); 4043 memcpy((VOID*)nativePathPtr, (VOID*)Tcl_DStringValue(&ds), (size_t) len); 4044 4045 Tcl_DStringFree(&ds); 4046 return (ClientData)nativePathPtr; 4047} 4048 4049/* 4050 *--------------------------------------------------------------------------- 4051 * 4052 * TclpNativeToNormalized -- 4053 * 4054 * Convert native format to a normalized path object, with refCount 4055 * of zero. 4056 * 4057 * Results: 4058 * A valid normalized path. 4059 * 4060 * Side effects: 4061 * None. 4062 * 4063 *--------------------------------------------------------------------------- 4064 */ 4065Tcl_Obj* 4066TclpNativeToNormalized(clientData) 4067 ClientData clientData; 4068{ 4069 Tcl_DString ds; 4070 Tcl_Obj *objPtr; 4071 CONST char *copy; 4072 int len; 4073 4074#ifdef __WIN32__ 4075 Tcl_WinTCharToUtf((CONST char*)clientData, -1, &ds); 4076#else 4077 Tcl_ExternalToUtfDString(NULL, (CONST char*)clientData, -1, &ds); 4078#endif 4079 4080 copy = Tcl_DStringValue(&ds); 4081 len = Tcl_DStringLength(&ds); 4082 4083#ifdef __WIN32__ 4084 /* 4085 * Certain native path representations on Windows have this special 4086 * prefix to indicate that they are to be treated specially. For 4087 * example extremely long paths, or symlinks 4088 */ 4089 if (*copy == '\\') { 4090 if (0 == strncmp(copy,"\\??\\",4)) { 4091 copy += 4; 4092 len -= 4; 4093 } else if (0 == strncmp(copy,"\\\\?\\",4)) { 4094 copy += 4; 4095 len -= 4; 4096 } 4097 } 4098#endif 4099 4100 objPtr = Tcl_NewStringObj(copy,len); 4101 Tcl_DStringFree(&ds); 4102 4103 return objPtr; 4104} 4105 4106 4107/* 4108 *--------------------------------------------------------------------------- 4109 * 4110 * TclNativeDupInternalRep -- 4111 * 4112 * Duplicate the native representation. 4113 * 4114 * Results: 4115 * The copied native representation, or NULL if it is not possible 4116 * to copy the representation. 4117 * 4118 * Side effects: 4119 * None. 4120 * 4121 *--------------------------------------------------------------------------- 4122 */ 4123ClientData 4124TclNativeDupInternalRep(clientData) 4125 ClientData clientData; 4126{ 4127 ClientData copy; 4128 size_t len; 4129 4130 if (clientData == NULL) { 4131 return NULL; 4132 } 4133 4134#ifdef __WIN32__ 4135 if (tclWinProcs->useWide) { 4136 /* unicode representation when running on NT/2K/XP */ 4137 len = sizeof(WCHAR) + (wcslen((CONST WCHAR*)clientData) * sizeof(WCHAR)); 4138 } else { 4139 /* ansi representation when running on 95/98/ME */ 4140 len = sizeof(char) + (strlen((CONST char*)clientData) * sizeof(char)); 4141 } 4142#else 4143 /* ansi representation when running on Unix/MacOS */ 4144 len = sizeof(char) + (strlen((CONST char*)clientData) * sizeof(char)); 4145#endif 4146 4147 copy = (ClientData) ckalloc(len); 4148 memcpy((VOID*)copy, (VOID*)clientData, len); 4149 return copy; 4150} 4151 4152/* 4153 *--------------------------------------------------------------------------- 4154 * 4155 * NativeFreeInternalRep -- 4156 * 4157 * Free a native internal representation, which will be non-NULL. 4158 * 4159 * Results: 4160 * None. 4161 * 4162 * Side effects: 4163 * Memory is released. 4164 * 4165 *--------------------------------------------------------------------------- 4166 */ 4167static void 4168NativeFreeInternalRep(clientData) 4169 ClientData clientData; 4170{ 4171 ckfree((char*)clientData); 4172} 4173 4174/* 4175 *--------------------------------------------------------------------------- 4176 * 4177 * Tcl_FSFileSystemInfo -- 4178 * 4179 * This function returns a list of two elements. The first 4180 * element is the name of the filesystem (e.g. "native" or "vfs"), 4181 * and the second is the particular type of the given path within 4182 * that filesystem. 4183 * 4184 * Results: 4185 * A list of two elements. 4186 * 4187 * Side effects: 4188 * The object may be converted to a path type. 4189 * 4190 *--------------------------------------------------------------------------- 4191 */ 4192Tcl_Obj* 4193Tcl_FSFileSystemInfo(pathObjPtr) 4194 Tcl_Obj* pathObjPtr; 4195{ 4196 Tcl_Obj *resPtr; 4197 Tcl_FSFilesystemPathTypeProc *proc; 4198 Tcl_Filesystem *fsPtr = Tcl_FSGetFileSystemForPath(pathObjPtr); 4199 4200 if (fsPtr == NULL) { 4201 return NULL; 4202 } 4203 4204 resPtr = Tcl_NewListObj(0,NULL); 4205 4206 Tcl_ListObjAppendElement(NULL, resPtr, 4207 Tcl_NewStringObj(fsPtr->typeName,-1)); 4208 4209 proc = fsPtr->filesystemPathTypeProc; 4210 if (proc != NULL) { 4211 Tcl_Obj *typePtr = (*proc)(pathObjPtr); 4212 if (typePtr != NULL) { 4213 Tcl_ListObjAppendElement(NULL, resPtr, typePtr); 4214 } 4215 } 4216 4217 return resPtr; 4218} 4219 4220/* 4221 *--------------------------------------------------------------------------- 4222 * 4223 * Tcl_FSPathSeparator -- 4224 * 4225 * This function returns the separator to be used for a given 4226 * path. The object returned should have a refCount of zero 4227 * 4228 * Results: 4229 * A Tcl object, with a refCount of zero. If the caller 4230 * needs to retain a reference to the object, it should 4231 * call Tcl_IncrRefCount. 4232 * 4233 * Side effects: 4234 * The path object may be converted to a path type. 4235 * 4236 *--------------------------------------------------------------------------- 4237 */ 4238Tcl_Obj* 4239Tcl_FSPathSeparator(pathObjPtr) 4240 Tcl_Obj* pathObjPtr; 4241{ 4242 Tcl_Filesystem *fsPtr = Tcl_FSGetFileSystemForPath(pathObjPtr); 4243 4244 if (fsPtr == NULL) { 4245 return NULL; 4246 } 4247 if (fsPtr->filesystemSeparatorProc != NULL) { 4248 return (*fsPtr->filesystemSeparatorProc)(pathObjPtr); 4249 } 4250 4251 return NULL; 4252} 4253 4254/* 4255 *--------------------------------------------------------------------------- 4256 * 4257 * NativeFilesystemSeparator -- 4258 * 4259 * This function is part of the native filesystem support, and 4260 * returns the separator for the given path. 4261 * 4262 * Results: 4263 * String object containing the separator character. 4264 * 4265 * Side effects: 4266 * None. 4267 * 4268 *--------------------------------------------------------------------------- 4269 */ 4270static Tcl_Obj* 4271NativeFilesystemSeparator(pathObjPtr) 4272 Tcl_Obj* pathObjPtr; 4273{ 4274 char *separator = NULL; /* lint */ 4275 switch (tclPlatform) { 4276 case TCL_PLATFORM_UNIX: 4277 separator = "/"; 4278 break; 4279 case TCL_PLATFORM_WINDOWS: 4280 separator = "\\"; 4281 break; 4282 case TCL_PLATFORM_MAC: 4283 separator = ":"; 4284 break; 4285 } 4286 return Tcl_NewStringObj(separator,1); 4287} 4288 4289/* Everything from here on is contained in this obsolete ifdef */ 4290#ifdef USE_OBSOLETE_FS_HOOKS 4291 4292/* 4293 *---------------------------------------------------------------------- 4294 * 4295 * TclStatInsertProc -- 4296 * 4297 * Insert the passed procedure pointer at the head of the list of 4298 * functions which are used during a call to 'TclStat(...)'. The 4299 * passed function should behave exactly like 'TclStat' when called 4300 * during that time (see 'TclStat(...)' for more information). 4301 * The function will be added even if it already in the list. 4302 * 4303 * Results: 4304 * Normally TCL_OK; TCL_ERROR if memory for a new node in the list 4305 * could not be allocated. 4306 * 4307 * Side effects: 4308 * Memory allocated and modifies the link list for 'TclStat' 4309 * functions. 4310 * 4311 *---------------------------------------------------------------------- 4312 */ 4313 4314int 4315TclStatInsertProc (proc) 4316 TclStatProc_ *proc; 4317{ 4318 int retVal = TCL_ERROR; 4319 4320 if (proc != NULL) { 4321 StatProc *newStatProcPtr; 4322 4323 newStatProcPtr = (StatProc *)ckalloc(sizeof(StatProc)); 4324 4325 if (newStatProcPtr != NULL) { 4326 newStatProcPtr->proc = proc; 4327 Tcl_MutexLock(&obsoleteFsHookMutex); 4328 newStatProcPtr->nextPtr = statProcList; 4329 statProcList = newStatProcPtr; 4330 Tcl_MutexUnlock(&obsoleteFsHookMutex); 4331 4332 retVal = TCL_OK; 4333 } 4334 } 4335 4336 return retVal; 4337} 4338 4339/* 4340 *---------------------------------------------------------------------- 4341 * 4342 * TclStatDeleteProc -- 4343 * 4344 * Removed the passed function pointer from the list of 'TclStat' 4345 * functions. Ensures that the built-in stat function is not 4346 * removvable. 4347 * 4348 * Results: 4349 * TCL_OK if the procedure pointer was successfully removed, 4350 * TCL_ERROR otherwise. 4351 * 4352 * Side effects: 4353 * Memory is deallocated and the respective list updated. 4354 * 4355 *---------------------------------------------------------------------- 4356 */ 4357 4358int 4359TclStatDeleteProc (proc) 4360 TclStatProc_ *proc; 4361{ 4362 int retVal = TCL_ERROR; 4363 StatProc *tmpStatProcPtr; 4364 StatProc *prevStatProcPtr = NULL; 4365 4366 Tcl_MutexLock(&obsoleteFsHookMutex); 4367 tmpStatProcPtr = statProcList; 4368 /* 4369 * Traverse the 'statProcList' looking for the particular node 4370 * whose 'proc' member matches 'proc' and remove that one from 4371 * the list. Ensure that the "default" node cannot be removed. 4372 */ 4373 4374 while ((retVal == TCL_ERROR) && (tmpStatProcPtr != NULL)) { 4375 if (tmpStatProcPtr->proc == proc) { 4376 if (prevStatProcPtr == NULL) { 4377 statProcList = tmpStatProcPtr->nextPtr; 4378 } else { 4379 prevStatProcPtr->nextPtr = tmpStatProcPtr->nextPtr; 4380 } 4381 4382 ckfree((char *)tmpStatProcPtr); 4383 4384 retVal = TCL_OK; 4385 } else { 4386 prevStatProcPtr = tmpStatProcPtr; 4387 tmpStatProcPtr = tmpStatProcPtr->nextPtr; 4388 } 4389 } 4390 4391 Tcl_MutexUnlock(&obsoleteFsHookMutex); 4392 4393 return retVal; 4394} 4395 4396/* 4397 *---------------------------------------------------------------------- 4398 * 4399 * TclAccessInsertProc -- 4400 * 4401 * Insert the passed procedure pointer at the head of the list of 4402 * functions which are used during a call to 'TclAccess(...)'. 4403 * The passed function should behave exactly like 'TclAccess' when 4404 * called during that time (see 'TclAccess(...)' for more 4405 * information). The function will be added even if it already in 4406 * the list. 4407 * 4408 * Results: 4409 * Normally TCL_OK; TCL_ERROR if memory for a new node in the list 4410 * could not be allocated. 4411 * 4412 * Side effects: 4413 * Memory allocated and modifies the link list for 'TclAccess' 4414 * functions. 4415 * 4416 *---------------------------------------------------------------------- 4417 */ 4418 4419int 4420TclAccessInsertProc(proc) 4421 TclAccessProc_ *proc; 4422{ 4423 int retVal = TCL_ERROR; 4424 4425 if (proc != NULL) { 4426 AccessProc *newAccessProcPtr; 4427 4428 newAccessProcPtr = (AccessProc *)ckalloc(sizeof(AccessProc)); 4429 4430 if (newAccessProcPtr != NULL) { 4431 newAccessProcPtr->proc = proc; 4432 Tcl_MutexLock(&obsoleteFsHookMutex); 4433 newAccessProcPtr->nextPtr = accessProcList; 4434 accessProcList = newAccessProcPtr; 4435 Tcl_MutexUnlock(&obsoleteFsHookMutex); 4436 4437 retVal = TCL_OK; 4438 } 4439 } 4440 4441 return retVal; 4442} 4443 4444/* 4445 *---------------------------------------------------------------------- 4446 * 4447 * TclAccessDeleteProc -- 4448 * 4449 * Removed the passed function pointer from the list of 'TclAccess' 4450 * functions. Ensures that the built-in access function is not 4451 * removvable. 4452 * 4453 * Results: 4454 * TCL_OK if the procedure pointer was successfully removed, 4455 * TCL_ERROR otherwise. 4456 * 4457 * Side effects: 4458 * Memory is deallocated and the respective list updated. 4459 * 4460 *---------------------------------------------------------------------- 4461 */ 4462 4463int 4464TclAccessDeleteProc(proc) 4465 TclAccessProc_ *proc; 4466{ 4467 int retVal = TCL_ERROR; 4468 AccessProc *tmpAccessProcPtr; 4469 AccessProc *prevAccessProcPtr = NULL; 4470 4471 /* 4472 * Traverse the 'accessProcList' looking for the particular node 4473 * whose 'proc' member matches 'proc' and remove that one from 4474 * the list. Ensure that the "default" node cannot be removed. 4475 */ 4476 4477 Tcl_MutexLock(&obsoleteFsHookMutex); 4478 tmpAccessProcPtr = accessProcList; 4479 while ((retVal == TCL_ERROR) && (tmpAccessProcPtr != NULL)) { 4480 if (tmpAccessProcPtr->proc == proc) { 4481 if (prevAccessProcPtr == NULL) { 4482 accessProcList = tmpAccessProcPtr->nextPtr; 4483 } else { 4484 prevAccessProcPtr->nextPtr = tmpAccessProcPtr->nextPtr; 4485 } 4486 4487 ckfree((char *)tmpAccessProcPtr); 4488 4489 retVal = TCL_OK; 4490 } else { 4491 prevAccessProcPtr = tmpAccessProcPtr; 4492 tmpAccessProcPtr = tmpAccessProcPtr->nextPtr; 4493 } 4494 } 4495 Tcl_MutexUnlock(&obsoleteFsHookMutex); 4496 4497 return retVal; 4498} 4499 4500/* 4501 *---------------------------------------------------------------------- 4502 * 4503 * TclOpenFileChannelInsertProc -- 4504 * 4505 * Insert the passed procedure pointer at the head of the list of 4506 * functions which are used during a call to 4507 * 'Tcl_OpenFileChannel(...)'. The passed function should behave 4508 * exactly like 'Tcl_OpenFileChannel' when called during that time 4509 * (see 'Tcl_OpenFileChannel(...)' for more information). The 4510 * function will be added even if it already in the list. 4511 * 4512 * Results: 4513 * Normally TCL_OK; TCL_ERROR if memory for a new node in the list 4514 * could not be allocated. 4515 * 4516 * Side effects: 4517 * Memory allocated and modifies the link list for 4518 * 'Tcl_OpenFileChannel' functions. 4519 * 4520 *---------------------------------------------------------------------- 4521 */ 4522 4523int 4524TclOpenFileChannelInsertProc(proc) 4525 TclOpenFileChannelProc_ *proc; 4526{ 4527 int retVal = TCL_ERROR; 4528 4529 if (proc != NULL) { 4530 OpenFileChannelProc *newOpenFileChannelProcPtr; 4531 4532 newOpenFileChannelProcPtr = 4533 (OpenFileChannelProc *)ckalloc(sizeof(OpenFileChannelProc)); 4534 4535 if (newOpenFileChannelProcPtr != NULL) { 4536 newOpenFileChannelProcPtr->proc = proc; 4537 Tcl_MutexLock(&obsoleteFsHookMutex); 4538 newOpenFileChannelProcPtr->nextPtr = openFileChannelProcList; 4539 openFileChannelProcList = newOpenFileChannelProcPtr; 4540 Tcl_MutexUnlock(&obsoleteFsHookMutex); 4541 4542 retVal = TCL_OK; 4543 } 4544 } 4545 4546 return retVal; 4547} 4548 4549/* 4550 *---------------------------------------------------------------------- 4551 * 4552 * TclOpenFileChannelDeleteProc -- 4553 * 4554 * Removed the passed function pointer from the list of 4555 * 'Tcl_OpenFileChannel' functions. Ensures that the built-in 4556 * open file channel function is not removable. 4557 * 4558 * Results: 4559 * TCL_OK if the procedure pointer was successfully removed, 4560 * TCL_ERROR otherwise. 4561 * 4562 * Side effects: 4563 * Memory is deallocated and the respective list updated. 4564 * 4565 *---------------------------------------------------------------------- 4566 */ 4567 4568int 4569TclOpenFileChannelDeleteProc(proc) 4570 TclOpenFileChannelProc_ *proc; 4571{ 4572 int retVal = TCL_ERROR; 4573 OpenFileChannelProc *tmpOpenFileChannelProcPtr = openFileChannelProcList; 4574 OpenFileChannelProc *prevOpenFileChannelProcPtr = NULL; 4575 4576 /* 4577 * Traverse the 'openFileChannelProcList' looking for the particular 4578 * node whose 'proc' member matches 'proc' and remove that one from 4579 * the list. 4580 */ 4581 4582 Tcl_MutexLock(&obsoleteFsHookMutex); 4583 tmpOpenFileChannelProcPtr = openFileChannelProcList; 4584 while ((retVal == TCL_ERROR) && 4585 (tmpOpenFileChannelProcPtr != NULL)) { 4586 if (tmpOpenFileChannelProcPtr->proc == proc) { 4587 if (prevOpenFileChannelProcPtr == NULL) { 4588 openFileChannelProcList = tmpOpenFileChannelProcPtr->nextPtr; 4589 } else { 4590 prevOpenFileChannelProcPtr->nextPtr = 4591 tmpOpenFileChannelProcPtr->nextPtr; 4592 } 4593 4594 ckfree((char *)tmpOpenFileChannelProcPtr); 4595 4596 retVal = TCL_OK; 4597 } else { 4598 prevOpenFileChannelProcPtr = tmpOpenFileChannelProcPtr; 4599 tmpOpenFileChannelProcPtr = tmpOpenFileChannelProcPtr->nextPtr; 4600 } 4601 } 4602 Tcl_MutexUnlock(&obsoleteFsHookMutex); 4603 4604 return retVal; 4605} 4606#endif /* USE_OBSOLETE_FS_HOOKS */ 4607 4608 4609/* 4610 * Prototypes for procedures defined later in this file. 4611 */ 4612 4613static void DupFsPathInternalRep _ANSI_ARGS_((Tcl_Obj *srcPtr, 4614 Tcl_Obj *copyPtr)); 4615static void FreeFsPathInternalRep _ANSI_ARGS_((Tcl_Obj *listPtr)); 4616static void UpdateStringOfFsPath _ANSI_ARGS_((Tcl_Obj *objPtr)); 4617static int SetFsPathFromAny _ANSI_ARGS_((Tcl_Interp *interp, 4618 Tcl_Obj *objPtr)); 4619static int FindSplitPos _ANSI_ARGS_((char *path, char *separator)); 4620 4621 4622 4623/* 4624 * Define the 'path' object type, which Tcl uses to represent 4625 * file paths internally. 4626 */ 4627static Tcl_ObjType tclFsPathType = { 4628 "path", /* name */ 4629 FreeFsPathInternalRep, /* freeIntRepProc */ 4630 DupFsPathInternalRep, /* dupIntRepProc */ 4631 UpdateStringOfFsPath, /* updateStringProc */ 4632 SetFsPathFromAny /* setFromAnyProc */ 4633}; 4634 4635/* 4636 * struct FsPath -- 4637 * 4638 * Internal representation of a Tcl_Obj of "path" type. This 4639 * can be used to represent relative or absolute paths, and has 4640 * certain optimisations when used to represent paths which are 4641 * already normalized and absolute. 4642 * 4643 * Note that 'normPathPtr' can be a circular reference to the 4644 * container Tcl_Obj of this FsPath. 4645 */ 4646typedef struct FsPath { 4647 Tcl_Obj *translatedPathPtr; /* Name without any ~user sequences. 4648 * If this is NULL, then this is a 4649 * pure normalized, absolute path 4650 * object, in which the parent Tcl_Obj's 4651 * string rep is already both translated 4652 * and normalized. */ 4653 Tcl_Obj *normPathPtr; /* Normalized absolute path, without 4654 * ., .. or ~user sequences. If the 4655 * Tcl_Obj containing 4656 * this FsPath is already normalized, 4657 * this may be a circular reference back 4658 * to the container. If that is NOT the 4659 * case, we have a refCount on the object. */ 4660 Tcl_Obj *cwdPtr; /* If null, path is absolute, else 4661 * this points to the cwd object used 4662 * for this path. We have a refCount 4663 * on the object. */ 4664 int flags; /* Flags to describe interpretation */ 4665 ClientData nativePathPtr; /* Native representation of this path, 4666 * which is filesystem dependent. */ 4667 int filesystemEpoch; /* Used to ensure the path representation 4668 * was generated during the correct 4669 * filesystem epoch. The epoch changes 4670 * when filesystem-mounts are changed. */ 4671 struct FilesystemRecord *fsRecPtr; 4672 /* Pointer to the filesystem record 4673 * entry to use for this path. */ 4674} FsPath; 4675 4676/* 4677 * Define some macros to give us convenient access to path-object 4678 * specific fields. 4679 */ 4680#define PATHOBJ(objPtr) (objPtr->internalRep.otherValuePtr) 4681#define PATHFLAGS(objPtr) \ 4682 (((FsPath*)(objPtr->internalRep.otherValuePtr))->flags) 4683 4684#define TCLPATH_APPENDED 1 4685#define TCLPATH_RELATIVE 2 4686#define TCLPATH_NEEDNORM 4 4687 4688/* 4689 *---------------------------------------------------------------------- 4690 * 4691 * Tcl_FSGetPathType -- 4692 * 4693 * Determines whether a given path is relative to the current 4694 * directory, relative to the current volume, or absolute. 4695 * 4696 * Results: 4697 * Returns one of TCL_PATH_ABSOLUTE, TCL_PATH_RELATIVE, or 4698 * TCL_PATH_VOLUME_RELATIVE. 4699 * 4700 * Side effects: 4701 * None. 4702 * 4703 *---------------------------------------------------------------------- 4704 */ 4705 4706Tcl_PathType 4707Tcl_FSGetPathType(pathObjPtr) 4708 Tcl_Obj *pathObjPtr; 4709{ 4710 return FSGetPathType(pathObjPtr, NULL, NULL); 4711} 4712 4713/* 4714 *---------------------------------------------------------------------- 4715 * 4716 * FSGetPathType -- 4717 * 4718 * Determines whether a given path is relative to the current 4719 * directory, relative to the current volume, or absolute. If the 4720 * caller wishes to know which filesystem claimed the path (in the 4721 * case for which the path is absolute), then a reference to a 4722 * filesystem pointer can be passed in (but passing NULL is 4723 * acceptable). 4724 * 4725 * Results: 4726 * Returns one of TCL_PATH_ABSOLUTE, TCL_PATH_RELATIVE, or 4727 * TCL_PATH_VOLUME_RELATIVE. The filesystem reference will 4728 * be set if and only if it is non-NULL and the function's 4729 * return value is TCL_PATH_ABSOLUTE. 4730 * 4731 * Side effects: 4732 * None. 4733 * 4734 *---------------------------------------------------------------------- 4735 */ 4736 4737static Tcl_PathType 4738FSGetPathType(pathObjPtr, filesystemPtrPtr, driveNameLengthPtr) 4739 Tcl_Obj *pathObjPtr; 4740 Tcl_Filesystem **filesystemPtrPtr; 4741 int *driveNameLengthPtr; 4742{ 4743 if (Tcl_FSConvertToPathType(NULL, pathObjPtr) != TCL_OK) { 4744 return GetPathType(pathObjPtr, filesystemPtrPtr, 4745 driveNameLengthPtr, NULL); 4746 } else { 4747 FsPath *fsPathPtr = (FsPath*) PATHOBJ(pathObjPtr); 4748 if (fsPathPtr->cwdPtr != NULL) { 4749 if (PATHFLAGS(pathObjPtr) == 0) { 4750 /* The path is not absolute... */ 4751#ifdef __WIN32__ 4752 /* ... on Windows we must make another call to determine 4753 * whether it's relative or volumerelative [Bug 2571597]. */ 4754 return GetPathType(pathObjPtr, filesystemPtrPtr, 4755 driveNameLengthPtr, NULL); 4756#else 4757 /* On other systems, quickly deduce !absolute -> relative */ 4758 return TCL_PATH_RELATIVE; 4759#endif 4760 } 4761 return FSGetPathType(fsPathPtr->cwdPtr, filesystemPtrPtr, 4762 driveNameLengthPtr); 4763 } else { 4764 return GetPathType(pathObjPtr, filesystemPtrPtr, 4765 driveNameLengthPtr, NULL); 4766 } 4767 } 4768} 4769 4770/* 4771 *--------------------------------------------------------------------------- 4772 * 4773 * Tcl_FSJoinPath -- 4774 * 4775 * This function takes the given Tcl_Obj, which should be a valid 4776 * list, and returns the path object given by considering the 4777 * first 'elements' elements as valid path segments. If elements < 0, 4778 * we use the entire list. 4779 * 4780 * Results: 4781 * Returns object with refCount of zero, (or if non-zero, it has 4782 * references elsewhere in Tcl). Either way, the caller must 4783 * increment its refCount before use. 4784 * 4785 * Side effects: 4786 * None. 4787 * 4788 *--------------------------------------------------------------------------- 4789 */ 4790Tcl_Obj* 4791Tcl_FSJoinPath(listObj, elements) 4792 Tcl_Obj *listObj; 4793 int elements; 4794{ 4795 Tcl_Obj *res; 4796 int i; 4797 Tcl_Filesystem *fsPtr = NULL; 4798 4799 if (elements < 0) { 4800 if (Tcl_ListObjLength(NULL, listObj, &elements) != TCL_OK) { 4801 return NULL; 4802 } 4803 } else { 4804 /* Just make sure it is a valid list */ 4805 int listTest; 4806 if (Tcl_ListObjLength(NULL, listObj, &listTest) != TCL_OK) { 4807 return NULL; 4808 } 4809 /* 4810 * Correct this if it is too large, otherwise we will 4811 * waste our time joining null elements to the path 4812 */ 4813 if (elements > listTest) { 4814 elements = listTest; 4815 } 4816 } 4817 4818 res = Tcl_NewObj(); 4819 4820 for (i = 0; i < elements; i++) { 4821 Tcl_Obj *elt; 4822 int driveNameLength; 4823 Tcl_PathType type; 4824 char *strElt; 4825 int strEltLen; 4826 int length; 4827 char *ptr; 4828 Tcl_Obj *driveName = NULL; 4829 4830 Tcl_ListObjIndex(NULL, listObj, i, &elt); 4831 4832 /* 4833 * This is a special case where we can be much more 4834 * efficient, where we are joining a single relative path 4835 * onto an object that is already of path type. The 4836 * 'TclNewFSPathObj' call below creates an object which 4837 * can be normalized more efficiently. Currently we only 4838 * use the special case when we have exactly two elements, 4839 * but we could expand that in the future. 4840 */ 4841 if ((i == (elements-2)) && (i == 0) && (elt->typePtr == &tclFsPathType) 4842 && !(elt->bytes != NULL && (elt->bytes[0] == '\0'))) { 4843 Tcl_Obj *tail; 4844 Tcl_PathType type; 4845 Tcl_ListObjIndex(NULL, listObj, i+1, &tail); 4846 type = GetPathType(tail, NULL, NULL, NULL); 4847 if (type == TCL_PATH_RELATIVE) { 4848 CONST char *str; 4849 int len; 4850 str = Tcl_GetStringFromObj(tail,&len); 4851 if (len == 0) { 4852 /* 4853 * This happens if we try to handle the root volume 4854 * '/'. There's no need to return a special path 4855 * object, when the base itself is just fine! 4856 */ 4857 Tcl_DecrRefCount(res); 4858 return elt; 4859 } 4860 /* 4861 * If it doesn't begin with '.' and is a mac or unix 4862 * path or it a windows path without backslashes, then we 4863 * can be very efficient here. (In fact even a windows 4864 * path with backslashes can be joined efficiently, but 4865 * the path object would not have forward slashes only, 4866 * and this would therefore contradict our 'file join' 4867 * documentation). 4868 */ 4869 if (str[0] != '.' && ((tclPlatform != TCL_PLATFORM_WINDOWS) 4870 || (strchr(str, '\\') == NULL))) { 4871 /* 4872 * Finally, on Windows, 'file join' is defined to 4873 * convert all backslashes to forward slashes, 4874 * so the base part cannot have backslashes either. 4875 */ 4876 if ((tclPlatform != TCL_PLATFORM_WINDOWS) 4877 || (strchr(Tcl_GetString(elt), '\\') == NULL)) { 4878 if (res != NULL) { 4879 TclDecrRefCount(res); 4880 } 4881 return TclNewFSPathObj(elt, str, len); 4882 } 4883 } 4884 /* 4885 * Otherwise we don't have an easy join, and 4886 * we must let the more general code below handle 4887 * things 4888 */ 4889 } else { 4890 if (tclPlatform == TCL_PLATFORM_UNIX) { 4891 Tcl_DecrRefCount(res); 4892 return tail; 4893 } else { 4894 CONST char *str; 4895 int len; 4896 str = Tcl_GetStringFromObj(tail,&len); 4897 if (tclPlatform == TCL_PLATFORM_WINDOWS) { 4898 if (strchr(str, '\\') == NULL) { 4899 Tcl_DecrRefCount(res); 4900 return tail; 4901 } 4902 } else if (tclPlatform == TCL_PLATFORM_MAC) { 4903 if (strchr(str, '/') == NULL) { 4904 Tcl_DecrRefCount(res); 4905 return tail; 4906 } 4907 } 4908 } 4909 } 4910 } 4911 strElt = Tcl_GetStringFromObj(elt, &strEltLen); 4912 type = GetPathType(elt, &fsPtr, &driveNameLength, &driveName); 4913 if (type != TCL_PATH_RELATIVE) { 4914 /* Zero out the current result */ 4915 Tcl_DecrRefCount(res); 4916 if (driveName != NULL) { 4917 res = Tcl_DuplicateObj(driveName); 4918 Tcl_DecrRefCount(driveName); 4919 } else { 4920 res = Tcl_NewStringObj(strElt, driveNameLength); 4921 } 4922 strElt += driveNameLength; 4923 } 4924 4925 ptr = Tcl_GetStringFromObj(res, &length); 4926 4927 /* 4928 * Strip off any './' before a tilde, unless this is the 4929 * beginning of the path. 4930 */ 4931 if (length > 0 && strEltLen > 0) { 4932 if ((strElt[0] == '.') && (strElt[1] == '/') 4933 && (strElt[2] == '~')) { 4934 strElt += 2; 4935 } 4936 } 4937 4938 /* 4939 * A NULL value for fsPtr at this stage basically means 4940 * we're trying to join a relative path onto something 4941 * which is also relative (or empty). There's nothing 4942 * particularly wrong with that. 4943 */ 4944 if (*strElt == '\0') continue; 4945 4946 if (fsPtr == &tclNativeFilesystem || fsPtr == NULL) { 4947 TclpNativeJoinPath(res, strElt); 4948 } else { 4949 char separator = '/'; 4950 int needsSep = 0; 4951 4952 if (fsPtr->filesystemSeparatorProc != NULL) { 4953 Tcl_Obj *sep = (*fsPtr->filesystemSeparatorProc)(res); 4954 if (sep != NULL) { 4955 separator = Tcl_GetString(sep)[0]; 4956 } 4957 } 4958 4959 if (length > 0 && ptr[length -1] != '/') { 4960 Tcl_AppendToObj(res, &separator, 1); 4961 length++; 4962 } 4963 Tcl_SetObjLength(res, length + (int) strlen(strElt)); 4964 4965 ptr = Tcl_GetString(res) + length; 4966 for (; *strElt != '\0'; strElt++) { 4967 if (*strElt == separator) { 4968 while (strElt[1] == separator) { 4969 strElt++; 4970 } 4971 if (strElt[1] != '\0') { 4972 if (needsSep) { 4973 *ptr++ = separator; 4974 } 4975 } 4976 } else { 4977 *ptr++ = *strElt; 4978 needsSep = 1; 4979 } 4980 } 4981 length = ptr - Tcl_GetString(res); 4982 Tcl_SetObjLength(res, length); 4983 } 4984 } 4985 return res; 4986} 4987 4988/* 4989 *--------------------------------------------------------------------------- 4990 * 4991 * Tcl_FSConvertToPathType -- 4992 * 4993 * This function tries to convert the given Tcl_Obj to a valid 4994 * Tcl path type, taking account of the fact that the cwd may 4995 * have changed even if this object is already supposedly of 4996 * the correct type. 4997 * 4998 * The filename may begin with "~" (to indicate current user's 4999 * home directory) or "~<user>" (to indicate any user's home 5000 * directory). 5001 * 5002 * Results: 5003 * Standard Tcl error code. 5004 * 5005 * Side effects: 5006 * The old representation may be freed, and new memory allocated. 5007 * 5008 *--------------------------------------------------------------------------- 5009 */ 5010int 5011Tcl_FSConvertToPathType(interp, objPtr) 5012 Tcl_Interp *interp; /* Interpreter in which to store error 5013 * message (if necessary). */ 5014 Tcl_Obj *objPtr; /* Object to convert to a valid, current 5015 * path type. */ 5016{ 5017 ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey); 5018 5019 /* 5020 * While it is bad practice to examine an object's type directly, 5021 * this is actually the best thing to do here. The reason is that 5022 * if we are converting this object to FsPath type for the first 5023 * time, we don't need to worry whether the 'cwd' has changed. 5024 * On the other hand, if this object is already of FsPath type, 5025 * and is a relative path, we do have to worry about the cwd. 5026 * If the cwd has changed, we must recompute the path. 5027 */ 5028 if (objPtr->typePtr == &tclFsPathType) { 5029 FsPath *fsPathPtr = (FsPath*) PATHOBJ(objPtr); 5030 if (fsPathPtr->filesystemEpoch != tsdPtr->filesystemEpoch) { 5031 if (objPtr->bytes == NULL) { 5032 UpdateStringOfFsPath(objPtr); 5033 } 5034 FreeFsPathInternalRep(objPtr); 5035 objPtr->typePtr = NULL; 5036 return Tcl_ConvertToType(interp, objPtr, &tclFsPathType); 5037 } 5038 return TCL_OK; 5039 } else { 5040 return Tcl_ConvertToType(interp, objPtr, &tclFsPathType); 5041 } 5042} 5043 5044/* 5045 * Helper function for SetFsPathFromAny. Returns position of first 5046 * directory delimiter in the path. 5047 */ 5048static int 5049FindSplitPos(path, separator) 5050 char *path; 5051 char *separator; 5052{ 5053 int count = 0; 5054 switch (tclPlatform) { 5055 case TCL_PLATFORM_UNIX: 5056 case TCL_PLATFORM_MAC: 5057 while (path[count] != 0) { 5058 if (path[count] == *separator) { 5059 return count; 5060 } 5061 count++; 5062 } 5063 break; 5064 5065 case TCL_PLATFORM_WINDOWS: 5066 while (path[count] != 0) { 5067 if (path[count] == *separator || path[count] == '\\') { 5068 return count; 5069 } 5070 count++; 5071 } 5072 break; 5073 } 5074 return count; 5075} 5076 5077/* 5078 *--------------------------------------------------------------------------- 5079 * 5080 * TclNewFSPathObj -- 5081 * 5082 * Creates a path object whose string representation is 5083 * '[file join dirPtr addStrRep]', but does so in a way that 5084 * allows for more efficient caching of normalized paths. 5085 * 5086 * Assumptions: 5087 * 'dirPtr' must be an absolute path. 5088 * 'len' may not be zero. 5089 * 5090 * Results: 5091 * The new Tcl object, with refCount zero. 5092 * 5093 * Side effects: 5094 * Memory is allocated. 'dirPtr' gets an additional refCount. 5095 * 5096 *--------------------------------------------------------------------------- 5097 */ 5098 5099Tcl_Obj* 5100TclNewFSPathObj(Tcl_Obj *dirPtr, CONST char *addStrRep, int len) 5101{ 5102 FsPath *fsPathPtr; 5103 Tcl_Obj *objPtr; 5104 ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey); 5105 CONST char *p; 5106 int state = 0, count = 0; 5107 5108 objPtr = Tcl_NewObj(); 5109 fsPathPtr = (FsPath*)ckalloc((unsigned)sizeof(FsPath)); 5110 5111 if (tclPlatform == TCL_PLATFORM_MAC) { 5112 /* 5113 * Mac relative paths may begin with a directory separator ':'. 5114 * If present, we need to skip this ':' because we assume that 5115 * we can join dirPtr and addStrRep by concatenating them as 5116 * strings (and we ensure that dirPtr is terminated by a ':'). 5117 */ 5118 if (addStrRep[0] == ':') { 5119 addStrRep++; 5120 len--; 5121 } 5122 } 5123 /* Setup the path */ 5124 fsPathPtr->translatedPathPtr = NULL; 5125 fsPathPtr->normPathPtr = Tcl_NewStringObj(addStrRep, len); 5126 Tcl_IncrRefCount(fsPathPtr->normPathPtr); 5127 fsPathPtr->cwdPtr = dirPtr; 5128 Tcl_IncrRefCount(dirPtr); 5129 fsPathPtr->nativePathPtr = NULL; 5130 fsPathPtr->fsRecPtr = NULL; 5131 fsPathPtr->filesystemEpoch = tsdPtr->filesystemEpoch; 5132 5133 PATHOBJ(objPtr) = (VOID *) fsPathPtr; 5134 PATHFLAGS(objPtr) = TCLPATH_RELATIVE | TCLPATH_APPENDED; 5135 objPtr->typePtr = &tclFsPathType; 5136 objPtr->bytes = NULL; 5137 objPtr->length = 0; 5138 5139 /* 5140 * Look for path components made up of only "." 5141 * This is overly conservative analysis to keep simple. It may 5142 * mark some things as needing more aggressive normalization 5143 * that don't actually need it. No harm done. 5144 */ 5145 for (p = addStrRep; len > 0; p++, len--) { 5146 switch (state) { 5147 case 0: /* So far only "." since last dirsep or start */ 5148 switch (*p) { 5149 case '.': 5150 count++; 5151 break; 5152 case '/': 5153 case '\\': 5154 case ':': 5155 if (count) { 5156 PATHFLAGS(objPtr) |= TCLPATH_NEEDNORM; 5157 len = 0; 5158 } 5159 break; 5160 default: 5161 count = 0; 5162 state = 1; 5163 } 5164 case 1: /* Scanning for next dirsep */ 5165 switch (*p) { 5166 case '/': 5167 case '\\': 5168 case ':': 5169 state = 0; 5170 break; 5171 } 5172 } 5173 } 5174 if (len == 0 && count) { 5175 PATHFLAGS(objPtr) |= TCLPATH_NEEDNORM; 5176 } 5177 5178 return objPtr; 5179} 5180 5181/* 5182 *--------------------------------------------------------------------------- 5183 * 5184 * TclFSMakePathRelative -- 5185 * 5186 * Only for internal use. 5187 * 5188 * Takes a path and a directory, where we _assume_ both path and 5189 * directory are absolute, normalized and that the path lies 5190 * inside the directory. Returns a Tcl_Obj representing filename 5191 * of the path relative to the directory. 5192 * 5193 * In the case where the resulting path would start with a '~', we 5194 * take special care to return an ordinary string. This means to 5195 * use that path (and not have it interpreted as a user name), 5196 * one must prepend './'. This may seem strange, but that is how 5197 * 'glob' is currently defined. 5198 * 5199 * Results: 5200 * NULL on error, otherwise a valid object, typically with 5201 * refCount of zero, which it is assumed the caller will 5202 * increment. 5203 * 5204 * Side effects: 5205 * The old representation may be freed, and new memory allocated. 5206 * 5207 *--------------------------------------------------------------------------- 5208 */ 5209 5210Tcl_Obj* 5211TclFSMakePathRelative(interp, objPtr, cwdPtr) 5212 Tcl_Interp *interp; /* Used for error reporting if not NULL. */ 5213 Tcl_Obj *objPtr; /* The object we have. */ 5214 Tcl_Obj *cwdPtr; /* Make it relative to this. */ 5215{ 5216 int cwdLen, len; 5217 CONST char *tempStr; 5218 ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey); 5219 5220 if (objPtr->typePtr == &tclFsPathType) { 5221 FsPath *fsPathPtr = (FsPath*) PATHOBJ(objPtr); 5222 if (PATHFLAGS(objPtr) != 0 5223 && fsPathPtr->cwdPtr == cwdPtr) { 5224 objPtr = fsPathPtr->normPathPtr; 5225 /* Free old representation */ 5226 if (objPtr->typePtr != NULL) { 5227 if (objPtr->bytes == NULL) { 5228 if (objPtr->typePtr->updateStringProc == NULL) { 5229 if (interp != NULL) { 5230 Tcl_ResetResult(interp); 5231 Tcl_AppendResult(interp, "can't find object", 5232 "string representation", (char *) NULL); 5233 } 5234 return NULL; 5235 } 5236 objPtr->typePtr->updateStringProc(objPtr); 5237 } 5238 if ((objPtr->typePtr->freeIntRepProc) != NULL) { 5239 (*objPtr->typePtr->freeIntRepProc)(objPtr); 5240 } 5241 } 5242 /* Now objPtr is a string object */ 5243 5244 if (Tcl_GetString(objPtr)[0] == '~') { 5245 /* 5246 * If the first character of the path is a tilde, 5247 * we must just return the path as is, to agree 5248 * with the defined behaviour of 'glob'. 5249 */ 5250 return objPtr; 5251 } 5252 5253 fsPathPtr = (FsPath*)ckalloc((unsigned)sizeof(FsPath)); 5254 5255 /* Circular reference, by design */ 5256 fsPathPtr->translatedPathPtr = objPtr; 5257 fsPathPtr->normPathPtr = NULL; 5258 fsPathPtr->cwdPtr = cwdPtr; 5259 Tcl_IncrRefCount(cwdPtr); 5260 fsPathPtr->nativePathPtr = NULL; 5261 fsPathPtr->fsRecPtr = NULL; 5262 fsPathPtr->filesystemEpoch = tsdPtr->filesystemEpoch; 5263 5264 PATHOBJ(objPtr) = (VOID *) fsPathPtr; 5265 PATHFLAGS(objPtr) = 0; 5266 objPtr->typePtr = &tclFsPathType; 5267 5268 return objPtr; 5269 } 5270 } 5271 /* 5272 * We know the cwd is a normalised object which does 5273 * not end in a directory delimiter, unless the cwd 5274 * is the name of a volume, in which case it will 5275 * end in a delimiter! We handle this situation here. 5276 * A better test than the '!= sep' might be to simply 5277 * check if 'cwd' is a root volume. 5278 * 5279 * Note that if we get this wrong, we will strip off 5280 * either too much or too little below, leading to 5281 * wrong answers returned by glob. 5282 */ 5283 tempStr = Tcl_GetStringFromObj(cwdPtr, &cwdLen); 5284 /* 5285 * Should we perhaps use 'Tcl_FSPathSeparator'? 5286 * But then what about the Windows special case? 5287 * Perhaps we should just check if cwd is a root 5288 * volume. 5289 */ 5290 switch (tclPlatform) { 5291 case TCL_PLATFORM_UNIX: 5292 if (tempStr[cwdLen-1] != '/') { 5293 cwdLen++; 5294 } 5295 break; 5296 case TCL_PLATFORM_WINDOWS: 5297 if (tempStr[cwdLen-1] != '/' 5298 && tempStr[cwdLen-1] != '\\') { 5299 cwdLen++; 5300 } 5301 break; 5302 case TCL_PLATFORM_MAC: 5303 if (tempStr[cwdLen-1] != ':') { 5304 cwdLen++; 5305 } 5306 break; 5307 } 5308 tempStr = Tcl_GetStringFromObj(objPtr, &len); 5309 5310 return Tcl_NewStringObj(tempStr + cwdLen, len - cwdLen); 5311} 5312 5313/* 5314 *--------------------------------------------------------------------------- 5315 * 5316 * TclFSMakePathFromNormalized -- 5317 * 5318 * Like SetFsPathFromAny, but assumes the given object is an 5319 * absolute normalized path. Only for internal use. 5320 * 5321 * Results: 5322 * Standard Tcl error code. 5323 * 5324 * Side effects: 5325 * The old representation may be freed, and new memory allocated. 5326 * 5327 *--------------------------------------------------------------------------- 5328 */ 5329 5330int 5331TclFSMakePathFromNormalized(interp, objPtr, nativeRep) 5332 Tcl_Interp *interp; /* Used for error reporting if not NULL. */ 5333 Tcl_Obj *objPtr; /* The object to convert. */ 5334 ClientData nativeRep; /* The native rep for the object, if known 5335 * else NULL. */ 5336{ 5337 FsPath *fsPathPtr; 5338 ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey); 5339 5340 if (objPtr->typePtr == &tclFsPathType) { 5341 return TCL_OK; 5342 } 5343 5344 /* Free old representation */ 5345 if (objPtr->typePtr != NULL) { 5346 if (objPtr->bytes == NULL) { 5347 if (objPtr->typePtr->updateStringProc == NULL) { 5348 if (interp != NULL) { 5349 Tcl_ResetResult(interp); 5350 Tcl_AppendResult(interp, "can't find object", 5351 "string representation", (char *) NULL); 5352 } 5353 return TCL_ERROR; 5354 } 5355 objPtr->typePtr->updateStringProc(objPtr); 5356 } 5357 if ((objPtr->typePtr->freeIntRepProc) != NULL) { 5358 (*objPtr->typePtr->freeIntRepProc)(objPtr); 5359 } 5360 } 5361 5362 fsPathPtr = (FsPath*)ckalloc((unsigned)sizeof(FsPath)); 5363 /* It's a pure normalized absolute path */ 5364 fsPathPtr->translatedPathPtr = NULL; 5365 fsPathPtr->normPathPtr = objPtr; 5366 fsPathPtr->cwdPtr = NULL; 5367 fsPathPtr->nativePathPtr = nativeRep; 5368 fsPathPtr->fsRecPtr = NULL; 5369 fsPathPtr->filesystemEpoch = tsdPtr->filesystemEpoch; 5370 5371 PATHOBJ(objPtr) = (VOID *) fsPathPtr; 5372 PATHFLAGS(objPtr) = 0; 5373 objPtr->typePtr = &tclFsPathType; 5374 5375 return TCL_OK; 5376} 5377 5378/* 5379 *--------------------------------------------------------------------------- 5380 * 5381 * Tcl_FSNewNativePath -- 5382 * 5383 * This function performs the something like that reverse of the 5384 * usual obj->path->nativerep conversions. If some code retrieves 5385 * a path in native form (from, e.g. readlink or a native dialog), 5386 * and that path is to be used at the Tcl level, then calling 5387 * this function is an efficient way of creating the appropriate 5388 * path object type. 5389 * 5390 * Any memory which is allocated for 'clientData' should be retained 5391 * until clientData is passed to the filesystem's freeInternalRepProc 5392 * when it can be freed. The built in platform-specific filesystems 5393 * use 'ckalloc' to allocate clientData, and ckfree to free it. 5394 * 5395 * Results: 5396 * NULL or a valid path object pointer, with refCount zero. 5397 * 5398 * Side effects: 5399 * New memory may be allocated. 5400 * 5401 *--------------------------------------------------------------------------- 5402 */ 5403 5404Tcl_Obj * 5405Tcl_FSNewNativePath(fromFilesystem, clientData) 5406 Tcl_Filesystem* fromFilesystem; 5407 ClientData clientData; 5408{ 5409 Tcl_Obj *objPtr; 5410 FsPath *fsPathPtr; 5411 5412 FilesystemRecord *fsFromPtr; 5413 ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey); 5414 5415 objPtr = TclFSInternalToNormalized(fromFilesystem, clientData, &fsFromPtr); 5416 if (objPtr == NULL) { 5417 return NULL; 5418 } 5419 5420 /* 5421 * Free old representation; shouldn't normally be any, 5422 * but best to be safe. 5423 */ 5424 if (objPtr->typePtr != NULL) { 5425 if (objPtr->bytes == NULL) { 5426 if (objPtr->typePtr->updateStringProc == NULL) { 5427 return NULL; 5428 } 5429 objPtr->typePtr->updateStringProc(objPtr); 5430 } 5431 if ((objPtr->typePtr->freeIntRepProc) != NULL) { 5432 (*objPtr->typePtr->freeIntRepProc)(objPtr); 5433 } 5434 } 5435 5436 fsPathPtr = (FsPath*)ckalloc((unsigned)sizeof(FsPath)); 5437 5438 fsPathPtr->translatedPathPtr = NULL; 5439 /* Circular reference, by design */ 5440 fsPathPtr->normPathPtr = objPtr; 5441 fsPathPtr->cwdPtr = NULL; 5442 fsPathPtr->nativePathPtr = clientData; 5443 fsPathPtr->fsRecPtr = fsFromPtr; 5444 fsPathPtr->fsRecPtr->fileRefCount++; 5445 fsPathPtr->filesystemEpoch = tsdPtr->filesystemEpoch; 5446 5447 PATHOBJ(objPtr) = (VOID *) fsPathPtr; 5448 PATHFLAGS(objPtr) = 0; 5449 objPtr->typePtr = &tclFsPathType; 5450 5451 return objPtr; 5452} 5453 5454/* 5455 *--------------------------------------------------------------------------- 5456 * 5457 * Tcl_FSGetTranslatedPath -- 5458 * 5459 * This function attempts to extract the translated path 5460 * from the given Tcl_Obj. If the translation succeeds (i.e. the 5461 * object is a valid path), then it is returned. Otherwise NULL 5462 * will be returned, and an error message may be left in the 5463 * interpreter (if it is non-NULL) 5464 * 5465 * Results: 5466 * NULL or a valid Tcl_Obj pointer. 5467 * 5468 * Side effects: 5469 * Only those of 'Tcl_FSConvertToPathType' 5470 * 5471 *--------------------------------------------------------------------------- 5472 */ 5473 5474Tcl_Obj* 5475Tcl_FSGetTranslatedPath(interp, pathPtr) 5476 Tcl_Interp *interp; 5477 Tcl_Obj* pathPtr; 5478{ 5479 Tcl_Obj *retObj = NULL; 5480 FsPath *srcFsPathPtr; 5481 5482 if (Tcl_FSConvertToPathType(interp, pathPtr) != TCL_OK) { 5483 return NULL; 5484 } 5485 srcFsPathPtr = (FsPath*) PATHOBJ(pathPtr); 5486 if (srcFsPathPtr->translatedPathPtr == NULL) { 5487 if (PATHFLAGS(pathPtr) != 0) { 5488 /* 5489 * We lack a translated path result, but we have a directory 5490 * (cwdPtr) and a tail (normPathPtr), and if we join the 5491 * translated version of cwdPtr to normPathPtr, we'll get the 5492 * translated result we need, and can store it for future use. 5493 */ 5494 5495 Tcl_Obj *translatedCwdPtr = Tcl_FSGetTranslatedPath(interp, 5496 srcFsPathPtr->cwdPtr); 5497 5498 retObj = Tcl_FSJoinToPath(translatedCwdPtr, 1, 5499 &(srcFsPathPtr->normPathPtr)); 5500 srcFsPathPtr->translatedPathPtr = retObj; 5501 Tcl_IncrRefCount(retObj); 5502 Tcl_DecrRefCount(translatedCwdPtr); 5503 } else { 5504 /* 5505 * It is a pure absolute, normalized path object. 5506 * This is something like being a 'pure list'. The 5507 * object's string, translatedPath and normalizedPath 5508 * are all identical. 5509 */ 5510 retObj = srcFsPathPtr->normPathPtr; 5511 } 5512 } else { 5513 /* It is an ordinary path object */ 5514 retObj = srcFsPathPtr->translatedPathPtr; 5515 } 5516 5517 if (retObj) { 5518 Tcl_IncrRefCount(retObj); 5519 } 5520 return retObj; 5521} 5522 5523/* 5524 *--------------------------------------------------------------------------- 5525 * 5526 * Tcl_FSGetTranslatedStringPath -- 5527 * 5528 * This function attempts to extract the translated path 5529 * from the given Tcl_Obj. If the translation succeeds (i.e. the 5530 * object is a valid path), then the path is returned. Otherwise NULL 5531 * will be returned, and an error message may be left in the 5532 * interpreter (if it is non-NULL) 5533 * 5534 * Results: 5535 * NULL or a valid string. 5536 * 5537 * Side effects: 5538 * Only those of 'Tcl_FSConvertToPathType' 5539 * 5540 *--------------------------------------------------------------------------- 5541 */ 5542CONST char* 5543Tcl_FSGetTranslatedStringPath(interp, pathPtr) 5544 Tcl_Interp *interp; 5545 Tcl_Obj* pathPtr; 5546{ 5547 Tcl_Obj *transPtr = Tcl_FSGetTranslatedPath(interp, pathPtr); 5548 5549 if (transPtr != NULL) { 5550 int len; 5551 CONST char *result, *orig; 5552 orig = Tcl_GetStringFromObj(transPtr, &len); 5553 result = (char*) ckalloc((unsigned)(len+1)); 5554 memcpy((VOID*) result, (VOID*) orig, (size_t) (len+1)); 5555 Tcl_DecrRefCount(transPtr); 5556 return result; 5557 } 5558 5559 return NULL; 5560} 5561 5562/* 5563 *--------------------------------------------------------------------------- 5564 * 5565 * Tcl_FSGetNormalizedPath -- 5566 * 5567 * This important function attempts to extract from the given Tcl_Obj 5568 * a unique normalised path representation, whose string value can 5569 * be used as a unique identifier for the file. 5570 * 5571 * Results: 5572 * NULL or a valid path object pointer. 5573 * 5574 * Side effects: 5575 * New memory may be allocated. The Tcl 'errno' may be modified 5576 * in the process of trying to examine various path possibilities. 5577 * 5578 *--------------------------------------------------------------------------- 5579 */ 5580 5581Tcl_Obj* 5582Tcl_FSGetNormalizedPath(interp, pathObjPtr) 5583 Tcl_Interp *interp; 5584 Tcl_Obj* pathObjPtr; 5585{ 5586 FsPath *fsPathPtr; 5587 5588 if (Tcl_FSConvertToPathType(interp, pathObjPtr) != TCL_OK) { 5589 return NULL; 5590 } 5591 fsPathPtr = (FsPath*) PATHOBJ(pathObjPtr); 5592 5593 if (PATHFLAGS(pathObjPtr) != 0) { 5594 /* 5595 * This is a special path object which is the result of 5596 * something like 'file join' 5597 */ 5598 Tcl_Obj *dir, *copy; 5599 int cwdLen; 5600 int pathType; 5601 CONST char *cwdStr; 5602 ClientData clientData = NULL; 5603 5604 pathType = Tcl_FSGetPathType(fsPathPtr->cwdPtr); 5605 dir = Tcl_FSGetNormalizedPath(interp, fsPathPtr->cwdPtr); 5606 if (dir == NULL) { 5607 return NULL; 5608 } 5609 if (pathObjPtr->bytes == NULL) { 5610 UpdateStringOfFsPath(pathObjPtr); 5611 } 5612 copy = Tcl_DuplicateObj(dir); 5613 Tcl_IncrRefCount(copy); 5614 Tcl_IncrRefCount(dir); 5615 /* We now own a reference on both 'dir' and 'copy' */ 5616 5617 cwdStr = Tcl_GetStringFromObj(copy, &cwdLen); 5618 /* 5619 * Should we perhaps use 'Tcl_FSPathSeparator'? 5620 * But then what about the Windows special case? 5621 * Perhaps we should just check if cwd is a root volume. 5622 * We should never get cwdLen == 0 in this code path. 5623 */ 5624 switch (tclPlatform) { 5625 case TCL_PLATFORM_UNIX: 5626 if (cwdStr[cwdLen-1] != '/') { 5627 Tcl_AppendToObj(copy, "/", 1); 5628 cwdLen++; 5629 } 5630 break; 5631 case TCL_PLATFORM_WINDOWS: 5632 if (cwdStr[cwdLen-1] != '/' 5633 && cwdStr[cwdLen-1] != '\\') { 5634 Tcl_AppendToObj(copy, "/", 1); 5635 cwdLen++; 5636 } 5637 break; 5638 case TCL_PLATFORM_MAC: 5639 if (cwdStr[cwdLen-1] != ':') { 5640 Tcl_AppendToObj(copy, ":", 1); 5641 cwdLen++; 5642 } 5643 break; 5644 } 5645 Tcl_AppendObjToObj(copy, fsPathPtr->normPathPtr); 5646 5647 /* Normalize the combined string. */ 5648 5649 if (PATHFLAGS(pathObjPtr) & TCLPATH_NEEDNORM) { 5650 /* 5651 * If the "tail" part has components (like /../) that cause 5652 * the combined path to need more complete normalizing, 5653 * call on the more powerful routine to accomplish that so 5654 * we avoid [Bug 2385549] ... 5655 */ 5656 5657 Tcl_Obj *newCopy = TclFSNormalizeAbsolutePath(interp, copy, NULL); 5658 Tcl_DecrRefCount(copy); 5659 copy = newCopy; 5660 } else { 5661 /* 5662 * ... but in most cases where we join a trouble free tail 5663 * to a normalized head, we can more efficiently normalize the 5664 * combined path by passing over only the unnormalized tail 5665 * portion. When this is sufficient, prior developers claim 5666 * this should be much faster. We use 'cwdLen-1' so that we are 5667 * already pointing at the dir-separator that we know about. 5668 * The normalization code will actually start off directly 5669 * after that separator. 5670 */ 5671 5672 TclFSNormalizeToUniquePath(interp, copy, cwdLen-1, 5673 (fsPathPtr->nativePathPtr == NULL ? &clientData : NULL)); 5674 } 5675 5676 /* Now we need to construct the new path object */ 5677 5678 if (pathType == TCL_PATH_RELATIVE) { 5679 FsPath* origDirFsPathPtr; 5680 Tcl_Obj *origDir = fsPathPtr->cwdPtr; 5681 origDirFsPathPtr = (FsPath*) PATHOBJ(origDir); 5682 5683 fsPathPtr->cwdPtr = origDirFsPathPtr->cwdPtr; 5684 Tcl_IncrRefCount(fsPathPtr->cwdPtr); 5685 5686 Tcl_DecrRefCount(fsPathPtr->normPathPtr); 5687 fsPathPtr->normPathPtr = copy; 5688 /* That's our reference to copy used */ 5689 Tcl_DecrRefCount(dir); 5690 Tcl_DecrRefCount(origDir); 5691 } else { 5692 Tcl_DecrRefCount(fsPathPtr->cwdPtr); 5693 fsPathPtr->cwdPtr = NULL; 5694 Tcl_DecrRefCount(fsPathPtr->normPathPtr); 5695 fsPathPtr->normPathPtr = copy; 5696 /* That's our reference to copy used */ 5697 Tcl_DecrRefCount(dir); 5698 } 5699 if (clientData != NULL) { 5700 /* 5701 * This may be unnecessary. It appears that the 5702 * TclFSNormalizeToUniquePath call above should have already 5703 * set this up. Not changing out of fear of the unknown. 5704 */ 5705 fsPathPtr->nativePathPtr = clientData; 5706 } 5707 PATHFLAGS(pathObjPtr) = 0; 5708 } 5709 /* Ensure cwd hasn't changed */ 5710 if (fsPathPtr->cwdPtr != NULL) { 5711 if (!TclFSCwdPointerEquals(fsPathPtr->cwdPtr)) { 5712 if (pathObjPtr->bytes == NULL) { 5713 UpdateStringOfFsPath(pathObjPtr); 5714 } 5715 FreeFsPathInternalRep(pathObjPtr); 5716 pathObjPtr->typePtr = NULL; 5717 if (Tcl_ConvertToType(interp, pathObjPtr, 5718 &tclFsPathType) != TCL_OK) { 5719 return NULL; 5720 } 5721 fsPathPtr = (FsPath*) PATHOBJ(pathObjPtr); 5722 } else if (fsPathPtr->normPathPtr == NULL) { 5723 int cwdLen; 5724 Tcl_Obj *copy; 5725 CONST char *cwdStr; 5726 ClientData clientData = NULL; 5727 5728 copy = Tcl_DuplicateObj(fsPathPtr->cwdPtr); 5729 Tcl_IncrRefCount(copy); 5730 cwdStr = Tcl_GetStringFromObj(copy, &cwdLen); 5731 /* 5732 * Should we perhaps use 'Tcl_FSPathSeparator'? 5733 * But then what about the Windows special case? 5734 * Perhaps we should just check if cwd is a root volume. 5735 * We should never get cwdLen == 0 in this code path. 5736 */ 5737 switch (tclPlatform) { 5738 case TCL_PLATFORM_UNIX: 5739 if (cwdStr[cwdLen-1] != '/') { 5740 Tcl_AppendToObj(copy, "/", 1); 5741 cwdLen++; 5742 } 5743 break; 5744 case TCL_PLATFORM_WINDOWS: 5745 if (cwdStr[cwdLen-1] != '/' 5746 && cwdStr[cwdLen-1] != '\\') { 5747 Tcl_AppendToObj(copy, "/", 1); 5748 cwdLen++; 5749 } 5750 break; 5751 case TCL_PLATFORM_MAC: 5752 if (cwdStr[cwdLen-1] != ':') { 5753 Tcl_AppendToObj(copy, ":", 1); 5754 cwdLen++; 5755 } 5756 break; 5757 } 5758 Tcl_AppendObjToObj(copy, pathObjPtr); 5759 /* 5760 * Normalize the combined string, but only starting after 5761 * the end of the previously normalized 'dir'. This should 5762 * be much faster! 5763 */ 5764 TclFSNormalizeToUniquePath(interp, copy, cwdLen-1, 5765 (fsPathPtr->nativePathPtr == NULL ? &clientData : NULL)); 5766 fsPathPtr->normPathPtr = copy; 5767 if (clientData != NULL) { 5768 fsPathPtr->nativePathPtr = clientData; 5769 } 5770 } 5771 } 5772 if (fsPathPtr->normPathPtr == NULL) { 5773 ClientData clientData = NULL; 5774 Tcl_Obj *useThisCwd = NULL; 5775 /* 5776 * Since normPathPtr is NULL, but this is a valid path 5777 * object, we know that the translatedPathPtr cannot be NULL. 5778 */ 5779 Tcl_Obj *absolutePath = fsPathPtr->translatedPathPtr; 5780 char *path = Tcl_GetString(absolutePath); 5781 5782 /* 5783 * We have to be a little bit careful here to avoid infinite loops 5784 * we're asking Tcl_FSGetPathType to return the path's type, but 5785 * that call can actually result in a lot of other filesystem 5786 * action, which might loop back through here. 5787 */ 5788 if (path[0] != '\0') { 5789 Tcl_PathType type = Tcl_FSGetPathType(pathObjPtr); 5790 if (type == TCL_PATH_RELATIVE) { 5791 useThisCwd = Tcl_FSGetCwd(interp); 5792 5793 if (useThisCwd == NULL) return NULL; 5794 5795 absolutePath = Tcl_FSJoinToPath(useThisCwd, 1, &absolutePath); 5796 Tcl_IncrRefCount(absolutePath); 5797 /* We have a refCount on the cwd */ 5798#ifdef __WIN32__ 5799 } else if (type == TCL_PATH_VOLUME_RELATIVE) { 5800 /* 5801 * Only Windows has volume-relative paths. These 5802 * paths are rather rare, but is is nice if Tcl can 5803 * handle them. It is much better if we can 5804 * handle them here, rather than in the native fs code, 5805 * because we really need to have a real absolute path 5806 * just below. 5807 * 5808 * We do not let this block compile on non-Windows 5809 * platforms because the test suite's manual forcing 5810 * of tclPlatform can otherwise cause this code path 5811 * to be executed, causing various errors because 5812 * volume-relative paths really do not exist. 5813 */ 5814 useThisCwd = Tcl_FSGetCwd(interp); 5815 if (useThisCwd == NULL) return NULL; 5816 5817 if (path[0] == '/') { 5818 /* 5819 * Path of form /foo/bar which is a path in the 5820 * root directory of the current volume. 5821 */ 5822 CONST char *drive = Tcl_GetString(useThisCwd); 5823 absolutePath = Tcl_NewStringObj(drive,2); 5824 Tcl_AppendToObj(absolutePath, path, -1); 5825 Tcl_IncrRefCount(absolutePath); 5826 /* We have a refCount on the cwd */ 5827 } else { 5828 /* 5829 * Path of form C:foo/bar, but this only makes 5830 * sense if the cwd is also on drive C. 5831 */ 5832 CONST char *drive = Tcl_GetString(useThisCwd); 5833 char drive_c = path[0]; 5834 if (drive_c >= 'a') { 5835 drive_c -= ('a' - 'A'); 5836 } 5837 if (drive[0] == drive_c) { 5838 absolutePath = Tcl_DuplicateObj(useThisCwd); 5839 /* We have a refCount on the cwd */ 5840 } else { 5841 Tcl_DecrRefCount(useThisCwd); 5842 useThisCwd = NULL; 5843 /* 5844 * The path is not in the current drive, but 5845 * is volume-relative. The way Tcl 8.3 handles 5846 * this is that it treats such a path as 5847 * relative to the root of the drive. We 5848 * therefore behave the same here. 5849 */ 5850 absolutePath = Tcl_NewStringObj(path, 2); 5851 } 5852 Tcl_IncrRefCount(absolutePath); 5853 Tcl_AppendToObj(absolutePath, "/", 1); 5854 Tcl_AppendToObj(absolutePath, path+2, -1); 5855 } 5856#endif /* __WIN32__ */ 5857 } 5858 } 5859 /* Already has refCount incremented */ 5860 fsPathPtr->normPathPtr = TclFSNormalizeAbsolutePath(interp, absolutePath, 5861 (fsPathPtr->nativePathPtr == NULL ? &clientData : NULL)); 5862 if (0 && (clientData != NULL)) { 5863 fsPathPtr->nativePathPtr = 5864 (*fsPathPtr->fsRecPtr->fsPtr->dupInternalRepProc)(clientData); 5865 } 5866 if (!strcmp(Tcl_GetString(fsPathPtr->normPathPtr), 5867 Tcl_GetString(pathObjPtr))) { 5868 /* 5869 * The path was already normalized. 5870 * Get rid of the duplicate. 5871 */ 5872 Tcl_DecrRefCount(fsPathPtr->normPathPtr); 5873 /* 5874 * We do *not* increment the refCount for 5875 * this circular reference 5876 */ 5877 fsPathPtr->normPathPtr = pathObjPtr; 5878 } 5879 if (useThisCwd != NULL) { 5880 /* This was returned by Tcl_FSJoinToPath above */ 5881 Tcl_DecrRefCount(absolutePath); 5882 fsPathPtr->cwdPtr = useThisCwd; 5883 } 5884 } 5885 5886 return fsPathPtr->normPathPtr; 5887} 5888 5889/* 5890 *--------------------------------------------------------------------------- 5891 * 5892 * Tcl_FSGetInternalRep -- 5893 * 5894 * Extract the internal representation of a given path object, 5895 * in the given filesystem. If the path object belongs to a 5896 * different filesystem, we return NULL. 5897 * 5898 * If the internal representation is currently NULL, we attempt 5899 * to generate it, by calling the filesystem's 5900 * 'Tcl_FSCreateInternalRepProc'. 5901 * 5902 * Results: 5903 * NULL or a valid internal representation. 5904 * 5905 * Side effects: 5906 * An attempt may be made to convert the object. 5907 * 5908 *--------------------------------------------------------------------------- 5909 */ 5910 5911ClientData 5912Tcl_FSGetInternalRep(pathObjPtr, fsPtr) 5913 Tcl_Obj* pathObjPtr; 5914 Tcl_Filesystem *fsPtr; 5915{ 5916 FsPath *srcFsPathPtr; 5917 5918 if (Tcl_FSConvertToPathType(NULL, pathObjPtr) != TCL_OK) { 5919 return NULL; 5920 } 5921 srcFsPathPtr = (FsPath*) PATHOBJ(pathObjPtr); 5922 5923 /* 5924 * We will only return the native representation for the caller's 5925 * filesystem. Otherwise we will simply return NULL. This means 5926 * that there must be a unique bi-directional mapping between paths 5927 * and filesystems, and that this mapping will not allow 'remapped' 5928 * files -- files which are in one filesystem but mapped into 5929 * another. Another way of putting this is that 'stacked' 5930 * filesystems are not allowed. We recognise that this is a 5931 * potentially useful feature for the future. 5932 * 5933 * Even something simple like a 'pass through' filesystem which 5934 * logs all activity and passes the calls onto the native system 5935 * would be nice, but not easily achievable with the current 5936 * implementation. 5937 */ 5938 if (srcFsPathPtr->fsRecPtr == NULL) { 5939 /* 5940 * This only usually happens in wrappers like TclpStat which 5941 * create a string object and pass it to TclpObjStat. Code 5942 * which calls the Tcl_FS.. functions should always have a 5943 * filesystem already set. Whether this code path is legal or 5944 * not depends on whether we decide to allow external code to 5945 * call the native filesystem directly. It is at least safer 5946 * to allow this sub-optimal routing. 5947 */ 5948 Tcl_FSGetFileSystemForPath(pathObjPtr); 5949 5950 /* 5951 * If we fail through here, then the path is probably not a 5952 * valid path in the filesystsem, and is most likely to be a 5953 * use of the empty path "" via a direct call to one of the 5954 * objectified interfaces (e.g. from the Tcl testsuite). 5955 */ 5956 srcFsPathPtr = (FsPath*) PATHOBJ(pathObjPtr); 5957 if (srcFsPathPtr->fsRecPtr == NULL) { 5958 return NULL; 5959 } 5960 } 5961 5962 if (fsPtr != srcFsPathPtr->fsRecPtr->fsPtr) { 5963 /* 5964 * There is still one possibility we should consider; if the 5965 * file belongs to a different filesystem, perhaps it is 5966 * actually linked through to a file in our own filesystem 5967 * which we do care about. The way we can check for this 5968 * is we ask what filesystem this path belongs to. 5969 */ 5970 Tcl_Filesystem *actualFs = Tcl_FSGetFileSystemForPath(pathObjPtr); 5971 if (actualFs == fsPtr) { 5972 return Tcl_FSGetInternalRep(pathObjPtr, fsPtr); 5973 } 5974 return NULL; 5975 } 5976 5977 if (srcFsPathPtr->nativePathPtr == NULL) { 5978 Tcl_FSCreateInternalRepProc *proc; 5979 char *nativePathPtr; 5980 5981 proc = srcFsPathPtr->fsRecPtr->fsPtr->createInternalRepProc; 5982 if (proc == NULL) { 5983 return NULL; 5984 } 5985 5986 nativePathPtr = (*proc)(pathObjPtr); 5987 srcFsPathPtr = (FsPath*) PATHOBJ(pathObjPtr); 5988 srcFsPathPtr->nativePathPtr = nativePathPtr; 5989 } 5990 5991 return srcFsPathPtr->nativePathPtr; 5992} 5993 5994/* 5995 *--------------------------------------------------------------------------- 5996 * 5997 * TclFSEnsureEpochOk -- 5998 * 5999 * This will ensure the pathObjPtr is up to date and can be 6000 * converted into a "path" type, and that we are able to generate a 6001 * complete normalized path which is used to determine the 6002 * filesystem match. 6003 * 6004 * Results: 6005 * Standard Tcl return code. 6006 * 6007 * Side effects: 6008 * An attempt may be made to convert the object. 6009 * 6010 *--------------------------------------------------------------------------- 6011 */ 6012 6013int 6014TclFSEnsureEpochOk(pathObjPtr, fsPtrPtr) 6015 Tcl_Obj* pathObjPtr; 6016 Tcl_Filesystem **fsPtrPtr; 6017{ 6018 FsPath *srcFsPathPtr; 6019 ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey); 6020 6021 /* 6022 * SHOULD BE ABLE TO IMPROVE EFFICIENCY HERE. 6023 */ 6024 6025 if (Tcl_FSGetNormalizedPath(NULL, pathObjPtr) == NULL) { 6026 return TCL_ERROR; 6027 } 6028 6029 srcFsPathPtr = (FsPath*) PATHOBJ(pathObjPtr); 6030 6031 /* 6032 * Check if the filesystem has changed in some way since 6033 * this object's internal representation was calculated. 6034 */ 6035 if (srcFsPathPtr->filesystemEpoch != tsdPtr->filesystemEpoch) { 6036 /* 6037 * We have to discard the stale representation and 6038 * recalculate it 6039 */ 6040 if (pathObjPtr->bytes == NULL) { 6041 UpdateStringOfFsPath(pathObjPtr); 6042 } 6043 FreeFsPathInternalRep(pathObjPtr); 6044 pathObjPtr->typePtr = NULL; 6045 if (SetFsPathFromAny(NULL, pathObjPtr) != TCL_OK) { 6046 return TCL_ERROR; 6047 } 6048 srcFsPathPtr = (FsPath*) PATHOBJ(pathObjPtr); 6049 } 6050 /* Check whether the object is already assigned to a fs */ 6051 if (srcFsPathPtr->fsRecPtr != NULL) { 6052 *fsPtrPtr = srcFsPathPtr->fsRecPtr->fsPtr; 6053 } 6054 6055 return TCL_OK; 6056} 6057 6058void 6059TclFSSetPathDetails(pathObjPtr, fsRecPtr, clientData) 6060 Tcl_Obj *pathObjPtr; 6061 FilesystemRecord *fsRecPtr; 6062 ClientData clientData; 6063{ 6064 ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey); 6065 /* We assume pathObjPtr is already of the correct type */ 6066 FsPath *srcFsPathPtr; 6067 6068 srcFsPathPtr = (FsPath*) PATHOBJ(pathObjPtr); 6069 srcFsPathPtr->fsRecPtr = fsRecPtr; 6070 srcFsPathPtr->nativePathPtr = clientData; 6071 srcFsPathPtr->filesystemEpoch = tsdPtr->filesystemEpoch; 6072 fsRecPtr->fileRefCount++; 6073} 6074 6075/* 6076 *--------------------------------------------------------------------------- 6077 * 6078 * Tcl_FSEqualPaths -- 6079 * 6080 * This function tests whether the two paths given are equal path 6081 * objects. If either or both is NULL, 0 is always returned. 6082 * 6083 * Results: 6084 * 1 or 0. 6085 * 6086 * Side effects: 6087 * None. 6088 * 6089 *--------------------------------------------------------------------------- 6090 */ 6091 6092int 6093Tcl_FSEqualPaths(firstPtr, secondPtr) 6094 Tcl_Obj* firstPtr; 6095 Tcl_Obj* secondPtr; 6096{ 6097 if (firstPtr == secondPtr) { 6098 return 1; 6099 } else { 6100 char *firstStr, *secondStr; 6101 int firstLen, secondLen, tempErrno; 6102 6103 if (firstPtr == NULL || secondPtr == NULL) { 6104 return 0; 6105 } 6106 firstStr = Tcl_GetStringFromObj(firstPtr, &firstLen); 6107 secondStr = Tcl_GetStringFromObj(secondPtr, &secondLen); 6108 if ((firstLen == secondLen) && (strcmp(firstStr, secondStr) == 0)) { 6109 return 1; 6110 } 6111 /* 6112 * Try the most thorough, correct method of comparing fully 6113 * normalized paths 6114 */ 6115 6116 tempErrno = Tcl_GetErrno(); 6117 firstPtr = Tcl_FSGetNormalizedPath(NULL, firstPtr); 6118 secondPtr = Tcl_FSGetNormalizedPath(NULL, secondPtr); 6119 Tcl_SetErrno(tempErrno); 6120 6121 if (firstPtr == NULL || secondPtr == NULL) { 6122 return 0; 6123 } 6124 firstStr = Tcl_GetStringFromObj(firstPtr, &firstLen); 6125 secondStr = Tcl_GetStringFromObj(secondPtr, &secondLen); 6126 if ((firstLen == secondLen) && (strcmp(firstStr, secondStr) == 0)) { 6127 return 1; 6128 } 6129 } 6130 6131 return 0; 6132} 6133 6134/* 6135 *--------------------------------------------------------------------------- 6136 * 6137 * SetFsPathFromAny -- 6138 * 6139 * This function tries to convert the given Tcl_Obj to a valid 6140 * Tcl path type. 6141 * 6142 * The filename may begin with "~" (to indicate current user's 6143 * home directory) or "~<user>" (to indicate any user's home 6144 * directory). 6145 * 6146 * Results: 6147 * Standard Tcl error code. 6148 * 6149 * Side effects: 6150 * The old representation may be freed, and new memory allocated. 6151 * 6152 *--------------------------------------------------------------------------- 6153 */ 6154 6155static int 6156SetFsPathFromAny(interp, objPtr) 6157 Tcl_Interp *interp; /* Used for error reporting if not NULL. */ 6158 Tcl_Obj *objPtr; /* The object to convert. */ 6159{ 6160 int len; 6161 FsPath *fsPathPtr; 6162 Tcl_Obj *transPtr; 6163 char *name; 6164 ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey); 6165 6166 if (objPtr->typePtr == &tclFsPathType) { 6167 return TCL_OK; 6168 } 6169 6170 /* 6171 * First step is to translate the filename. This is similar to 6172 * Tcl_TranslateFilename, but shouldn't convert everything to 6173 * windows backslashes on that platform. The current 6174 * implementation of this piece is a slightly optimised version 6175 * of the various Tilde/Split/Join stuff to avoid multiple 6176 * split/join operations. 6177 * 6178 * We remove any trailing directory separator. 6179 * 6180 * However, the split/join routines are quite complex, and 6181 * one has to make sure not to break anything on Unix, Win 6182 * or MacOS (fCmd.test, fileName.test and cmdAH.test exercise 6183 * most of the code). 6184 */ 6185 name = Tcl_GetStringFromObj(objPtr,&len); 6186 6187 /* 6188 * Handle tilde substitutions, if needed. 6189 */ 6190 if (name[0] == '~') { 6191 char *expandedUser; 6192 Tcl_DString temp; 6193 int split; 6194 char separator='/'; 6195 6196 if (tclPlatform==TCL_PLATFORM_MAC) { 6197 if (strchr(name, ':') != NULL) separator = ':'; 6198 } 6199 6200 split = FindSplitPos(name, &separator); 6201 if (split != len) { 6202 /* We have multiple pieces '~user/foo/bar...' */ 6203 name[split] = '\0'; 6204 } 6205 /* Do some tilde substitution */ 6206 if (name[1] == '\0') { 6207 /* We have just '~' */ 6208 CONST char *dir; 6209 Tcl_DString dirString; 6210 if (split != len) { name[split] = separator; } 6211 6212 dir = TclGetEnv("HOME", &dirString); 6213 if (dir == NULL) { 6214 if (interp) { 6215 Tcl_ResetResult(interp); 6216 Tcl_AppendResult(interp, "couldn't find HOME environment ", 6217 "variable to expand path", (char *) NULL); 6218 } 6219 return TCL_ERROR; 6220 } 6221 Tcl_DStringInit(&temp); 6222 Tcl_JoinPath(1, &dir, &temp); 6223 Tcl_DStringFree(&dirString); 6224 } else { 6225 /* We have a user name '~user' */ 6226 Tcl_DStringInit(&temp); 6227 if (TclpGetUserHome(name+1, &temp) == NULL) { 6228 if (interp != NULL) { 6229 Tcl_ResetResult(interp); 6230 Tcl_AppendResult(interp, "user \"", (name+1), 6231 "\" doesn't exist", (char *) NULL); 6232 } 6233 Tcl_DStringFree(&temp); 6234 if (split != len) { name[split] = separator; } 6235 return TCL_ERROR; 6236 } 6237 if (split != len) { name[split] = separator; } 6238 } 6239 6240 expandedUser = Tcl_DStringValue(&temp); 6241 transPtr = Tcl_NewStringObj(expandedUser, Tcl_DStringLength(&temp)); 6242 6243 if (split != len) { 6244 /* Join up the tilde substitution with the rest */ 6245 if (name[split+1] == separator) { 6246 6247 /* 6248 * Somewhat tricky case like ~//foo/bar. 6249 * Make use of Split/Join machinery to get it right. 6250 * Assumes all paths beginning with ~ are part of the 6251 * native filesystem. 6252 */ 6253 6254 int objc; 6255 Tcl_Obj **objv; 6256 Tcl_Obj *parts = TclpNativeSplitPath(objPtr, NULL); 6257 Tcl_ListObjGetElements(NULL, parts, &objc, &objv); 6258 /* Skip '~'. It's replaced by its expansion */ 6259 objc--; objv++; 6260 while (objc--) { 6261 TclpNativeJoinPath(transPtr, Tcl_GetString(*objv++)); 6262 } 6263 Tcl_DecrRefCount(parts); 6264 } else { 6265 /* Simple case. "rest" is relative path. Just join it. */ 6266 Tcl_Obj *rest = Tcl_NewStringObj(name+split+1,-1); 6267 transPtr = Tcl_FSJoinToPath(transPtr, 1, &rest); 6268 } 6269 } 6270 Tcl_DStringFree(&temp); 6271 } else { 6272 transPtr = Tcl_FSJoinToPath(objPtr,0,NULL); 6273 } 6274 6275#if defined(__CYGWIN__) && defined(__WIN32__) 6276 { 6277 extern int cygwin_conv_to_win32_path 6278 _ANSI_ARGS_((CONST char *, char *)); 6279 char winbuf[MAX_PATH+1]; 6280 6281 /* 6282 * In the Cygwin world, call conv_to_win32_path in order to use the 6283 * mount table to translate the file name into something Windows will 6284 * understand. Take care when converting empty strings! 6285 */ 6286 name = Tcl_GetStringFromObj(transPtr, &len); 6287 if (len > 0) { 6288 cygwin_conv_to_win32_path(name, winbuf); 6289 TclWinNoBackslash(winbuf); 6290 Tcl_SetStringObj(transPtr, winbuf, -1); 6291 } 6292 } 6293#endif /* __CYGWIN__ && __WIN32__ */ 6294 6295 /* 6296 * Now we have a translated filename in 'transPtr'. This will have 6297 * forward slashes on Windows, and will not contain any ~user 6298 * sequences. 6299 */ 6300 6301 fsPathPtr = (FsPath*)ckalloc((unsigned)sizeof(FsPath)); 6302 6303 fsPathPtr->translatedPathPtr = transPtr; 6304 Tcl_IncrRefCount(fsPathPtr->translatedPathPtr); 6305 fsPathPtr->normPathPtr = NULL; 6306 fsPathPtr->cwdPtr = NULL; 6307 fsPathPtr->nativePathPtr = NULL; 6308 fsPathPtr->fsRecPtr = NULL; 6309 fsPathPtr->filesystemEpoch = tsdPtr->filesystemEpoch; 6310 6311 /* 6312 * Free old representation before installing our new one. 6313 */ 6314 if (objPtr->typePtr != NULL && objPtr->typePtr->freeIntRepProc != NULL) { 6315 (objPtr->typePtr->freeIntRepProc)(objPtr); 6316 } 6317 PATHOBJ(objPtr) = (VOID *) fsPathPtr; 6318 PATHFLAGS(objPtr) = 0; 6319 objPtr->typePtr = &tclFsPathType; 6320 6321 return TCL_OK; 6322} 6323 6324static void 6325FreeFsPathInternalRep(pathObjPtr) 6326 Tcl_Obj *pathObjPtr; /* Path object with internal rep to free. */ 6327{ 6328 FsPath *fsPathPtr = (FsPath*) PATHOBJ(pathObjPtr); 6329 6330 if (fsPathPtr->translatedPathPtr != NULL) { 6331 if (fsPathPtr->translatedPathPtr != pathObjPtr) { 6332 Tcl_DecrRefCount(fsPathPtr->translatedPathPtr); 6333 } 6334 } 6335 if (fsPathPtr->normPathPtr != NULL) { 6336 if (fsPathPtr->normPathPtr != pathObjPtr) { 6337 Tcl_DecrRefCount(fsPathPtr->normPathPtr); 6338 } 6339 fsPathPtr->normPathPtr = NULL; 6340 } 6341 if (fsPathPtr->cwdPtr != NULL) { 6342 Tcl_DecrRefCount(fsPathPtr->cwdPtr); 6343 } 6344 if (fsPathPtr->nativePathPtr != NULL) { 6345 if (fsPathPtr->fsRecPtr != NULL) { 6346 if (fsPathPtr->fsRecPtr->fsPtr->freeInternalRepProc != NULL) { 6347 (*fsPathPtr->fsRecPtr->fsPtr 6348 ->freeInternalRepProc)(fsPathPtr->nativePathPtr); 6349 fsPathPtr->nativePathPtr = NULL; 6350 } 6351 } 6352 } 6353 if (fsPathPtr->fsRecPtr != NULL) { 6354 fsPathPtr->fsRecPtr->fileRefCount--; 6355 if (fsPathPtr->fsRecPtr->fileRefCount <= 0) { 6356 /* It has been unregistered already, so simply free it */ 6357 ckfree((char *)fsPathPtr->fsRecPtr); 6358 } 6359 } 6360 6361 ckfree((char*) fsPathPtr); 6362} 6363 6364 6365static void 6366DupFsPathInternalRep(srcPtr, copyPtr) 6367 Tcl_Obj *srcPtr; /* Path obj with internal rep to copy. */ 6368 Tcl_Obj *copyPtr; /* Path obj with internal rep to set. */ 6369{ 6370 FsPath *srcFsPathPtr = (FsPath*) PATHOBJ(srcPtr); 6371 FsPath *copyFsPathPtr = (FsPath*) ckalloc((unsigned)sizeof(FsPath)); 6372 6373 Tcl_FSDupInternalRepProc *dupProc; 6374 6375 PATHOBJ(copyPtr) = (VOID *) copyFsPathPtr; 6376 6377 if (srcFsPathPtr->translatedPathPtr != NULL) { 6378 copyFsPathPtr->translatedPathPtr = srcFsPathPtr->translatedPathPtr; 6379 if (copyFsPathPtr->translatedPathPtr != copyPtr) { 6380 Tcl_IncrRefCount(copyFsPathPtr->translatedPathPtr); 6381 } 6382 } else { 6383 copyFsPathPtr->translatedPathPtr = NULL; 6384 } 6385 6386 if (srcFsPathPtr->normPathPtr != NULL) { 6387 copyFsPathPtr->normPathPtr = srcFsPathPtr->normPathPtr; 6388 if (copyFsPathPtr->normPathPtr != copyPtr) { 6389 Tcl_IncrRefCount(copyFsPathPtr->normPathPtr); 6390 } 6391 } else { 6392 copyFsPathPtr->normPathPtr = NULL; 6393 } 6394 6395 if (srcFsPathPtr->cwdPtr != NULL) { 6396 copyFsPathPtr->cwdPtr = srcFsPathPtr->cwdPtr; 6397 Tcl_IncrRefCount(copyFsPathPtr->cwdPtr); 6398 } else { 6399 copyFsPathPtr->cwdPtr = NULL; 6400 } 6401 6402 copyFsPathPtr->flags = srcFsPathPtr->flags; 6403 6404 if (srcFsPathPtr->fsRecPtr != NULL 6405 && srcFsPathPtr->nativePathPtr != NULL) { 6406 dupProc = srcFsPathPtr->fsRecPtr->fsPtr->dupInternalRepProc; 6407 if (dupProc != NULL) { 6408 copyFsPathPtr->nativePathPtr = 6409 (*dupProc)(srcFsPathPtr->nativePathPtr); 6410 } else { 6411 copyFsPathPtr->nativePathPtr = NULL; 6412 } 6413 } else { 6414 copyFsPathPtr->nativePathPtr = NULL; 6415 } 6416 copyFsPathPtr->fsRecPtr = srcFsPathPtr->fsRecPtr; 6417 copyFsPathPtr->filesystemEpoch = srcFsPathPtr->filesystemEpoch; 6418 if (copyFsPathPtr->fsRecPtr != NULL) { 6419 copyFsPathPtr->fsRecPtr->fileRefCount++; 6420 } 6421 6422 copyPtr->typePtr = &tclFsPathType; 6423} 6424 6425/* 6426 *--------------------------------------------------------------------------- 6427 * 6428 * UpdateStringOfFsPath -- 6429 * 6430 * Gives an object a valid string rep. 6431 * 6432 * Results: 6433 * None. 6434 * 6435 * Side effects: 6436 * Memory may be allocated. 6437 * 6438 *--------------------------------------------------------------------------- 6439 */ 6440 6441static void 6442UpdateStringOfFsPath(objPtr) 6443 register Tcl_Obj *objPtr; /* path obj with string rep to update. */ 6444{ 6445 FsPath *fsPathPtr = (FsPath*) PATHOBJ(objPtr); 6446 CONST char *cwdStr; 6447 int cwdLen; 6448 Tcl_Obj *copy; 6449 6450 if (PATHFLAGS(objPtr) == 0 || fsPathPtr->cwdPtr == NULL) { 6451 panic("Called UpdateStringOfFsPath with invalid object"); 6452 } 6453 6454 copy = Tcl_DuplicateObj(fsPathPtr->cwdPtr); 6455 Tcl_IncrRefCount(copy); 6456 6457 cwdStr = Tcl_GetStringFromObj(copy, &cwdLen); 6458 /* 6459 * Should we perhaps use 'Tcl_FSPathSeparator'? 6460 * But then what about the Windows special case? 6461 * Perhaps we should just check if cwd is a root volume. 6462 * We should never get cwdLen == 0 in this code path. 6463 */ 6464 switch (tclPlatform) { 6465 case TCL_PLATFORM_UNIX: 6466 if (cwdStr[cwdLen-1] != '/') { 6467 Tcl_AppendToObj(copy, "/", 1); 6468 cwdLen++; 6469 } 6470 break; 6471 case TCL_PLATFORM_WINDOWS: 6472 /* 6473 * We need the extra 'cwdLen != 2', and ':' checks because 6474 * a volume relative path doesn't get a '/'. For example 6475 * 'glob C:*cat*.exe' will return 'C:cat32.exe' 6476 */ 6477 if (cwdStr[cwdLen-1] != '/' 6478 && cwdStr[cwdLen-1] != '\\') { 6479 if (cwdLen != 2 || cwdStr[1] != ':') { 6480 Tcl_AppendToObj(copy, "/", 1); 6481 cwdLen++; 6482 } 6483 } 6484 break; 6485 case TCL_PLATFORM_MAC: 6486 if (cwdStr[cwdLen-1] != ':') { 6487 Tcl_AppendToObj(copy, ":", 1); 6488 cwdLen++; 6489 } 6490 break; 6491 } 6492 Tcl_AppendObjToObj(copy, fsPathPtr->normPathPtr); 6493 objPtr->bytes = Tcl_GetStringFromObj(copy, &cwdLen); 6494 objPtr->length = cwdLen; 6495 copy->bytes = tclEmptyStringRep; 6496 copy->length = 0; 6497 Tcl_DecrRefCount(copy); 6498} 6499 6500/* 6501 *--------------------------------------------------------------------------- 6502 * 6503 * NativePathInFilesystem -- 6504 * 6505 * Any path object is acceptable to the native filesystem, by 6506 * default (we will throw errors when illegal paths are actually 6507 * tried to be used). 6508 * 6509 * However, this behavior means the native filesystem must be 6510 * the last filesystem in the lookup list (otherwise it will 6511 * claim all files belong to it, and other filesystems will 6512 * never get a look in). 6513 * 6514 * Results: 6515 * TCL_OK, to indicate 'yes', -1 to indicate no. 6516 * 6517 * Side effects: 6518 * None. 6519 * 6520 *--------------------------------------------------------------------------- 6521 */ 6522static int 6523NativePathInFilesystem(pathPtr, clientDataPtr) 6524 Tcl_Obj *pathPtr; 6525 ClientData *clientDataPtr; 6526{ 6527 /* 6528 * A special case is required to handle the empty path "". 6529 * This is a valid path (i.e. the user should be able 6530 * to do 'file exists ""' without throwing an error), but 6531 * equally the path doesn't exist. Those are the semantics 6532 * of Tcl (at present anyway), so we have to abide by them 6533 * here. 6534 */ 6535 if (pathPtr->typePtr == &tclFsPathType) { 6536 if (pathPtr->bytes != NULL && pathPtr->bytes[0] == '\0') { 6537 /* We reject the empty path "" */ 6538 return -1; 6539 } 6540 /* Otherwise there is no way this path can be empty */ 6541 } else { 6542 /* 6543 * It is somewhat unusual to reach this code path without 6544 * the object being of tclFsPathType. However, we do 6545 * our best to deal with the situation. 6546 */ 6547 int len; 6548 Tcl_GetStringFromObj(pathPtr,&len); 6549 if (len == 0) { 6550 /* We reject the empty path "" */ 6551 return -1; 6552 } 6553 } 6554 /* 6555 * Path is of correct type, or is of non-zero length, 6556 * so we accept it. 6557 */ 6558 return TCL_OK; 6559} 6560