1/* 2 * tclIOUtil.c -- 3 * 4 * This file contains the implementation of Tcl's generic filesystem 5 * code, which supports a pluggable filesystem architecture allowing both 6 * platform specific filesystems and 'virtual filesystems'. All 7 * filesystem access should go through the functions defined in this 8 * file. Most of this code was contributed by Vince Darley. 9 * 10 * Parts of this file are based on code contributed by Karl Lehenbauer, 11 * Mark Diekhans and Peter da Silva. 12 * 13 * Copyright (c) 1991-1994 The Regents of the University of California. 14 * Copyright (c) 1994-1997 Sun Microsystems, Inc. 15 * Copyright (c) 2001-2004 Vincent Darley. 16 * 17 * See the file "license.terms" for information on usage and redistribution of 18 * this file, and for a DISCLAIMER OF ALL WARRANTIES. 19 * 20 * RCS: @(#) $Id: tclIOUtil.c,v 1.151.2.3 2010/09/06 12:57:33 stwo Exp $ 21 */ 22 23#include "tclInt.h" 24#ifdef __WIN32__ 25# include "tclWinInt.h" 26#endif 27#include "tclFileSystem.h" 28 29/* 30 * Prototypes for functions defined later in this file. 31 */ 32 33static FilesystemRecord*FsGetFirstFilesystem(void); 34static void FsThrExitProc(ClientData cd); 35static Tcl_Obj * FsListMounts(Tcl_Obj *pathPtr, const char *pattern); 36static void FsAddMountsToGlobResult(Tcl_Obj *resultPtr, 37 Tcl_Obj *pathPtr, const char *pattern, 38 Tcl_GlobTypeData *types); 39static void FsUpdateCwd(Tcl_Obj *cwdObj, ClientData clientData); 40 41#ifdef TCL_THREADS 42static void FsRecacheFilesystemList(void); 43#endif 44 45/* 46 * These form part of the native filesystem support. They are needed here 47 * because we have a few native filesystem functions (which are the same for 48 * win/unix) in this file. There is no need to place them in tclInt.h, because 49 * they are not (and should not be) used anywhere else. 50 */ 51 52MODULE_SCOPE const char * tclpFileAttrStrings[]; 53MODULE_SCOPE const TclFileAttrProcs tclpFileAttrProcs[]; 54 55/* 56 * The following functions are obsolete string based APIs, and should be 57 * removed in a future release (Tcl 9 would be a good time). 58 */ 59 60 61/* Obsolete */ 62int 63Tcl_Stat( 64 const char *path, /* Path of file to stat (in current CP). */ 65 struct stat *oldStyleBuf) /* Filled with results of stat call. */ 66{ 67 int ret; 68 Tcl_StatBuf buf; 69 Tcl_Obj *pathPtr = Tcl_NewStringObj(path, -1); 70 71 Tcl_IncrRefCount(pathPtr); 72 ret = Tcl_FSStat(pathPtr, &buf); 73 Tcl_DecrRefCount(pathPtr); 74 if (ret != -1) { 75#ifndef TCL_WIDE_INT_IS_LONG 76 Tcl_WideInt tmp1, tmp2, tmp3 = 0; 77# define OUT_OF_RANGE(x) \ 78 (((Tcl_WideInt)(x)) < Tcl_LongAsWide(LONG_MIN) || \ 79 ((Tcl_WideInt)(x)) > Tcl_LongAsWide(LONG_MAX)) 80# define OUT_OF_URANGE(x) \ 81 (((Tcl_WideUInt)(x)) > ((Tcl_WideUInt)ULONG_MAX)) 82 83 /* 84 * Perform the result-buffer overflow check manually. 85 * 86 * Note that ino_t/ino64_t is unsigned... 87 * 88 * Workaround gcc warning of "comparison is always false due to 89 * limited range of data type" by assigning to tmp var of type 90 * Tcl_WideInt. 91 */ 92 93 tmp1 = (Tcl_WideInt) buf.st_ino; 94 tmp2 = (Tcl_WideInt) buf.st_size; 95#ifdef HAVE_STRUCT_STAT_ST_BLOCKS 96 tmp3 = (Tcl_WideInt) buf.st_blocks; 97#endif 98 99 if (OUT_OF_URANGE(tmp1) || OUT_OF_RANGE(tmp2) || OUT_OF_RANGE(tmp3)) { 100#if defined(EFBIG) 101 errno = EFBIG; 102#elif defined(EOVERFLOW) 103 errno = EOVERFLOW; 104#else 105#error "What status should be returned for file size out of range?" 106#endif 107 return -1; 108 } 109 110# undef OUT_OF_RANGE 111# undef OUT_OF_URANGE 112#endif /* !TCL_WIDE_INT_IS_LONG */ 113 114 /* 115 * Copy across all supported fields, with possible type coercions on 116 * those fields that change between the normal and lf64 versions of 117 * the stat structure (on Solaris at least). This is slow when the 118 * structure sizes coincide, but that's what you get for using an 119 * obsolete interface. 120 */ 121 122 oldStyleBuf->st_mode = buf.st_mode; 123 oldStyleBuf->st_ino = (ino_t) buf.st_ino; 124 oldStyleBuf->st_dev = buf.st_dev; 125 oldStyleBuf->st_rdev = buf.st_rdev; 126 oldStyleBuf->st_nlink = buf.st_nlink; 127 oldStyleBuf->st_uid = buf.st_uid; 128 oldStyleBuf->st_gid = buf.st_gid; 129 oldStyleBuf->st_size = (off_t) buf.st_size; 130 oldStyleBuf->st_atime = buf.st_atime; 131 oldStyleBuf->st_mtime = buf.st_mtime; 132 oldStyleBuf->st_ctime = buf.st_ctime; 133#ifdef HAVE_STRUCT_STAT_ST_BLKSIZE 134 oldStyleBuf->st_blksize = buf.st_blksize; 135#endif 136#ifdef HAVE_STRUCT_STAT_ST_BLOCKS 137#ifdef HAVE_BLKCNT_T 138 oldStyleBuf->st_blocks = (blkcnt_t) buf.st_blocks; 139#else 140 oldStyleBuf->st_blocks = (unsigned long) buf.st_blocks; 141#endif 142#endif 143 } 144 return ret; 145} 146 147/* Obsolete */ 148int 149Tcl_Access( 150 const char *path, /* Path of file to access (in current CP). */ 151 int mode) /* Permission setting. */ 152{ 153 int ret; 154 Tcl_Obj *pathPtr = Tcl_NewStringObj(path,-1); 155 156 Tcl_IncrRefCount(pathPtr); 157 ret = Tcl_FSAccess(pathPtr,mode); 158 Tcl_DecrRefCount(pathPtr); 159 160 return ret; 161} 162 163/* Obsolete */ 164Tcl_Channel 165Tcl_OpenFileChannel( 166 Tcl_Interp *interp, /* Interpreter for error reporting; can be 167 * NULL. */ 168 const char *path, /* Name of file to open. */ 169 const char *modeString, /* A list of POSIX open modes or a string such 170 * as "rw". */ 171 int permissions) /* If the open involves creating a file, with 172 * what modes to create it? */ 173{ 174 Tcl_Channel ret; 175 Tcl_Obj *pathPtr = Tcl_NewStringObj(path,-1); 176 177 Tcl_IncrRefCount(pathPtr); 178 ret = Tcl_FSOpenFileChannel(interp, pathPtr, modeString, permissions); 179 Tcl_DecrRefCount(pathPtr); 180 181 return ret; 182} 183 184/* Obsolete */ 185int 186Tcl_Chdir( 187 const char *dirName) 188{ 189 int ret; 190 Tcl_Obj *pathPtr = Tcl_NewStringObj(dirName,-1); 191 Tcl_IncrRefCount(pathPtr); 192 ret = Tcl_FSChdir(pathPtr); 193 Tcl_DecrRefCount(pathPtr); 194 return ret; 195} 196 197/* Obsolete */ 198char * 199Tcl_GetCwd( 200 Tcl_Interp *interp, 201 Tcl_DString *cwdPtr) 202{ 203 Tcl_Obj *cwd; 204 cwd = Tcl_FSGetCwd(interp); 205 if (cwd == NULL) { 206 return NULL; 207 } else { 208 Tcl_DStringInit(cwdPtr); 209 Tcl_DStringAppend(cwdPtr, Tcl_GetString(cwd), -1); 210 Tcl_DecrRefCount(cwd); 211 return Tcl_DStringValue(cwdPtr); 212 } 213} 214 215/* Obsolete */ 216int 217Tcl_EvalFile( 218 Tcl_Interp *interp, /* Interpreter in which to process file. */ 219 const char *fileName) /* Name of file to process. Tilde-substitution 220 * will be performed on this name. */ 221{ 222 int ret; 223 Tcl_Obj *pathPtr = Tcl_NewStringObj(fileName,-1); 224 Tcl_IncrRefCount(pathPtr); 225 ret = Tcl_FSEvalFile(interp, pathPtr); 226 Tcl_DecrRefCount(pathPtr); 227 return ret; 228} 229 230/* 231 * The 3 hooks for Stat, Access and OpenFileChannel are obsolete. The 232 * complete, general hooked filesystem APIs should be used instead. This 233 * define decides whether to include the obsolete hooks and related code. If 234 * these are removed, we'll also want to remove them from stubs/tclInt. The 235 * only known users of these APIs are prowrap and mktclapp. New 236 * code/extensions should not use them, since they do not provide as full 237 * support as the full filesystem API. 238 * 239 * As soon as prowrap and mktclapp are updated to use the full filesystem 240 * support, I suggest all these hooks are removed. 241 */ 242 243#undef USE_OBSOLETE_FS_HOOKS 244 245#ifdef USE_OBSOLETE_FS_HOOKS 246 247/* 248 * The following typedef declarations allow for hooking into the chain of 249 * functions maintained for 'Tcl_Stat(...)', 'Tcl_Access(...)' & 250 * 'Tcl_OpenFileChannel(...)'. Basically for each hookable function a linked 251 * list is defined. 252 */ 253 254typedef struct StatProc { 255 TclStatProc_ *proc; /* Function to process a 'stat()' call */ 256 struct StatProc *nextPtr; /* The next 'stat()' function to call */ 257} StatProc; 258 259typedef struct AccessProc { 260 TclAccessProc_ *proc; /* Function to process a 'access()' call */ 261 struct AccessProc *nextPtr; /* The next 'access()' function to call */ 262} AccessProc; 263 264typedef struct OpenFileChannelProc { 265 TclOpenFileChannelProc_ *proc; 266 /* Function to process a 267 * 'Tcl_OpenFileChannel()' call */ 268 struct OpenFileChannelProc *nextPtr; 269 /* The next 'Tcl_OpenFileChannel()' function 270 * to call */ 271} OpenFileChannelProc; 272 273/* 274 * For each type of (obsolete) hookable function, a static node is declared to 275 * hold the function pointer for the "built-in" routine (e.g. 'TclpStat(...)') 276 * and the respective list is initialized as a pointer to that node. 277 * 278 * The "delete" functions (e.g. 'TclStatDeleteProc(...)') ensure that these 279 * statically declared list entry cannot be inadvertently removed. 280 * 281 * This method avoids the need to call any sort of "initialization" function. 282 * 283 * All three lists are protected by a global obsoleteFsHookMutex. 284 */ 285 286static StatProc *statProcList = NULL; 287static AccessProc *accessProcList = NULL; 288static OpenFileChannelProc *openFileChannelProcList = NULL; 289 290TCL_DECLARE_MUTEX(obsoleteFsHookMutex) 291 292#endif /* USE_OBSOLETE_FS_HOOKS */ 293 294/* 295 * Declare the native filesystem support. These functions should be considered 296 * private to Tcl, and should really not be called directly by any code other 297 * than this file (i.e. neither by Tcl's core nor by extensions). Similarly, 298 * the old string-based Tclp... native filesystem functions should not be 299 * called. 300 * 301 * The correct API to use now is the Tcl_FS... set of functions, which ensure 302 * correct and complete virtual filesystem support. 303 * 304 * We cannot make all of these static, since some of them are implemented in 305 * the platform-specific directories. 306 */ 307 308static Tcl_FSFilesystemSeparatorProc NativeFilesystemSeparator; 309static Tcl_FSFreeInternalRepProc NativeFreeInternalRep; 310static Tcl_FSFileAttrStringsProc NativeFileAttrStrings; 311static Tcl_FSFileAttrsGetProc NativeFileAttrsGet; 312static Tcl_FSFileAttrsSetProc NativeFileAttrsSet; 313 314/* 315 * The only reason these functions are not static is that they are either 316 * called by code in the native (win/unix) directories or they are actually 317 * implemented in those directories. They should simply not be called by code 318 * outside Tcl's native filesystem core i.e. they should be considered 319 * 'static' to Tcl's filesystem code (if we ever built the native filesystem 320 * support into a separate code library, this could actually be enforced). 321 */ 322 323Tcl_FSFilesystemPathTypeProc TclpFilesystemPathType; 324Tcl_FSInternalToNormalizedProc TclpNativeToNormalized; 325Tcl_FSStatProc TclpObjStat; 326Tcl_FSAccessProc TclpObjAccess; 327Tcl_FSMatchInDirectoryProc TclpMatchInDirectory; 328Tcl_FSChdirProc TclpObjChdir; 329Tcl_FSLstatProc TclpObjLstat; 330Tcl_FSCopyFileProc TclpObjCopyFile; 331Tcl_FSDeleteFileProc TclpObjDeleteFile; 332Tcl_FSRenameFileProc TclpObjRenameFile; 333Tcl_FSCreateDirectoryProc TclpObjCreateDirectory; 334Tcl_FSCopyDirectoryProc TclpObjCopyDirectory; 335Tcl_FSRemoveDirectoryProc TclpObjRemoveDirectory; 336Tcl_FSUnloadFileProc TclpUnloadFile; 337Tcl_FSLinkProc TclpObjLink; 338Tcl_FSListVolumesProc TclpObjListVolumes; 339 340/* 341 * Define the native filesystem dispatch table. If necessary, it is ok to make 342 * this non-static, but it should only be accessed by the functions actually 343 * listed within it (or perhaps other helper functions of them). Anything 344 * which is not part of this 'native filesystem implementation' should not be 345 * delving inside here! 346 */ 347 348Tcl_Filesystem tclNativeFilesystem = { 349 "native", 350 sizeof(Tcl_Filesystem), 351 TCL_FILESYSTEM_VERSION_2, 352 &TclNativePathInFilesystem, 353 &TclNativeDupInternalRep, 354 &NativeFreeInternalRep, 355 &TclpNativeToNormalized, 356 &TclNativeCreateNativeRep, 357 &TclpObjNormalizePath, 358 &TclpFilesystemPathType, 359 &NativeFilesystemSeparator, 360 &TclpObjStat, 361 &TclpObjAccess, 362 &TclpOpenFileChannel, 363 &TclpMatchInDirectory, 364 &TclpUtime, 365#ifndef S_IFLNK 366 NULL, 367#else 368 &TclpObjLink, 369#endif /* S_IFLNK */ 370 &TclpObjListVolumes, 371 &NativeFileAttrStrings, 372 &NativeFileAttrsGet, 373 &NativeFileAttrsSet, 374 &TclpObjCreateDirectory, 375 &TclpObjRemoveDirectory, 376 &TclpObjDeleteFile, 377 &TclpObjCopyFile, 378 &TclpObjRenameFile, 379 &TclpObjCopyDirectory, 380 &TclpObjLstat, 381 &TclpDlopen, 382 /* Needs a cast since we're using version_2 */ 383 (Tcl_FSGetCwdProc *) &TclpGetNativeCwd, 384 &TclpObjChdir 385}; 386 387/* 388 * Define the tail of the linked list. Note that for unconventional uses of 389 * Tcl without a native filesystem, we may in the future wish to modify the 390 * current approach of hard-coding the native filesystem in the lookup list 391 * 'filesystemList' below. 392 * 393 * We initialize the record so that it thinks one file uses it. This means it 394 * will never be freed. 395 */ 396 397static FilesystemRecord nativeFilesystemRecord = { 398 NULL, 399 &tclNativeFilesystem, 400 1, 401 NULL 402}; 403 404/* 405 * This is incremented each time we modify the linked list of filesystems. Any 406 * time it changes, all cached filesystem representations are suspect and must 407 * be freed. For multithreading builds, change of the filesystem epoch will 408 * trigger cache cleanup in all threads. 409 */ 410 411static int theFilesystemEpoch = 0; 412 413/* 414 * Stores the linked list of filesystems. A 1:1 copy of this list is also 415 * maintained in the TSD for each thread. This is to avoid synchronization 416 * issues. 417 */ 418 419static FilesystemRecord *filesystemList = &nativeFilesystemRecord; 420TCL_DECLARE_MUTEX(filesystemMutex) 421 422/* 423 * Used to implement Tcl_FSGetCwd in a file-system independent way. 424 */ 425 426static Tcl_Obj* cwdPathPtr = NULL; 427static int cwdPathEpoch = 0; 428static ClientData cwdClientData = NULL; 429TCL_DECLARE_MUTEX(cwdMutex) 430 431Tcl_ThreadDataKey tclFsDataKey; 432 433/* 434 * One of these structures is used each time we successfully load a file from 435 * a file system by way of making a temporary copy of the file on the native 436 * filesystem. We need to store both the actual unloadProc/clientData 437 * combination which was used, and the original and modified filenames, so 438 * that we can correctly undo the entire operation when we want to unload the 439 * code. 440 */ 441 442typedef struct FsDivertLoad { 443 Tcl_LoadHandle loadHandle; 444 Tcl_FSUnloadFileProc *unloadProcPtr; 445 Tcl_Obj *divertedFile; 446 const Tcl_Filesystem *divertedFilesystem; 447 ClientData divertedFileNativeRep; 448} FsDivertLoad; 449 450/* 451 * Now move on to the basic filesystem implementation 452 */ 453 454static void 455FsThrExitProc( 456 ClientData cd) 457{ 458 ThreadSpecificData *tsdPtr = (ThreadSpecificData *) cd; 459 FilesystemRecord *fsRecPtr = NULL, *tmpFsRecPtr = NULL; 460 461 /* 462 * Trash the cwd copy. 463 */ 464 465 if (tsdPtr->cwdPathPtr != NULL) { 466 Tcl_DecrRefCount(tsdPtr->cwdPathPtr); 467 tsdPtr->cwdPathPtr = NULL; 468 } 469 if (tsdPtr->cwdClientData != NULL) { 470 NativeFreeInternalRep(tsdPtr->cwdClientData); 471 } 472 473 /* 474 * Trash the filesystems cache. 475 */ 476 477 fsRecPtr = tsdPtr->filesystemList; 478 while (fsRecPtr != NULL) { 479 tmpFsRecPtr = fsRecPtr->nextPtr; 480 if (--fsRecPtr->fileRefCount <= 0) { 481 ckfree((char *)fsRecPtr); 482 } 483 fsRecPtr = tmpFsRecPtr; 484 } 485 tsdPtr->initialized = 0; 486} 487 488int 489TclFSCwdIsNative(void) 490{ 491 ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&tclFsDataKey); 492 493 if (tsdPtr->cwdClientData != NULL) { 494 return 1; 495 } else { 496 return 0; 497 } 498} 499 500/* 501 *---------------------------------------------------------------------- 502 * 503 * TclFSCwdPointerEquals -- 504 * 505 * Check whether the current working directory is equal to the path 506 * given. 507 * 508 * Results: 509 * 1 (equal) or 0 (un-equal) as appropriate. 510 * 511 * Side effects: 512 * If the paths are equal, but are not the same object, this method will 513 * modify the given pathPtrPtr to refer to the same object. In this case 514 * the object pointed to by pathPtrPtr will have its refCount 515 * decremented, and it will be adjusted to point to the cwd (with a new 516 * refCount). 517 * 518 *---------------------------------------------------------------------- 519 */ 520 521int 522TclFSCwdPointerEquals( 523 Tcl_Obj** pathPtrPtr) 524{ 525 ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&tclFsDataKey); 526 527 Tcl_MutexLock(&cwdMutex); 528 if (tsdPtr->cwdPathPtr == NULL 529 || tsdPtr->cwdPathEpoch != cwdPathEpoch) { 530 if (tsdPtr->cwdPathPtr != NULL) { 531 Tcl_DecrRefCount(tsdPtr->cwdPathPtr); 532 } 533 if (tsdPtr->cwdClientData != NULL) { 534 NativeFreeInternalRep(tsdPtr->cwdClientData); 535 } 536 if (cwdPathPtr == NULL) { 537 tsdPtr->cwdPathPtr = NULL; 538 } else { 539 tsdPtr->cwdPathPtr = Tcl_DuplicateObj(cwdPathPtr); 540 Tcl_IncrRefCount(tsdPtr->cwdPathPtr); 541 } 542 if (cwdClientData == NULL) { 543 tsdPtr->cwdClientData = NULL; 544 } else { 545 tsdPtr->cwdClientData = TclNativeDupInternalRep(cwdClientData); 546 } 547 tsdPtr->cwdPathEpoch = cwdPathEpoch; 548 } 549 Tcl_MutexUnlock(&cwdMutex); 550 551 if (tsdPtr->initialized == 0) { 552 Tcl_CreateThreadExitHandler(FsThrExitProc, (ClientData) tsdPtr); 553 tsdPtr->initialized = 1; 554 } 555 556 if (pathPtrPtr == NULL) { 557 return (tsdPtr->cwdPathPtr == NULL); 558 } 559 560 if (tsdPtr->cwdPathPtr == *pathPtrPtr) { 561 return 1; 562 } else { 563 int len1, len2; 564 const char *str1, *str2; 565 566 str1 = Tcl_GetStringFromObj(tsdPtr->cwdPathPtr, &len1); 567 str2 = Tcl_GetStringFromObj(*pathPtrPtr, &len2); 568 if (len1 == len2 && !strcmp(str1,str2)) { 569 /* 570 * They are equal, but different objects. Update so they will be 571 * the same object in the future. 572 */ 573 574 Tcl_DecrRefCount(*pathPtrPtr); 575 *pathPtrPtr = tsdPtr->cwdPathPtr; 576 Tcl_IncrRefCount(*pathPtrPtr); 577 return 1; 578 } else { 579 return 0; 580 } 581 } 582} 583 584#ifdef TCL_THREADS 585static void 586FsRecacheFilesystemList(void) 587{ 588 ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&tclFsDataKey); 589 FilesystemRecord *fsRecPtr, *tmpFsRecPtr = NULL; 590 591 /* 592 * Trash the current cache. 593 */ 594 595 fsRecPtr = tsdPtr->filesystemList; 596 while (fsRecPtr != NULL) { 597 tmpFsRecPtr = fsRecPtr->nextPtr; 598 if (--fsRecPtr->fileRefCount <= 0) { 599 ckfree((char *)fsRecPtr); 600 } 601 fsRecPtr = tmpFsRecPtr; 602 } 603 tsdPtr->filesystemList = NULL; 604 605 /* 606 * Code below operates on shared data. We are already called under mutex 607 * lock so we can safely proceed. 608 * 609 * Locate tail of the global filesystem list. 610 */ 611 612 fsRecPtr = filesystemList; 613 while (fsRecPtr != NULL) { 614 tmpFsRecPtr = fsRecPtr; 615 fsRecPtr = fsRecPtr->nextPtr; 616 } 617 618 /* 619 * Refill the cache honouring the order. 620 */ 621 622 fsRecPtr = tmpFsRecPtr; 623 while (fsRecPtr != NULL) { 624 tmpFsRecPtr = (FilesystemRecord *) ckalloc(sizeof(FilesystemRecord)); 625 *tmpFsRecPtr = *fsRecPtr; 626 tmpFsRecPtr->nextPtr = tsdPtr->filesystemList; 627 tmpFsRecPtr->prevPtr = NULL; 628 if (tsdPtr->filesystemList) { 629 tsdPtr->filesystemList->prevPtr = tmpFsRecPtr; 630 } 631 tsdPtr->filesystemList = tmpFsRecPtr; 632 fsRecPtr = fsRecPtr->prevPtr; 633 } 634 635 /* 636 * Make sure the above gets released on thread exit. 637 */ 638 639 if (tsdPtr->initialized == 0) { 640 Tcl_CreateThreadExitHandler(FsThrExitProc, (ClientData) tsdPtr); 641 tsdPtr->initialized = 1; 642 } 643} 644#endif /* TCL_THREADS */ 645 646static FilesystemRecord * 647FsGetFirstFilesystem(void) 648{ 649 ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&tclFsDataKey); 650 FilesystemRecord *fsRecPtr; 651#ifndef TCL_THREADS 652 tsdPtr->filesystemEpoch = theFilesystemEpoch; 653 fsRecPtr = filesystemList; 654#else 655 Tcl_MutexLock(&filesystemMutex); 656 if (tsdPtr->filesystemList == NULL 657 || (tsdPtr->filesystemEpoch != theFilesystemEpoch)) { 658 FsRecacheFilesystemList(); 659 tsdPtr->filesystemEpoch = theFilesystemEpoch; 660 } 661 Tcl_MutexUnlock(&filesystemMutex); 662 fsRecPtr = tsdPtr->filesystemList; 663#endif 664 return fsRecPtr; 665} 666 667/* 668 * The epoch can be changed both by filesystems being added or removed and by 669 * env(HOME) changing. 670 */ 671 672int 673TclFSEpochOk( 674 int filesystemEpoch) 675{ 676 ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&tclFsDataKey); 677 (void) FsGetFirstFilesystem(); 678 return (filesystemEpoch == tsdPtr->filesystemEpoch); 679} 680 681/* 682 * If non-NULL, clientData is owned by us and must be freed later. 683 */ 684 685static void 686FsUpdateCwd( 687 Tcl_Obj *cwdObj, 688 ClientData clientData) 689{ 690 int len; 691 char *str = NULL; 692 ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&tclFsDataKey); 693 694 if (cwdObj != NULL) { 695 str = Tcl_GetStringFromObj(cwdObj, &len); 696 } 697 698 Tcl_MutexLock(&cwdMutex); 699 if (cwdPathPtr != NULL) { 700 Tcl_DecrRefCount(cwdPathPtr); 701 } 702 if (cwdClientData != NULL) { 703 NativeFreeInternalRep(cwdClientData); 704 } 705 706 if (cwdObj == NULL) { 707 cwdPathPtr = NULL; 708 cwdClientData = NULL; 709 } else { 710 /* 711 * This must be stored as string obj! 712 */ 713 714 cwdPathPtr = Tcl_NewStringObj(str, len); 715 Tcl_IncrRefCount(cwdPathPtr); 716 cwdClientData = TclNativeDupInternalRep(clientData); 717 } 718 719 cwdPathEpoch++; 720 tsdPtr->cwdPathEpoch = cwdPathEpoch; 721 Tcl_MutexUnlock(&cwdMutex); 722 723 if (tsdPtr->cwdPathPtr) { 724 Tcl_DecrRefCount(tsdPtr->cwdPathPtr); 725 } 726 if (tsdPtr->cwdClientData) { 727 NativeFreeInternalRep(tsdPtr->cwdClientData); 728 } 729 730 if (cwdObj == NULL) { 731 tsdPtr->cwdPathPtr = NULL; 732 tsdPtr->cwdClientData = NULL; 733 } else { 734 tsdPtr->cwdPathPtr = Tcl_NewStringObj(str, len); 735 tsdPtr->cwdClientData = clientData; 736 Tcl_IncrRefCount(tsdPtr->cwdPathPtr); 737 } 738} 739 740/* 741 *---------------------------------------------------------------------- 742 * 743 * TclFinalizeFilesystem -- 744 * 745 * Clean up the filesystem. After this, calls to all Tcl_FS... functions 746 * will fail. 747 * 748 * We will later call TclResetFilesystem to restore the FS to a pristine 749 * state. 750 * 751 * Results: 752 * None. 753 * 754 * Side effects: 755 * Frees any memory allocated by the filesystem. 756 * 757 *---------------------------------------------------------------------- 758 */ 759 760void 761TclFinalizeFilesystem(void) 762{ 763 FilesystemRecord *fsRecPtr; 764 765 /* 766 * Assumption that only one thread is active now. Otherwise we would need 767 * to put various mutexes around this code. 768 */ 769 770 if (cwdPathPtr != NULL) { 771 Tcl_DecrRefCount(cwdPathPtr); 772 cwdPathPtr = NULL; 773 cwdPathEpoch = 0; 774 } 775 if (cwdClientData != NULL) { 776 NativeFreeInternalRep(cwdClientData); 777 cwdClientData = NULL; 778 } 779 780 /* 781 * Remove all filesystems, freeing any allocated memory that is no longer 782 * needed 783 */ 784 785 fsRecPtr = filesystemList; 786 while (fsRecPtr != NULL) { 787 FilesystemRecord *tmpFsRecPtr = fsRecPtr->nextPtr; 788 if (fsRecPtr->fileRefCount <= 0) { 789 /* 790 * The native filesystem is static, so we don't free it. 791 */ 792 793 if (fsRecPtr->fsPtr != &tclNativeFilesystem) { 794 ckfree((char *)fsRecPtr); 795 } 796 } 797 fsRecPtr = tmpFsRecPtr; 798 } 799 filesystemList = NULL; 800 801 /* 802 * Now filesystemList is NULL. This means that any attempt to use the 803 * filesystem is likely to fail. 804 */ 805 806#ifdef USE_OBSOLETE_FS_HOOKS 807 statProcList = NULL; 808 accessProcList = NULL; 809 openFileChannelProcList = NULL; 810#endif 811#ifdef __WIN32__ 812 TclWinEncodingsCleanup(); 813#endif 814} 815 816/* 817 *---------------------------------------------------------------------- 818 * 819 * TclResetFilesystem -- 820 * 821 * Restore the filesystem to a pristine state. 822 * 823 * Results: 824 * None. 825 * 826 * Side effects: 827 * None. 828 * 829 *---------------------------------------------------------------------- 830 */ 831 832void 833TclResetFilesystem(void) 834{ 835 filesystemList = &nativeFilesystemRecord; 836 837 /* 838 * Note, at this point, I believe nativeFilesystemRecord -> fileRefCount 839 * should equal 1 and if not, we should try to track down the cause. 840 */ 841 842#ifdef __WIN32__ 843 /* 844 * Cleans up the win32 API filesystem proc lookup table. This must happen 845 * very late in finalization so that deleting of copied dlls can occur. 846 */ 847 848 TclWinResetInterfaces(); 849#endif 850} 851 852/* 853 *---------------------------------------------------------------------- 854 * 855 * Tcl_FSRegister -- 856 * 857 * Insert the filesystem function table at the head of the list of 858 * functions which are used during calls to all file-system operations. 859 * The filesystem will be added even if it is already in the list. (You 860 * can use Tcl_FSData to check if it is in the list, provided the 861 * ClientData used was not NULL). 862 * 863 * Note that the filesystem handling is head-to-tail of the list. Each 864 * filesystem is asked in turn whether it can handle a particular 865 * request, until one of them says 'yes'. At that point no further 866 * filesystems are asked. 867 * 868 * In particular this means if you want to add a diagnostic filesystem 869 * (which simply reports all fs activity), it must be at the head of the 870 * list: i.e. it must be the last registered. 871 * 872 * Results: 873 * Normally TCL_OK; TCL_ERROR if memory for a new node in the list could 874 * not be allocated. 875 * 876 * Side effects: 877 * Memory allocated and modifies the link list for filesystems. 878 * 879 *---------------------------------------------------------------------- 880 */ 881 882int 883Tcl_FSRegister( 884 ClientData clientData, /* Client specific data for this fs */ 885 Tcl_Filesystem *fsPtr) /* The filesystem record for the new fs. */ 886{ 887 FilesystemRecord *newFilesystemPtr; 888 889 if (fsPtr == NULL) { 890 return TCL_ERROR; 891 } 892 893 newFilesystemPtr = (FilesystemRecord *) ckalloc(sizeof(FilesystemRecord)); 894 895 newFilesystemPtr->clientData = clientData; 896 newFilesystemPtr->fsPtr = fsPtr; 897 898 /* 899 * We start with a refCount of 1. If this drops to zero, then anyone is 900 * welcome to ckfree us. 901 */ 902 903 newFilesystemPtr->fileRefCount = 1; 904 905 /* 906 * Is this lock and wait strictly speaking necessary? Since any iterators 907 * out there will have grabbed a copy of the head of the list and be 908 * iterating away from that, if we add a new element to the head of the 909 * list, it can't possibly have any effect on any of their loops. In fact 910 * it could be better not to wait, since we are adjusting the filesystem 911 * epoch, any cached representations calculated by existing iterators are 912 * going to have to be thrown away anyway. 913 * 914 * However, since registering and unregistering filesystems is a very rare 915 * action, this is not a very important point. 916 */ 917 918 Tcl_MutexLock(&filesystemMutex); 919 920 newFilesystemPtr->nextPtr = filesystemList; 921 newFilesystemPtr->prevPtr = NULL; 922 if (filesystemList) { 923 filesystemList->prevPtr = newFilesystemPtr; 924 } 925 filesystemList = newFilesystemPtr; 926 927 /* 928 * Increment the filesystem epoch counter, since existing paths might 929 * conceivably now belong to different filesystems. 930 */ 931 932 theFilesystemEpoch++; 933 Tcl_MutexUnlock(&filesystemMutex); 934 935 return TCL_OK; 936} 937 938/* 939 *---------------------------------------------------------------------- 940 * 941 * Tcl_FSUnregister -- 942 * 943 * Remove the passed filesystem from the list of filesystem function 944 * tables. It also ensures that the built-in (native) filesystem is not 945 * removable, although we may wish to change that decision in the future 946 * to allow a smaller Tcl core, in which the native filesystem is not 947 * used at all (we could, say, initialise Tcl completely over a network 948 * connection). 949 * 950 * Results: 951 * TCL_OK if the function pointer was successfully removed, TCL_ERROR 952 * otherwise. 953 * 954 * Side effects: 955 * Memory may be deallocated (or will be later, once no "path" objects 956 * refer to this filesystem), but the list of registered filesystems is 957 * updated immediately. 958 * 959 *---------------------------------------------------------------------- 960 */ 961 962int 963Tcl_FSUnregister( 964 Tcl_Filesystem *fsPtr) /* The filesystem record to remove. */ 965{ 966 int retVal = TCL_ERROR; 967 FilesystemRecord *fsRecPtr; 968 969 Tcl_MutexLock(&filesystemMutex); 970 971 /* 972 * Traverse the 'filesystemList' looking for the particular node whose 973 * 'fsPtr' member matches 'fsPtr' and remove that one from the list. 974 * Ensure that the "default" node cannot be removed. 975 */ 976 977 fsRecPtr = filesystemList; 978 while ((retVal == TCL_ERROR) && (fsRecPtr->fsPtr != &tclNativeFilesystem)) { 979 if (fsRecPtr->fsPtr == fsPtr) { 980 if (fsRecPtr->prevPtr) { 981 fsRecPtr->prevPtr->nextPtr = fsRecPtr->nextPtr; 982 } else { 983 filesystemList = fsRecPtr->nextPtr; 984 } 985 if (fsRecPtr->nextPtr) { 986 fsRecPtr->nextPtr->prevPtr = fsRecPtr->prevPtr; 987 } 988 989 /* 990 * Increment the filesystem epoch counter, since existing paths 991 * might conceivably now belong to different filesystems. This 992 * should also ensure that paths which have cached the filesystem 993 * which is about to be deleted do not reference that filesystem 994 * (which would of course lead to memory exceptions). 995 */ 996 997 theFilesystemEpoch++; 998 999 fsRecPtr->fileRefCount--; 1000 if (fsRecPtr->fileRefCount <= 0) { 1001 ckfree((char *)fsRecPtr); 1002 } 1003 1004 retVal = TCL_OK; 1005 } else { 1006 fsRecPtr = fsRecPtr->nextPtr; 1007 } 1008 } 1009 1010 Tcl_MutexUnlock(&filesystemMutex); 1011 return retVal; 1012} 1013 1014/* 1015 *---------------------------------------------------------------------- 1016 * 1017 * Tcl_FSMatchInDirectory -- 1018 * 1019 * This routine is used by the globbing code to search a directory for 1020 * all files which match a given pattern. The appropriate function for 1021 * the filesystem to which pathPtr belongs will be called. If pathPtr 1022 * does not belong to any filesystem and if it is NULL or the empty 1023 * string, then we assume the pattern is to be matched in the current 1024 * working directory. To avoid have the Tcl_FSMatchInDirectoryProc for 1025 * each filesystem from having to deal with this issue, we create a 1026 * pathPtr on the fly (equal to the cwd), and then remove it from the 1027 * results returned. This makes filesystems easy to write, since they can 1028 * assume the pathPtr passed to them is an ordinary path. In fact this 1029 * means we could remove such special case handling from Tcl's native 1030 * filesystems. 1031 * 1032 * If 'pattern' is NULL, then pathPtr is assumed to be a fully specified 1033 * path of a single file/directory which must be checked for existence 1034 * and correct type. 1035 * 1036 * Results: 1037 * 1038 * The return value is a standard Tcl result indicating whether an error 1039 * occurred in globbing. Error messages are placed in interp, but good 1040 * results are placed in the resultPtr given. 1041 * 1042 * Recursive searches, e.g. 1043 * glob -dir $dir -join * pkgIndex.tcl 1044 * which must recurse through each directory matching '*' are handled 1045 * internally by Tcl, by passing specific flags in a modified 'types' 1046 * parameter. This means the actual filesystem only ever sees patterns 1047 * which match in a single directory. 1048 * 1049 * Side effects: 1050 * The interpreter may have an error message inserted into it. 1051 * 1052 *---------------------------------------------------------------------- 1053 */ 1054 1055int 1056Tcl_FSMatchInDirectory( 1057 Tcl_Interp *interp, /* Interpreter to receive error messages, but 1058 * may be NULL. */ 1059 Tcl_Obj *resultPtr, /* List object to receive results. */ 1060 Tcl_Obj *pathPtr, /* Contains path to directory to search. */ 1061 const char *pattern, /* Pattern to match against. */ 1062 Tcl_GlobTypeData *types) /* Object containing list of acceptable types. 1063 * May be NULL. In particular the directory 1064 * flag is very important. */ 1065{ 1066 const Tcl_Filesystem *fsPtr; 1067 Tcl_Obj *cwd, *tmpResultPtr, **elemsPtr; 1068 int resLength, i, ret = -1; 1069 1070 if (types != NULL && types->type & TCL_GLOB_TYPE_MOUNT) { 1071 /* 1072 * We don't currently allow querying of mounts by external code (a 1073 * valuable future step), so since we're the only function that 1074 * actually knows about mounts, this means we're being called 1075 * recursively by ourself. Return no matches. 1076 */ 1077 1078 return TCL_OK; 1079 } 1080 1081 if (pathPtr != NULL) { 1082 fsPtr = Tcl_FSGetFileSystemForPath(pathPtr); 1083 } else { 1084 fsPtr = NULL; 1085 } 1086 1087 /* 1088 * Check if we've successfully mapped the path to a filesystem within 1089 * which to search. 1090 */ 1091 1092 if (fsPtr != NULL) { 1093 if (fsPtr->matchInDirectoryProc == NULL) { 1094 Tcl_SetErrno(ENOENT); 1095 return -1; 1096 } 1097 ret = (*fsPtr->matchInDirectoryProc)(interp, resultPtr, pathPtr, 1098 pattern, types); 1099 if (ret == TCL_OK && pattern != NULL) { 1100 FsAddMountsToGlobResult(resultPtr, pathPtr, pattern, types); 1101 } 1102 return ret; 1103 } 1104 1105 /* 1106 * If the path isn't empty, we have no idea how to match files in a 1107 * directory which belongs to no known filesystem 1108 */ 1109 1110 if (pathPtr != NULL && TclGetString(pathPtr)[0] != '\0') { 1111 Tcl_SetErrno(ENOENT); 1112 return -1; 1113 } 1114 1115 /* 1116 * We have an empty or NULL path. This is defined to mean we must search 1117 * for files within the current 'cwd'. We therefore use that, but then 1118 * since the proc we call will return results which include the cwd we 1119 * must then trim it off the front of each path in the result. We choose 1120 * to deal with this here (in the generic code), since if we don't, every 1121 * single filesystem's implementation of Tcl_FSMatchInDirectory will have 1122 * to deal with it for us. 1123 */ 1124 1125 cwd = Tcl_FSGetCwd(NULL); 1126 if (cwd == NULL) { 1127 if (interp != NULL) { 1128 Tcl_SetResult(interp, "glob couldn't determine " 1129 "the current working directory", TCL_STATIC); 1130 } 1131 return TCL_ERROR; 1132 } 1133 1134 fsPtr = Tcl_FSGetFileSystemForPath(cwd); 1135 if (fsPtr != NULL && fsPtr->matchInDirectoryProc != NULL) { 1136 TclNewObj(tmpResultPtr); 1137 Tcl_IncrRefCount(tmpResultPtr); 1138 ret = (*fsPtr->matchInDirectoryProc)(interp, tmpResultPtr, cwd, 1139 pattern, types); 1140 if (ret == TCL_OK) { 1141 FsAddMountsToGlobResult(tmpResultPtr, cwd, pattern, types); 1142 1143 /* 1144 * Note that we know resultPtr and tmpResultPtr are distinct. 1145 */ 1146 1147 ret = Tcl_ListObjGetElements(interp, tmpResultPtr, 1148 &resLength, &elemsPtr); 1149 for (i=0 ; ret==TCL_OK && i<resLength ; i++) { 1150 ret = Tcl_ListObjAppendElement(interp, resultPtr, 1151 TclFSMakePathRelative(interp, elemsPtr[i], cwd)); 1152 } 1153 } 1154 TclDecrRefCount(tmpResultPtr); 1155 } 1156 Tcl_DecrRefCount(cwd); 1157 return ret; 1158} 1159 1160/* 1161 *---------------------------------------------------------------------- 1162 * 1163 * FsAddMountsToGlobResult -- 1164 * 1165 * This routine is used by the globbing code to take the results of a 1166 * directory listing and add any mounted paths to that listing. This is 1167 * required so that simple things like 'glob *' merge mounts and listings 1168 * correctly. 1169 * 1170 * Results: 1171 * None. 1172 * 1173 * Side effects: 1174 * Modifies the resultPtr. 1175 * 1176 *---------------------------------------------------------------------- 1177 */ 1178 1179static void 1180FsAddMountsToGlobResult( 1181 Tcl_Obj *resultPtr, /* The current list of matching paths; must 1182 * not be shared! */ 1183 Tcl_Obj *pathPtr, /* The directory in question */ 1184 const char *pattern, /* Pattern to match against. */ 1185 Tcl_GlobTypeData *types) /* Object containing list of acceptable types. 1186 * May be NULL. In particular the directory 1187 * flag is very important. */ 1188{ 1189 int mLength, gLength, i; 1190 int dir = (types == NULL || (types->type & TCL_GLOB_TYPE_DIR)); 1191 Tcl_Obj *mounts = FsListMounts(pathPtr, pattern); 1192 1193 if (mounts == NULL) { 1194 return; 1195 } 1196 1197 if (Tcl_ListObjLength(NULL, mounts, &mLength) != TCL_OK || mLength == 0) { 1198 goto endOfMounts; 1199 } 1200 if (Tcl_ListObjLength(NULL, resultPtr, &gLength) != TCL_OK) { 1201 goto endOfMounts; 1202 } 1203 for (i=0 ; i<mLength ; i++) { 1204 Tcl_Obj *mElt; 1205 int j; 1206 int found = 0; 1207 1208 Tcl_ListObjIndex(NULL, mounts, i, &mElt); 1209 1210 for (j=0 ; j<gLength ; j++) { 1211 Tcl_Obj *gElt; 1212 1213 Tcl_ListObjIndex(NULL, resultPtr, j, &gElt); 1214 if (Tcl_FSEqualPaths(mElt, gElt)) { 1215 found = 1; 1216 if (!dir) { 1217 /* 1218 * We don't want to list this. 1219 */ 1220 1221 Tcl_ListObjReplace(NULL, resultPtr, j, 1, 0, NULL); 1222 gLength--; 1223 } 1224 break; /* Break out of for loop */ 1225 } 1226 } 1227 if (!found && dir) { 1228 Tcl_Obj *norm; 1229 int len, mlen; 1230 1231 /* 1232 * We know mElt is absolute normalized and lies inside pathPtr, so 1233 * now we must add to the result the right representation of mElt, 1234 * i.e. the representation which is relative to pathPtr. 1235 */ 1236 1237 norm = Tcl_FSGetNormalizedPath(NULL, pathPtr); 1238 if (norm != NULL) { 1239 const char *path, *mount; 1240 1241 mount = Tcl_GetStringFromObj(mElt, &mlen); 1242 path = Tcl_GetStringFromObj(norm, &len); 1243 if (path[len-1] == '/') { 1244 /* 1245 * Deal with the root of the volume. 1246 */ 1247 1248 len--; 1249 } 1250 len++; /* account for '/' in the mElt [Bug 1602539] */ 1251 mElt = TclNewFSPathObj(pathPtr, mount + len, mlen - len); 1252 Tcl_ListObjAppendElement(NULL, resultPtr, mElt); 1253 } 1254 /* 1255 * No need to increment gLength, since we don't want to compare 1256 * mounts against mounts. 1257 */ 1258 } 1259 } 1260 1261 endOfMounts: 1262 Tcl_DecrRefCount(mounts); 1263} 1264 1265/* 1266 *---------------------------------------------------------------------- 1267 * 1268 * Tcl_FSMountsChanged -- 1269 * 1270 * Notify the filesystem that the available mounted filesystems (or 1271 * within any one filesystem type, the number or location of mount 1272 * points) have changed. 1273 * 1274 * Results: 1275 * None. 1276 * 1277 * Side effects: 1278 * The global filesystem variable 'theFilesystemEpoch' is incremented. 1279 * The effect of this is to make all cached path representations invalid. 1280 * Clearly it should only therefore be called when it is really required! 1281 * There are a few circumstances when it should be called: 1282 * 1283 * (1) when a new filesystem is registered or unregistered. Strictly 1284 * speaking this is only necessary if the new filesystem accepts file 1285 * paths as is (normally the filesystem itself is really a shell which 1286 * hasn't yet had any mount points established and so its 1287 * 'pathInFilesystem' proc will always fail). However, for safety, Tcl 1288 * always calls this for you in these circumstances. 1289 * 1290 * (2) when additional mount points are established inside any existing 1291 * filesystem (except the native fs) 1292 * 1293 * (3) when any filesystem (except the native fs) changes the list of 1294 * available volumes. 1295 * 1296 * (4) when the mapping from a string representation of a file to a full, 1297 * normalized path changes. For example, if 'env(HOME)' is modified, then 1298 * any path containing '~' will map to a different filesystem location. 1299 * Therefore all such paths need to have their internal representation 1300 * invalidated. 1301 * 1302 * Tcl has no control over (2) and (3), so any registered filesystem must 1303 * make sure it calls this function when those situations occur. 1304 * 1305 * (Note: the reason for the exception in 2,3 for the native filesystem 1306 * is that the native filesystem by default claims all unknown files even 1307 * if it really doesn't understand them or if they don't exist). 1308 * 1309 *---------------------------------------------------------------------- 1310 */ 1311 1312void 1313Tcl_FSMountsChanged( 1314 Tcl_Filesystem *fsPtr) 1315{ 1316 /* 1317 * We currently don't do anything with this parameter. We could in the 1318 * future only invalidate files for this filesystem or otherwise take more 1319 * advanced action. 1320 */ 1321 1322 (void)fsPtr; 1323 1324 /* 1325 * Increment the filesystem epoch counter, since existing paths might now 1326 * belong to different filesystems. 1327 */ 1328 1329 Tcl_MutexLock(&filesystemMutex); 1330 theFilesystemEpoch++; 1331 Tcl_MutexUnlock(&filesystemMutex); 1332} 1333 1334/* 1335 *---------------------------------------------------------------------- 1336 * 1337 * Tcl_FSData -- 1338 * 1339 * Retrieve the clientData field for the filesystem given, or NULL if 1340 * that filesystem is not registered. 1341 * 1342 * Results: 1343 * A clientData value, or NULL. Note that if the filesystem was 1344 * registered with a NULL clientData field, this function will return 1345 * that NULL value. 1346 * 1347 * Side effects: 1348 * None. 1349 * 1350 *---------------------------------------------------------------------- 1351 */ 1352 1353ClientData 1354Tcl_FSData( 1355 Tcl_Filesystem *fsPtr) /* The filesystem record to query. */ 1356{ 1357 ClientData retVal = NULL; 1358 FilesystemRecord *fsRecPtr = FsGetFirstFilesystem(); 1359 1360 /* 1361 * Traverse the list of filesystems look for a particular one. If found, 1362 * return that filesystem's clientData (originally provided when calling 1363 * Tcl_FSRegister). 1364 */ 1365 1366 while ((retVal == NULL) && (fsRecPtr != NULL)) { 1367 if (fsRecPtr->fsPtr == fsPtr) { 1368 retVal = fsRecPtr->clientData; 1369 } 1370 fsRecPtr = fsRecPtr->nextPtr; 1371 } 1372 1373 return retVal; 1374} 1375 1376/* 1377 *--------------------------------------------------------------------------- 1378 * 1379 * TclFSNormalizeToUniquePath -- 1380 * 1381 * Takes a path specification containing no ../, ./ sequences, and 1382 * converts it into a unique path for the given platform. On Unix, this 1383 * means the path must be free of symbolic links/aliases, and on Windows 1384 * it means we want the long form, with that long form's case-dependence 1385 * (which gives us a unique, case-dependent path). 1386 * 1387 * Results: 1388 * The pathPtr is modified in place. The return value is the last byte 1389 * offset which was recognised in the path string. 1390 * 1391 * Side effects: 1392 * None (beyond the memory allocation for the result). 1393 * 1394 * Special notes: 1395 * If the filesystem-specific normalizePathProcs can re-introduce ../, ./ 1396 * sequences into the path, then this function will not return the 1397 * correct result. This may be possible with symbolic links on unix. 1398 * 1399 * Important assumption: if startAt is non-zero, it must point to a 1400 * directory separator that we know exists and is already normalized (so 1401 * it is important not to point to the char just after the separator). 1402 * 1403 *--------------------------------------------------------------------------- 1404 */ 1405 1406int 1407TclFSNormalizeToUniquePath( 1408 Tcl_Interp *interp, /* Used for error messages. */ 1409 Tcl_Obj *pathPtr, /* The path to normalize in place */ 1410 int startAt, /* Start at this char-offset */ 1411 ClientData *clientDataPtr) /* If we generated a complete normalized path 1412 * for a given filesystem, we can optionally 1413 * return an fs-specific clientdata here. */ 1414{ 1415 FilesystemRecord *fsRecPtr, *firstFsRecPtr; 1416 /* Ignore this variable */ 1417 (void) clientDataPtr; 1418 1419 /* 1420 * Call each of the "normalise path" functions in succession. This is a 1421 * special case, in which if we have a native filesystem handler, we call 1422 * it first. This is because the root of Tcl's filesystem is always a 1423 * native filesystem (i.e. '/' on unix is native). 1424 */ 1425 1426 firstFsRecPtr = FsGetFirstFilesystem(); 1427 1428 fsRecPtr = firstFsRecPtr; 1429 while (fsRecPtr != NULL) { 1430 if (fsRecPtr->fsPtr == &tclNativeFilesystem) { 1431 Tcl_FSNormalizePathProc *proc = fsRecPtr->fsPtr->normalizePathProc; 1432 if (proc != NULL) { 1433 startAt = (*proc)(interp, pathPtr, startAt); 1434 } 1435 break; 1436 } 1437 fsRecPtr = fsRecPtr->nextPtr; 1438 } 1439 1440 fsRecPtr = firstFsRecPtr; 1441 while (fsRecPtr != NULL) { 1442 /* 1443 * Skip the native system next time through. 1444 */ 1445 1446 if (fsRecPtr->fsPtr != &tclNativeFilesystem) { 1447 Tcl_FSNormalizePathProc *proc = fsRecPtr->fsPtr->normalizePathProc; 1448 if (proc != NULL) { 1449 startAt = (*proc)(interp, pathPtr, startAt); 1450 } 1451 1452 /* 1453 * We could add an efficiency check like this: 1454 * if (retVal == length-of(pathPtr)) {break;} 1455 * but there's not much benefit. 1456 */ 1457 } 1458 fsRecPtr = fsRecPtr->nextPtr; 1459 } 1460 1461 return startAt; 1462} 1463 1464/* 1465 *--------------------------------------------------------------------------- 1466 * 1467 * TclGetOpenMode -- 1468 * 1469 * This routine is an obsolete, limited version of TclGetOpenModeEx() 1470 * below. It exists only to satisfy any extensions imprudently using it 1471 * via Tcl's internal stubs table. 1472 * 1473 * Results: 1474 * Same as TclGetOpenModeEx(). 1475 * 1476 * Side effects: 1477 * Same as TclGetOpenModeEx(). 1478 * 1479 *--------------------------------------------------------------------------- 1480 */ 1481 1482int 1483TclGetOpenMode( 1484 Tcl_Interp *interp, /* Interpreter to use for error reporting - 1485 * may be NULL. */ 1486 const char *modeString, /* Mode string, e.g. "r+" or "RDONLY CREAT" */ 1487 int *seekFlagPtr) /* Set this to 1 if the caller should seek to 1488 * EOF during the opening of the file. */ 1489{ 1490 int binary = 0; 1491 return TclGetOpenModeEx(interp, modeString, seekFlagPtr, &binary); 1492} 1493 1494/* 1495 *--------------------------------------------------------------------------- 1496 * 1497 * TclGetOpenModeEx -- 1498 * 1499 * Computes a POSIX mode mask for opening a file, from a given string, 1500 * and also sets flags to indicate whether the caller should seek to EOF 1501 * after opening the file, and whether the caller should configure the 1502 * channel for binary data. 1503 * 1504 * Results: 1505 * On success, returns mode to pass to "open". If an error occurs, the 1506 * return value is -1 and if interp is not NULL, sets interp's result 1507 * object to an error message. 1508 * 1509 * Side effects: 1510 * Sets the integer referenced by seekFlagPtr to 1 to tell the caller to 1511 * seek to EOF after opening the file, or to 0 otherwise. Sets the 1512 * integer referenced by binaryPtr to 1 to tell the caller to seek to 1513 * configure the channel for binary data, or to 0 otherwise. 1514 * 1515 * Special note: 1516 * This code is based on a prototype implementation contributed by Mark 1517 * Diekhans. 1518 * 1519 *--------------------------------------------------------------------------- 1520 */ 1521 1522int 1523TclGetOpenModeEx( 1524 Tcl_Interp *interp, /* Interpreter to use for error reporting - 1525 * may be NULL. */ 1526 const char *modeString, /* Mode string, e.g. "r+" or "RDONLY CREAT" */ 1527 int *seekFlagPtr, /* Set this to 1 if the caller should seek to 1528 * EOF during the opening of the file. */ 1529 int *binaryPtr) /* Set this to 1 if the caller should 1530 * configure the opened channel for binary 1531 * operations */ 1532{ 1533 int mode, modeArgc, c, i, gotRW; 1534 const char **modeArgv, *flag; 1535#define RW_MODES (O_RDONLY|O_WRONLY|O_RDWR) 1536 1537 /* 1538 * Check for the simpler fopen-like access modes (e.g. "r"). They are 1539 * distinguished from the POSIX access modes by the presence of a 1540 * lower-case first letter. 1541 */ 1542 1543 *seekFlagPtr = 0; 1544 *binaryPtr = 0; 1545 mode = 0; 1546 1547 /* 1548 * Guard against international characters before using byte oriented 1549 * routines. 1550 */ 1551 1552 if (!(modeString[0] & 0x80) 1553 && islower(UCHAR(modeString[0]))) { /* INTL: ISO only. */ 1554 switch (modeString[0]) { 1555 case 'r': 1556 mode = O_RDONLY; 1557 break; 1558 case 'w': 1559 mode = O_WRONLY|O_CREAT|O_TRUNC; 1560 break; 1561 case 'a': 1562 /* 1563 * Added O_APPEND for proper automatic seek-to-end-on-write by the 1564 * OS. [Bug 680143] 1565 */ 1566 1567 mode = O_WRONLY|O_CREAT|O_APPEND; 1568 *seekFlagPtr = 1; 1569 break; 1570 default: 1571 goto error; 1572 } 1573 i=1; 1574 while (i<3 && modeString[i]) { 1575 if (modeString[i] == modeString[i-1]) { 1576 goto error; 1577 } 1578 switch (modeString[i++]) { 1579 case '+': 1580 /* 1581 * Must remove the O_APPEND flag so that the seek command 1582 * works. [Bug 1773127] 1583 */ 1584 1585 mode &= ~(O_RDONLY|O_WRONLY|O_APPEND); 1586 mode |= O_RDWR; 1587 break; 1588 case 'b': 1589 *binaryPtr = 1; 1590 break; 1591 default: 1592 goto error; 1593 } 1594 } 1595 if (modeString[i] != 0) { 1596 goto error; 1597 } 1598 return mode; 1599 1600 error: 1601 *seekFlagPtr = 0; 1602 *binaryPtr = 0; 1603 if (interp != NULL) { 1604 Tcl_AppendResult(interp, "illegal access mode \"", modeString, 1605 "\"", NULL); 1606 } 1607 return -1; 1608 } 1609 1610 /* 1611 * The access modes are specified using a list of POSIX modes such as 1612 * O_CREAT. 1613 * 1614 * IMPORTANT NOTE: We rely on Tcl_SplitList working correctly when a NULL 1615 * interpreter is passed in. 1616 */ 1617 1618 if (Tcl_SplitList(interp, modeString, &modeArgc, &modeArgv) != TCL_OK) { 1619 if (interp != NULL) { 1620 Tcl_AddErrorInfo(interp, 1621 "\n while processing open access modes \""); 1622 Tcl_AddErrorInfo(interp, modeString); 1623 Tcl_AddErrorInfo(interp, "\""); 1624 } 1625 return -1; 1626 } 1627 1628 gotRW = 0; 1629 for (i = 0; i < modeArgc; i++) { 1630 flag = modeArgv[i]; 1631 c = flag[0]; 1632 if ((c == 'R') && (strcmp(flag, "RDONLY") == 0)) { 1633 mode = (mode & ~RW_MODES) | O_RDONLY; 1634 gotRW = 1; 1635 } else if ((c == 'W') && (strcmp(flag, "WRONLY") == 0)) { 1636 mode = (mode & ~RW_MODES) | O_WRONLY; 1637 gotRW = 1; 1638 } else if ((c == 'R') && (strcmp(flag, "RDWR") == 0)) { 1639 mode = (mode & ~RW_MODES) | O_RDWR; 1640 gotRW = 1; 1641 } else if ((c == 'A') && (strcmp(flag, "APPEND") == 0)) { 1642 mode |= O_APPEND; 1643 *seekFlagPtr = 1; 1644 } else if ((c == 'C') && (strcmp(flag, "CREAT") == 0)) { 1645 mode |= O_CREAT; 1646 } else if ((c == 'E') && (strcmp(flag, "EXCL") == 0)) { 1647 mode |= O_EXCL; 1648 1649 } else if ((c == 'N') && (strcmp(flag, "NOCTTY") == 0)) { 1650#ifdef O_NOCTTY 1651 mode |= O_NOCTTY; 1652#else 1653 if (interp != NULL) { 1654 Tcl_AppendResult(interp, "access mode \"", flag, 1655 "\" not supported by this system", NULL); 1656 } 1657 ckfree((char *) modeArgv); 1658 return -1; 1659#endif 1660 1661 } else if ((c == 'N') && (strcmp(flag, "NONBLOCK") == 0)) { 1662#ifdef O_NONBLOCK 1663 mode |= O_NONBLOCK; 1664#else 1665 if (interp != NULL) { 1666 Tcl_AppendResult(interp, "access mode \"", flag, 1667 "\" not supported by this system", NULL); 1668 } 1669 ckfree((char *) modeArgv); 1670 return -1; 1671#endif 1672 1673 } else if ((c == 'T') && (strcmp(flag, "TRUNC") == 0)) { 1674 mode |= O_TRUNC; 1675 } else if ((c == 'B') && (strcmp(flag, "BINARY") == 0)) { 1676 *binaryPtr = 1; 1677 } else { 1678 1679 if (interp != NULL) { 1680 Tcl_AppendResult(interp, "invalid access mode \"", flag, 1681 "\": must be RDONLY, WRONLY, RDWR, APPEND, BINARY, " 1682 "CREAT, EXCL, NOCTTY, NONBLOCK, or TRUNC", NULL); 1683 } 1684 ckfree((char *) modeArgv); 1685 return -1; 1686 } 1687 } 1688 1689 ckfree((char *) modeArgv); 1690 1691 if (!gotRW) { 1692 if (interp != NULL) { 1693 Tcl_AppendResult(interp, "access mode must include either" 1694 " RDONLY, WRONLY, or RDWR", NULL); 1695 } 1696 return -1; 1697 } 1698 return mode; 1699} 1700 1701/* 1702 * Tcl_FSEvalFile is Tcl_FSEvalFileEx without encoding argument. 1703 */ 1704 1705int 1706Tcl_FSEvalFile( 1707 Tcl_Interp *interp, /* Interpreter in which to process file. */ 1708 Tcl_Obj *pathPtr) /* Path of file to process. Tilde-substitution 1709 * will be performed on this name. */ 1710{ 1711 return Tcl_FSEvalFileEx(interp, pathPtr, NULL); 1712} 1713 1714/* 1715 *---------------------------------------------------------------------- 1716 * 1717 * Tcl_FSEvalFileEx -- 1718 * 1719 * Read in a file and process the entire file as one gigantic Tcl 1720 * command. 1721 * 1722 * Results: 1723 * A standard Tcl result, which is either the result of executing the 1724 * file or an error indicating why the file couldn't be read. 1725 * 1726 * Side effects: 1727 * Depends on the commands in the file. During the evaluation of the 1728 * contents of the file, iPtr->scriptFile is made to point to pathPtr 1729 * (the old value is cached and replaced when this function returns). 1730 * 1731 *---------------------------------------------------------------------- 1732 */ 1733 1734int 1735Tcl_FSEvalFileEx( 1736 Tcl_Interp *interp, /* Interpreter in which to process file. */ 1737 Tcl_Obj *pathPtr, /* Path of file to process. Tilde-substitution 1738 * will be performed on this name. */ 1739 const char *encodingName) /* If non-NULL, then use this encoding for the 1740 * file. NULL means use the system encoding. */ 1741{ 1742 int length, result = TCL_ERROR; 1743 Tcl_StatBuf statBuf; 1744 Tcl_Obj *oldScriptFile; 1745 Interp *iPtr; 1746 char *string; 1747 Tcl_Channel chan; 1748 Tcl_Obj *objPtr; 1749 1750 if (Tcl_FSGetNormalizedPath(interp, pathPtr) == NULL) { 1751 return result; 1752 } 1753 1754 if (Tcl_FSStat(pathPtr, &statBuf) == -1) { 1755 Tcl_SetErrno(errno); 1756 Tcl_AppendResult(interp, "couldn't read file \"", 1757 Tcl_GetString(pathPtr), "\": ", Tcl_PosixError(interp), NULL); 1758 return result; 1759 } 1760 chan = Tcl_FSOpenFileChannel(interp, pathPtr, "r", 0644); 1761 if (chan == (Tcl_Channel) NULL) { 1762 Tcl_ResetResult(interp); 1763 Tcl_AppendResult(interp, "couldn't read file \"", 1764 Tcl_GetString(pathPtr), "\": ", Tcl_PosixError(interp), NULL); 1765 return result; 1766 } 1767 1768 /* 1769 * The eofchar is \32 (^Z). This is the usual on Windows, but we effect 1770 * this cross-platform to allow for scripted documents. [Bug: 2040] 1771 */ 1772 1773 Tcl_SetChannelOption(interp, chan, "-eofchar", "\32"); 1774 1775 /* 1776 * If the encoding is specified, set it for the channel. Else don't touch 1777 * it (and use the system encoding) Report error on unknown encoding. 1778 */ 1779 1780 if (encodingName != NULL) { 1781 if (Tcl_SetChannelOption(interp, chan, "-encoding", encodingName) 1782 != TCL_OK) { 1783 Tcl_Close(interp,chan); 1784 return result; 1785 } 1786 } 1787 1788 objPtr = Tcl_NewObj(); 1789 Tcl_IncrRefCount(objPtr); 1790 if (Tcl_ReadChars(chan, objPtr, -1, 0) < 0) { 1791 Tcl_Close(interp, chan); 1792 Tcl_AppendResult(interp, "couldn't read file \"", 1793 Tcl_GetString(pathPtr), "\": ", Tcl_PosixError(interp), NULL); 1794 goto end; 1795 } 1796 1797 if (Tcl_Close(interp, chan) != TCL_OK) { 1798 goto end; 1799 } 1800 1801 iPtr = (Interp *) interp; 1802 oldScriptFile = iPtr->scriptFile; 1803 iPtr->scriptFile = pathPtr; 1804 Tcl_IncrRefCount(iPtr->scriptFile); 1805 string = Tcl_GetStringFromObj(objPtr, &length); 1806 /* TIP #280 Force the evaluator to open a frame for a sourced 1807 * file. */ 1808 iPtr->evalFlags |= TCL_EVAL_FILE; 1809 result = Tcl_EvalEx(interp, string, length, 0); 1810 1811 /* 1812 * Now we have to be careful; the script may have changed the 1813 * iPtr->scriptFile value, so we must reset it without assuming it still 1814 * points to 'pathPtr'. 1815 */ 1816 1817 if (iPtr->scriptFile != NULL) { 1818 Tcl_DecrRefCount(iPtr->scriptFile); 1819 } 1820 iPtr->scriptFile = oldScriptFile; 1821 1822 if (result == TCL_RETURN) { 1823 result = TclUpdateReturnInfo(iPtr); 1824 } else if (result == TCL_ERROR) { 1825 /* 1826 * Record information telling where the error occurred. 1827 */ 1828 1829 const char *pathString = Tcl_GetStringFromObj(pathPtr, &length); 1830 int limit = 150; 1831 int overflow = (length > limit); 1832 1833 Tcl_AppendObjToErrorInfo(interp, Tcl_ObjPrintf( 1834 "\n (file \"%.*s%s\" line %d)", 1835 (overflow ? limit : length), pathString, 1836 (overflow ? "..." : ""), interp->errorLine)); 1837 } 1838 1839 end: 1840 Tcl_DecrRefCount(objPtr); 1841 return result; 1842} 1843 1844/* 1845 *---------------------------------------------------------------------- 1846 * 1847 * Tcl_GetErrno -- 1848 * 1849 * Gets the current value of the Tcl error code variable. This is 1850 * currently the global variable "errno" but could in the future change 1851 * to something else. 1852 * 1853 * Results: 1854 * The value of the Tcl error code variable. 1855 * 1856 * Side effects: 1857 * None. Note that the value of the Tcl error code variable is UNDEFINED 1858 * if a call to Tcl_SetErrno did not precede this call. 1859 * 1860 *---------------------------------------------------------------------- 1861 */ 1862 1863int 1864Tcl_GetErrno(void) 1865{ 1866 return errno; 1867} 1868 1869/* 1870 *---------------------------------------------------------------------- 1871 * 1872 * Tcl_SetErrno -- 1873 * 1874 * Sets the Tcl error code variable to the supplied value. 1875 * 1876 * Results: 1877 * None. 1878 * 1879 * Side effects: 1880 * Modifies the value of the Tcl error code variable. 1881 * 1882 *---------------------------------------------------------------------- 1883 */ 1884 1885void 1886Tcl_SetErrno( 1887 int err) /* The new value. */ 1888{ 1889 errno = err; 1890} 1891 1892/* 1893 *---------------------------------------------------------------------- 1894 * 1895 * Tcl_PosixError -- 1896 * 1897 * This function is typically called after UNIX kernel calls return 1898 * errors. It stores machine-readable information about the error in 1899 * errorCode field of interp and returns an information string for the 1900 * caller's use. 1901 * 1902 * Results: 1903 * The return value is a human-readable string describing the error. 1904 * 1905 * Side effects: 1906 * The errorCode field of the interp is set. 1907 * 1908 *---------------------------------------------------------------------- 1909 */ 1910 1911const char * 1912Tcl_PosixError( 1913 Tcl_Interp *interp) /* Interpreter whose errorCode field is to be 1914 * set. */ 1915{ 1916 const char *id, *msg; 1917 1918 msg = Tcl_ErrnoMsg(errno); 1919 id = Tcl_ErrnoId(); 1920 if (interp) { 1921 Tcl_SetErrorCode(interp, "POSIX", id, msg, NULL); 1922 } 1923 return msg; 1924} 1925 1926/* 1927 *---------------------------------------------------------------------- 1928 * 1929 * Tcl_FSStat -- 1930 * 1931 * This function replaces the library version of stat and lsat. 1932 * 1933 * The appropriate function for the filesystem to which pathPtr belongs 1934 * will be called. 1935 * 1936 * Results: 1937 * See stat documentation. 1938 * 1939 * Side effects: 1940 * See stat documentation. 1941 * 1942 *---------------------------------------------------------------------- 1943 */ 1944 1945int 1946Tcl_FSStat( 1947 Tcl_Obj *pathPtr, /* Path of file to stat (in current CP). */ 1948 Tcl_StatBuf *buf) /* Filled with results of stat call. */ 1949{ 1950 const Tcl_Filesystem *fsPtr; 1951#ifdef USE_OBSOLETE_FS_HOOKS 1952 struct stat oldStyleStatBuffer; 1953 int retVal = -1; 1954 1955 /* 1956 * Call each of the "stat" function in succession. A non-return value of 1957 * -1 indicates the particular function has succeeded. 1958 */ 1959 1960 Tcl_MutexLock(&obsoleteFsHookMutex); 1961 1962 if (statProcList != NULL) { 1963 StatProc *statProcPtr; 1964 char *path; 1965 Tcl_Obj *transPtr = Tcl_FSGetTranslatedPath(NULL, pathPtr); 1966 if (transPtr == NULL) { 1967 path = NULL; 1968 } else { 1969 path = Tcl_GetString(transPtr); 1970 } 1971 1972 statProcPtr = statProcList; 1973 while ((retVal == -1) && (statProcPtr != NULL)) { 1974 retVal = (*statProcPtr->proc)(path, &oldStyleStatBuffer); 1975 statProcPtr = statProcPtr->nextPtr; 1976 } 1977 if (transPtr != NULL) { 1978 Tcl_DecrRefCount(transPtr); 1979 } 1980 } 1981 1982 Tcl_MutexUnlock(&obsoleteFsHookMutex); 1983 if (retVal != -1) { 1984 /* 1985 * Note that EOVERFLOW is not a problem here, and these assignments 1986 * should all be widening (if not identity.) 1987 */ 1988 1989 buf->st_mode = oldStyleStatBuffer.st_mode; 1990 buf->st_ino = oldStyleStatBuffer.st_ino; 1991 buf->st_dev = oldStyleStatBuffer.st_dev; 1992 buf->st_rdev = oldStyleStatBuffer.st_rdev; 1993 buf->st_nlink = oldStyleStatBuffer.st_nlink; 1994 buf->st_uid = oldStyleStatBuffer.st_uid; 1995 buf->st_gid = oldStyleStatBuffer.st_gid; 1996 buf->st_size = Tcl_LongAsWide(oldStyleStatBuffer.st_size); 1997 buf->st_atime = oldStyleStatBuffer.st_atime; 1998 buf->st_mtime = oldStyleStatBuffer.st_mtime; 1999 buf->st_ctime = oldStyleStatBuffer.st_ctime; 2000#ifdef HAVE_STRUCT_STAT_ST_BLKSIZE 2001 buf->st_blksize = oldStyleStatBuffer.st_blksize; 2002#endif 2003#ifdef HAVE_STRUCT_STAT_ST_BLOCKS 2004 buf->st_blocks = Tcl_LongAsWide(oldStyleStatBuffer.st_blocks); 2005#endif 2006 return retVal; 2007 } 2008#endif /* USE_OBSOLETE_FS_HOOKS */ 2009 2010 fsPtr = Tcl_FSGetFileSystemForPath(pathPtr); 2011 if (fsPtr != NULL) { 2012 Tcl_FSStatProc *proc = fsPtr->statProc; 2013 if (proc != NULL) { 2014 return (*proc)(pathPtr, buf); 2015 } 2016 } 2017 Tcl_SetErrno(ENOENT); 2018 return -1; 2019} 2020 2021/* 2022 *---------------------------------------------------------------------- 2023 * 2024 * Tcl_FSLstat -- 2025 * 2026 * This function replaces the library version of lstat. The appropriate 2027 * function for the filesystem to which pathPtr belongs will be called. 2028 * If no 'lstat' function is listed, but a 'stat' function is, then Tcl 2029 * will fall back on the stat function. 2030 * 2031 * Results: 2032 * See lstat documentation. 2033 * 2034 * Side effects: 2035 * See lstat documentation. 2036 * 2037 *---------------------------------------------------------------------- 2038 */ 2039 2040int 2041Tcl_FSLstat( 2042 Tcl_Obj *pathPtr, /* Path of file to stat (in current CP). */ 2043 Tcl_StatBuf *buf) /* Filled with results of stat call. */ 2044{ 2045 const Tcl_Filesystem *fsPtr = Tcl_FSGetFileSystemForPath(pathPtr); 2046 if (fsPtr != NULL) { 2047 Tcl_FSLstatProc *proc = fsPtr->lstatProc; 2048 if (proc != NULL) { 2049 return (*proc)(pathPtr, buf); 2050 } else { 2051 Tcl_FSStatProc *sproc = fsPtr->statProc; 2052 if (sproc != NULL) { 2053 return (*sproc)(pathPtr, buf); 2054 } 2055 } 2056 } 2057 Tcl_SetErrno(ENOENT); 2058 return -1; 2059} 2060 2061/* 2062 *---------------------------------------------------------------------- 2063 * 2064 * Tcl_FSAccess -- 2065 * 2066 * This function replaces the library version of access. The appropriate 2067 * function for the filesystem to which pathPtr belongs will be called. 2068 * 2069 * Results: 2070 * See access documentation. 2071 * 2072 * Side effects: 2073 * See access documentation. 2074 * 2075 *---------------------------------------------------------------------- 2076 */ 2077 2078int 2079Tcl_FSAccess( 2080 Tcl_Obj *pathPtr, /* Path of file to access (in current CP). */ 2081 int mode) /* Permission setting. */ 2082{ 2083 const Tcl_Filesystem *fsPtr; 2084#ifdef USE_OBSOLETE_FS_HOOKS 2085 int retVal = -1; 2086 2087 /* 2088 * Call each of the "access" function in succession. A non-return value of 2089 * -1 indicates the particular function has succeeded. 2090 */ 2091 2092 Tcl_MutexLock(&obsoleteFsHookMutex); 2093 2094 if (accessProcList != NULL) { 2095 AccessProc *accessProcPtr; 2096 char *path; 2097 Tcl_Obj *transPtr = Tcl_FSGetTranslatedPath(NULL, pathPtr); 2098 if (transPtr == NULL) { 2099 path = NULL; 2100 } else { 2101 path = Tcl_GetString(transPtr); 2102 } 2103 2104 accessProcPtr = accessProcList; 2105 while ((retVal == -1) && (accessProcPtr != NULL)) { 2106 retVal = (*accessProcPtr->proc)(path, mode); 2107 accessProcPtr = accessProcPtr->nextPtr; 2108 } 2109 if (transPtr != NULL) { 2110 Tcl_DecrRefCount(transPtr); 2111 } 2112 } 2113 2114 Tcl_MutexUnlock(&obsoleteFsHookMutex); 2115 if (retVal != -1) { 2116 return retVal; 2117 } 2118#endif /* USE_OBSOLETE_FS_HOOKS */ 2119 2120 fsPtr = Tcl_FSGetFileSystemForPath(pathPtr); 2121 if (fsPtr != NULL) { 2122 Tcl_FSAccessProc *proc = fsPtr->accessProc; 2123 if (proc != NULL) { 2124 return (*proc)(pathPtr, mode); 2125 } 2126 } 2127 2128 Tcl_SetErrno(ENOENT); 2129 return -1; 2130} 2131 2132/* 2133 *---------------------------------------------------------------------- 2134 * 2135 * Tcl_FSOpenFileChannel -- 2136 * 2137 * The appropriate function for the filesystem to which pathPtr belongs 2138 * will be called. 2139 * 2140 * Results: 2141 * The new channel or NULL, if the named file could not be opened. 2142 * 2143 * Side effects: 2144 * May open the channel and may cause creation of a file on the file 2145 * system. 2146 * 2147 *---------------------------------------------------------------------- 2148 */ 2149 2150Tcl_Channel 2151Tcl_FSOpenFileChannel( 2152 Tcl_Interp *interp, /* Interpreter for error reporting; can be 2153 * NULL. */ 2154 Tcl_Obj *pathPtr, /* Name of file to open. */ 2155 const char *modeString, /* A list of POSIX open modes or a string such 2156 * as "rw". */ 2157 int permissions) /* If the open involves creating a file, with 2158 * what modes to create it? */ 2159{ 2160 const Tcl_Filesystem *fsPtr; 2161 Tcl_Channel retVal = NULL; 2162 2163#ifdef USE_OBSOLETE_FS_HOOKS 2164 /* 2165 * Call each of the "Tcl_OpenFileChannel" functions in succession. A 2166 * non-NULL return value indicates the particular function has succeeded. 2167 */ 2168 2169 Tcl_MutexLock(&obsoleteFsHookMutex); 2170 if (openFileChannelProcList != NULL) { 2171 OpenFileChannelProc *openFileChannelProcPtr; 2172 char *path; 2173 Tcl_Obj *transPtr = Tcl_FSGetTranslatedPath(interp, pathPtr); 2174 2175 if (transPtr == NULL) { 2176 path = NULL; 2177 } else { 2178 path = Tcl_GetString(transPtr); 2179 } 2180 2181 openFileChannelProcPtr = openFileChannelProcList; 2182 2183 while ((retVal == NULL) && (openFileChannelProcPtr != NULL)) { 2184 retVal = (*openFileChannelProcPtr->proc)(interp, path, 2185 modeString, permissions); 2186 openFileChannelProcPtr = openFileChannelProcPtr->nextPtr; 2187 } 2188 if (transPtr != NULL) { 2189 Tcl_DecrRefCount(transPtr); 2190 } 2191 } 2192 Tcl_MutexUnlock(&obsoleteFsHookMutex); 2193 if (retVal != NULL) { 2194 return retVal; 2195 } 2196#endif /* USE_OBSOLETE_FS_HOOKS */ 2197 2198 /* 2199 * We need this just to ensure we return the correct error messages under 2200 * some circumstances. 2201 */ 2202 2203 if (Tcl_FSGetNormalizedPath(interp, pathPtr) == NULL) { 2204 return NULL; 2205 } 2206 2207 fsPtr = Tcl_FSGetFileSystemForPath(pathPtr); 2208 if (fsPtr != NULL) { 2209 Tcl_FSOpenFileChannelProc *proc = fsPtr->openFileChannelProc; 2210 if (proc != NULL) { 2211 int mode, seekFlag, binary; 2212 2213 /* 2214 * Parse the mode, picking up whether we want to seek to start 2215 * with and/or set the channel automatically into binary mode. 2216 */ 2217 2218 mode = TclGetOpenModeEx(interp, modeString, &seekFlag, &binary); 2219 if (mode == -1) { 2220 return NULL; 2221 } 2222 2223 /* 2224 * Do the actual open() call. 2225 */ 2226 2227 retVal = (*proc)(interp, pathPtr, mode, permissions); 2228 if (retVal == NULL) { 2229 return NULL; 2230 } 2231 2232 /* 2233 * Apply appropriate flags parsed out above. 2234 */ 2235 2236 if (seekFlag && Tcl_Seek(retVal, (Tcl_WideInt)0, 2237 SEEK_END) < (Tcl_WideInt)0) { 2238 if (interp != NULL) { 2239 Tcl_AppendResult(interp, "could not seek to end " 2240 "of file while opening \"", Tcl_GetString(pathPtr), 2241 "\": ", Tcl_PosixError(interp), NULL); 2242 } 2243 Tcl_Close(NULL, retVal); 2244 return NULL; 2245 } 2246 if (binary) { 2247 Tcl_SetChannelOption(interp, retVal, "-translation", "binary"); 2248 } 2249 return retVal; 2250 } 2251 } 2252 2253 /* 2254 * File doesn't belong to any filesystem that can open it. 2255 */ 2256 2257 Tcl_SetErrno(ENOENT); 2258 if (interp != NULL) { 2259 Tcl_AppendResult(interp, "couldn't open \"", Tcl_GetString(pathPtr), 2260 "\": ", Tcl_PosixError(interp), NULL); 2261 } 2262 return NULL; 2263} 2264 2265/* 2266 *---------------------------------------------------------------------- 2267 * 2268 * Tcl_FSUtime -- 2269 * 2270 * This function replaces the library version of utime. The appropriate 2271 * function for the filesystem to which pathPtr belongs will be called. 2272 * 2273 * Results: 2274 * See utime documentation. 2275 * 2276 * Side effects: 2277 * See utime documentation. 2278 * 2279 *---------------------------------------------------------------------- 2280 */ 2281 2282int 2283Tcl_FSUtime( 2284 Tcl_Obj *pathPtr, /* File to change access/modification times */ 2285 struct utimbuf *tval) /* Structure containing access/modification 2286 * times to use. Should not be modified. */ 2287{ 2288 const Tcl_Filesystem *fsPtr = Tcl_FSGetFileSystemForPath(pathPtr); 2289 if (fsPtr != NULL) { 2290 Tcl_FSUtimeProc *proc = fsPtr->utimeProc; 2291 if (proc != NULL) { 2292 return (*proc)(pathPtr, tval); 2293 } 2294 } 2295 return -1; 2296} 2297 2298/* 2299 *---------------------------------------------------------------------- 2300 * 2301 * NativeFileAttrStrings -- 2302 * 2303 * This function implements the platform dependent 'file attributes' 2304 * subcommand, for the native filesystem, for listing the set of possible 2305 * attribute strings. This function is part of Tcl's native filesystem 2306 * support, and is placed here because it is shared by Unix and Windows 2307 * code. 2308 * 2309 * Results: 2310 * An array of strings 2311 * 2312 * Side effects: 2313 * None. 2314 * 2315 *---------------------------------------------------------------------- 2316 */ 2317 2318static const char ** 2319NativeFileAttrStrings( 2320 Tcl_Obj *pathPtr, 2321 Tcl_Obj **objPtrRef) 2322{ 2323 return tclpFileAttrStrings; 2324} 2325 2326/* 2327 *---------------------------------------------------------------------- 2328 * 2329 * NativeFileAttrsGet -- 2330 * 2331 * This function implements the platform dependent 'file attributes' 2332 * subcommand, for the native filesystem, for 'get' operations. This 2333 * function is part of Tcl's native filesystem support, and is placed 2334 * here because it is shared by Unix and Windows code. 2335 * 2336 * Results: 2337 * Standard Tcl return code. The object placed in objPtrRef (if TCL_OK 2338 * was returned) is likely to have a refCount of zero. Either way we must 2339 * either store it somewhere (e.g. the Tcl result), or Incr/Decr its 2340 * refCount to ensure it is properly freed. 2341 * 2342 * Side effects: 2343 * None. 2344 * 2345 *---------------------------------------------------------------------- 2346 */ 2347 2348static int 2349NativeFileAttrsGet( 2350 Tcl_Interp *interp, /* The interpreter for error reporting. */ 2351 int index, /* index of the attribute command. */ 2352 Tcl_Obj *pathPtr, /* path of file we are operating on. */ 2353 Tcl_Obj **objPtrRef) /* for output. */ 2354{ 2355 return (*tclpFileAttrProcs[index].getProc)(interp, index, pathPtr, 2356 objPtrRef); 2357} 2358 2359/* 2360 *---------------------------------------------------------------------- 2361 * 2362 * NativeFileAttrsSet -- 2363 * 2364 * This function implements the platform dependent 'file attributes' 2365 * subcommand, for the native filesystem, for 'set' operations. This 2366 * function is part of Tcl's native filesystem support, and is placed 2367 * here because it is shared by Unix and Windows code. 2368 * 2369 * Results: 2370 * Standard Tcl return code. 2371 * 2372 * Side effects: 2373 * None. 2374 * 2375 *---------------------------------------------------------------------- 2376 */ 2377 2378static int 2379NativeFileAttrsSet( 2380 Tcl_Interp *interp, /* The interpreter for error reporting. */ 2381 int index, /* index of the attribute command. */ 2382 Tcl_Obj *pathPtr, /* path of file we are operating on. */ 2383 Tcl_Obj *objPtr) /* set to this value. */ 2384{ 2385 return (*tclpFileAttrProcs[index].setProc)(interp, index, pathPtr, objPtr); 2386} 2387 2388/* 2389 *---------------------------------------------------------------------- 2390 * 2391 * Tcl_FSFileAttrStrings -- 2392 * 2393 * This function implements part of the hookable 'file attributes' 2394 * subcommand. The appropriate function for the filesystem to which 2395 * pathPtr belongs will be called. 2396 * 2397 * Results: 2398 * The called function may either return an array of strings, or may 2399 * instead return NULL and place a Tcl list into the given objPtrRef. 2400 * Tcl will take that list and first increment its refCount before using 2401 * it. On completion of that use, Tcl will decrement its refCount. Hence 2402 * if the list should be disposed of by Tcl when done, it should have a 2403 * refCount of zero, and if the list should not be disposed of, the 2404 * filesystem should ensure it retains a refCount on the object. 2405 * 2406 * Side effects: 2407 * None. 2408 * 2409 *---------------------------------------------------------------------- 2410 */ 2411 2412const char ** 2413Tcl_FSFileAttrStrings( 2414 Tcl_Obj *pathPtr, 2415 Tcl_Obj **objPtrRef) 2416{ 2417 const Tcl_Filesystem *fsPtr = Tcl_FSGetFileSystemForPath(pathPtr); 2418 2419 if (fsPtr != NULL) { 2420 Tcl_FSFileAttrStringsProc *proc = fsPtr->fileAttrStringsProc; 2421 if (proc != NULL) { 2422 return (*proc)(pathPtr, objPtrRef); 2423 } 2424 } 2425 Tcl_SetErrno(ENOENT); 2426 return NULL; 2427} 2428 2429/* 2430 *---------------------------------------------------------------------- 2431 * 2432 * TclFSFileAttrIndex -- 2433 * 2434 * Helper function for converting an attribute name to an index into the 2435 * attribute table. 2436 * 2437 * Results: 2438 * Tcl result code, index written to *indexPtr on result==TCL_OK 2439 * 2440 * Side effects: 2441 * None. 2442 * 2443 *---------------------------------------------------------------------- 2444 */ 2445 2446int 2447TclFSFileAttrIndex( 2448 Tcl_Obj *pathPtr, /* File whose attributes are to be indexed 2449 * into. */ 2450 const char *attributeName, /* The attribute being looked for. */ 2451 int *indexPtr) /* Where to write the found index. */ 2452{ 2453 Tcl_Obj *listObj = NULL; 2454 const char **attrTable; 2455 2456 /* 2457 * Get the attribute table for the file. 2458 */ 2459 2460 attrTable = Tcl_FSFileAttrStrings(pathPtr, &listObj); 2461 if (listObj != NULL) { 2462 Tcl_IncrRefCount(listObj); 2463 } 2464 2465 if (attrTable != NULL) { 2466 /* 2467 * It's a constant attribute table, so use T_GIFO. 2468 */ 2469 2470 Tcl_Obj *tmpObj = Tcl_NewStringObj(attributeName, -1); 2471 int result; 2472 2473 result = Tcl_GetIndexFromObj(NULL, tmpObj, attrTable, NULL, TCL_EXACT, 2474 indexPtr); 2475 TclDecrRefCount(tmpObj); 2476 if (listObj != NULL) { 2477 TclDecrRefCount(listObj); 2478 } 2479 return result; 2480 } else if (listObj != NULL) { 2481 /* 2482 * It's a non-constant attribute list, so do a literal search. 2483 */ 2484 2485 int i, objc; 2486 Tcl_Obj **objv; 2487 2488 if (Tcl_ListObjGetElements(NULL, listObj, &objc, &objv) != TCL_OK) { 2489 TclDecrRefCount(listObj); 2490 return TCL_ERROR; 2491 } 2492 for (i=0 ; i<objc ; i++) { 2493 if (!strcmp(attributeName, TclGetString(objv[i]))) { 2494 TclDecrRefCount(listObj); 2495 *indexPtr = i; 2496 return TCL_OK; 2497 } 2498 } 2499 TclDecrRefCount(listObj); 2500 return TCL_ERROR; 2501 } else { 2502 return TCL_ERROR; 2503 } 2504} 2505 2506/* 2507 *---------------------------------------------------------------------- 2508 * 2509 * Tcl_FSFileAttrsGet -- 2510 * 2511 * This function implements read access for the hookable 'file 2512 * attributes' subcommand. The appropriate function for the filesystem to 2513 * which pathPtr belongs will be called. 2514 * 2515 * Results: 2516 * Standard Tcl return code. The object placed in objPtrRef (if TCL_OK 2517 * was returned) is likely to have a refCount of zero. Either way we must 2518 * either store it somewhere (e.g. the Tcl result), or Incr/Decr its 2519 * refCount to ensure it is properly freed. 2520 * 2521 * Side effects: 2522 * None. 2523 * 2524 *---------------------------------------------------------------------- 2525 */ 2526 2527int 2528Tcl_FSFileAttrsGet( 2529 Tcl_Interp *interp, /* The interpreter for error reporting. */ 2530 int index, /* index of the attribute command. */ 2531 Tcl_Obj *pathPtr, /* filename we are operating on. */ 2532 Tcl_Obj **objPtrRef) /* for output. */ 2533{ 2534 const Tcl_Filesystem *fsPtr = Tcl_FSGetFileSystemForPath(pathPtr); 2535 2536 if (fsPtr != NULL) { 2537 Tcl_FSFileAttrsGetProc *proc = fsPtr->fileAttrsGetProc; 2538 if (proc != NULL) { 2539 return (*proc)(interp, index, pathPtr, objPtrRef); 2540 } 2541 } 2542 Tcl_SetErrno(ENOENT); 2543 return -1; 2544} 2545 2546/* 2547 *---------------------------------------------------------------------- 2548 * 2549 * Tcl_FSFileAttrsSet -- 2550 * 2551 * This function implements write access for the hookable 'file 2552 * attributes' subcommand. The appropriate function for the filesystem to 2553 * which pathPtr belongs will be called. 2554 * 2555 * Results: 2556 * Standard Tcl return code. 2557 * 2558 * Side effects: 2559 * None. 2560 * 2561 *---------------------------------------------------------------------- 2562 */ 2563 2564int 2565Tcl_FSFileAttrsSet( 2566 Tcl_Interp *interp, /* The interpreter for error reporting. */ 2567 int index, /* index of the attribute command. */ 2568 Tcl_Obj *pathPtr, /* filename we are operating on. */ 2569 Tcl_Obj *objPtr) /* Input value. */ 2570{ 2571 const Tcl_Filesystem *fsPtr = Tcl_FSGetFileSystemForPath(pathPtr); 2572 2573 if (fsPtr != NULL) { 2574 Tcl_FSFileAttrsSetProc *proc = fsPtr->fileAttrsSetProc; 2575 if (proc != NULL) { 2576 return (*proc)(interp, index, pathPtr, objPtr); 2577 } 2578 } 2579 Tcl_SetErrno(ENOENT); 2580 return -1; 2581} 2582 2583/* 2584 *---------------------------------------------------------------------- 2585 * 2586 * Tcl_FSGetCwd -- 2587 * 2588 * This function replaces the library version of getcwd(). 2589 * 2590 * Most VFS's will *not* implement a 'cwdProc'. Tcl now maintains its own 2591 * record (in a Tcl_Obj) of the cwd, and an attempt is made to synch this 2592 * with the cwd's containing filesystem, if that filesystem provides a 2593 * cwdProc (e.g. the native filesystem). 2594 * 2595 * Note that if Tcl's cwd is not in the native filesystem, then of course 2596 * Tcl's cwd and the native cwd are different: extensions should 2597 * therefore ensure they only access the cwd through this function to 2598 * avoid confusion. 2599 * 2600 * If a global cwdPathPtr already exists, it is cached in the thread's 2601 * private data structures and reference to the cached copy is returned, 2602 * subject to a synchronisation attempt in that cwdPathPtr's fs. 2603 * 2604 * Otherwise, the chain of functions that have been "inserted" into the 2605 * filesystem will be called in succession until either a value other 2606 * than NULL is returned, or the entire list is visited. 2607 * 2608 * Results: 2609 * The result is a pointer to a Tcl_Obj specifying the current directory, 2610 * or NULL if the current directory could not be determined. If NULL is 2611 * returned, an error message is left in the interp's result. 2612 * 2613 * The result already has its refCount incremented for the caller. When 2614 * it is no longer needed, that refCount should be decremented. 2615 * 2616 * Side effects: 2617 * Various objects may be freed and allocated. 2618 * 2619 *---------------------------------------------------------------------- 2620 */ 2621 2622Tcl_Obj * 2623Tcl_FSGetCwd( 2624 Tcl_Interp *interp) 2625{ 2626 ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&tclFsDataKey); 2627 2628 if (TclFSCwdPointerEquals(NULL)) { 2629 FilesystemRecord *fsRecPtr; 2630 Tcl_Obj *retVal = NULL; 2631 2632 /* 2633 * We've never been called before, try to find a cwd. Call each of the 2634 * "Tcl_GetCwd" function in succession. A non-NULL return value 2635 * indicates the particular function has succeeded. 2636 */ 2637 2638 fsRecPtr = FsGetFirstFilesystem(); 2639 while ((retVal == NULL) && (fsRecPtr != NULL)) { 2640 Tcl_FSGetCwdProc *proc = fsRecPtr->fsPtr->getCwdProc; 2641 if (proc != NULL) { 2642 if (fsRecPtr->fsPtr->version != TCL_FILESYSTEM_VERSION_1) { 2643 ClientData retCd; 2644 TclFSGetCwdProc2 *proc2 = (TclFSGetCwdProc2*)proc; 2645 2646 retCd = (*proc2)(NULL); 2647 if (retCd != NULL) { 2648 Tcl_Obj *norm; 2649 /* Looks like a new current directory */ 2650 retVal = (*fsRecPtr->fsPtr->internalToNormalizedProc)( 2651 retCd); 2652 Tcl_IncrRefCount(retVal); 2653 norm = TclFSNormalizeAbsolutePath(interp,retVal,NULL); 2654 if (norm != NULL) { 2655 /* 2656 * We found a cwd, which is now in our global 2657 * storage. We must make a copy. Norm already has 2658 * a refCount of 1. 2659 * 2660 * Threading issue: note that multiple threads at 2661 * system startup could in principle call this 2662 * function simultaneously. They will therefore 2663 * each set the cwdPathPtr independently. That 2664 * behaviour is a bit peculiar, but should be 2665 * fine. Once we have a cwd, we'll always be in 2666 * the 'else' branch below which is simpler. 2667 */ 2668 2669 FsUpdateCwd(norm, retCd); 2670 Tcl_DecrRefCount(norm); 2671 } else { 2672 (*fsRecPtr->fsPtr->freeInternalRepProc)(retCd); 2673 } 2674 Tcl_DecrRefCount(retVal); 2675 retVal = NULL; 2676 goto cdDidNotChange; 2677 } else if (interp != NULL) { 2678 Tcl_AppendResult(interp, 2679 "error getting working directory name: ", 2680 Tcl_PosixError(interp), NULL); 2681 } 2682 } else { 2683 retVal = (*proc)(interp); 2684 } 2685 } 2686 fsRecPtr = fsRecPtr->nextPtr; 2687 } 2688 2689 /* 2690 * Now the 'cwd' may NOT be normalized, at least on some platforms. 2691 * For the sake of efficiency, we want a completely normalized cwd at 2692 * all times. 2693 * 2694 * Finally, if retVal is NULL, we do not have a cwd, which could be 2695 * problematic. 2696 */ 2697 2698 if (retVal != NULL) { 2699 Tcl_Obj *norm = TclFSNormalizeAbsolutePath(interp, retVal, NULL); 2700 if (norm != NULL) { 2701 /* 2702 * We found a cwd, which is now in our global storage. We must 2703 * make a copy. Norm already has a refCount of 1. 2704 * 2705 * Threading issue: note that multiple threads at system 2706 * startup could in principle call this function 2707 * simultaneously. They will therefore each set the cwdPathPtr 2708 * independently. That behaviour is a bit peculiar, but should 2709 * be fine. Once we have a cwd, we'll always be in the 'else' 2710 * branch below which is simpler. 2711 */ 2712 2713 ClientData cd = (ClientData) Tcl_FSGetNativePath(norm); 2714 FsUpdateCwd(norm, TclNativeDupInternalRep(cd)); 2715 Tcl_DecrRefCount(norm); 2716 } 2717 Tcl_DecrRefCount(retVal); 2718 } 2719 } else { 2720 /* 2721 * We already have a cwd cached, but we want to give the filesystem it 2722 * is in a chance to check whether that cwd has changed, or is perhaps 2723 * no longer accessible. This allows an error to be thrown if, say, 2724 * the permissions on that directory have changed. 2725 */ 2726 2727 const Tcl_Filesystem *fsPtr = Tcl_FSGetFileSystemForPath(tsdPtr->cwdPathPtr); 2728 2729 /* 2730 * If the filesystem couldn't be found, or if no cwd function exists 2731 * for this filesystem, then we simply assume the cached cwd is ok. 2732 * If we do call a cwd, we must watch for errors (if the cwd returns 2733 * NULL). This ensures that, say, on Unix if the permissions of the 2734 * cwd change, 'pwd' does actually throw the correct error in Tcl. 2735 * (This is tested for in the test suite on unix). 2736 */ 2737 2738 if (fsPtr != NULL) { 2739 Tcl_FSGetCwdProc *proc = fsPtr->getCwdProc; 2740 ClientData retCd = NULL; 2741 if (proc != NULL) { 2742 Tcl_Obj *retVal; 2743 if (fsPtr->version != TCL_FILESYSTEM_VERSION_1) { 2744 TclFSGetCwdProc2 *proc2 = (TclFSGetCwdProc2*)proc; 2745 2746 retCd = (*proc2)(tsdPtr->cwdClientData); 2747 if (retCd == NULL && interp != NULL) { 2748 Tcl_AppendResult(interp, 2749 "error getting working directory name: ", 2750 Tcl_PosixError(interp), NULL); 2751 } 2752 2753 if (retCd == tsdPtr->cwdClientData) { 2754 goto cdDidNotChange; 2755 } 2756 2757 /* 2758 * Looks like a new current directory. 2759 */ 2760 2761 retVal = (*fsPtr->internalToNormalizedProc)(retCd); 2762 Tcl_IncrRefCount(retVal); 2763 } else { 2764 retVal = (*proc)(interp); 2765 } 2766 if (retVal != NULL) { 2767 Tcl_Obj *norm = TclFSNormalizeAbsolutePath(interp, 2768 retVal, NULL); 2769 2770 /* 2771 * Check whether cwd has changed from the value previously 2772 * stored in cwdPathPtr. Really 'norm' shouldn't be NULL, 2773 * but we are careful. 2774 */ 2775 2776 if (norm == NULL) { 2777 /* Do nothing */ 2778 if (retCd != NULL) { 2779 (*fsPtr->freeInternalRepProc)(retCd); 2780 } 2781 } else if (norm == tsdPtr->cwdPathPtr) { 2782 goto cdEqual; 2783 } else { 2784 /* 2785 * Note that both 'norm' and 'tsdPtr->cwdPathPtr' are 2786 * normalized paths. Therefore we can be more 2787 * efficient than calling 'Tcl_FSEqualPaths', and in 2788 * addition avoid a nasty infinite loop bug when 2789 * trying to normalize tsdPtr->cwdPathPtr. 2790 */ 2791 2792 int len1, len2; 2793 char *str1, *str2; 2794 2795 str1 = Tcl_GetStringFromObj(tsdPtr->cwdPathPtr, &len1); 2796 str2 = Tcl_GetStringFromObj(norm, &len2); 2797 if ((len1 == len2) && (strcmp(str1, str2) == 0)) { 2798 /* 2799 * If the paths were equal, we can be more 2800 * efficient and retain the old path object which 2801 * will probably already be shared. In this case 2802 * we can simply free the normalized path we just 2803 * calculated. 2804 */ 2805 2806 cdEqual: 2807 Tcl_DecrRefCount(norm); 2808 if (retCd != NULL) { 2809 (*fsPtr->freeInternalRepProc)(retCd); 2810 } 2811 } else { 2812 FsUpdateCwd(norm, retCd); 2813 Tcl_DecrRefCount(norm); 2814 } 2815 } 2816 Tcl_DecrRefCount(retVal); 2817 } else { 2818 /* 2819 * The 'cwd' function returned an error; reset the cwd. 2820 */ 2821 2822 FsUpdateCwd(NULL, NULL); 2823 } 2824 } 2825 } 2826 } 2827 2828 cdDidNotChange: 2829 if (tsdPtr->cwdPathPtr != NULL) { 2830 Tcl_IncrRefCount(tsdPtr->cwdPathPtr); 2831 } 2832 2833 return tsdPtr->cwdPathPtr; 2834} 2835 2836/* 2837 *---------------------------------------------------------------------- 2838 * 2839 * Tcl_FSChdir -- 2840 * 2841 * This function replaces the library version of chdir(). 2842 * 2843 * The path is normalized and then passed to the filesystem which claims 2844 * it. 2845 * 2846 * Results: 2847 * See chdir() documentation. If successful, we keep a record of the 2848 * successful path in cwdPathPtr for subsequent calls to getcwd. 2849 * 2850 * Side effects: 2851 * See chdir() documentation. The global cwdPathPtr may change value. 2852 * 2853 *---------------------------------------------------------------------- 2854 */ 2855 2856int 2857Tcl_FSChdir( 2858 Tcl_Obj *pathPtr) 2859{ 2860 const Tcl_Filesystem *fsPtr; 2861 int retVal = -1; 2862 2863 if (Tcl_FSGetNormalizedPath(NULL, pathPtr) == NULL) { 2864 Tcl_SetErrno(ENOENT); 2865 return retVal; 2866 } 2867 2868 fsPtr = Tcl_FSGetFileSystemForPath(pathPtr); 2869 if (fsPtr != NULL) { 2870 Tcl_FSChdirProc *proc = fsPtr->chdirProc; 2871 if (proc != NULL) { 2872 /* 2873 * If this fails, an appropriate errno will have been stored using 2874 * 'Tcl_SetErrno()'. 2875 */ 2876 2877 retVal = (*proc)(pathPtr); 2878 } else { 2879 /* 2880 * Fallback on stat-based implementation. 2881 */ 2882 2883 Tcl_StatBuf buf; 2884 2885 /* 2886 * If the file can be stat'ed and is a directory and is readable, 2887 * then we can chdir. If any of these actions fail, then 2888 * 'Tcl_SetErrno()' should automatically have been called to set 2889 * an appropriate error code 2890 */ 2891 2892 if ((Tcl_FSStat(pathPtr, &buf) == 0) && (S_ISDIR(buf.st_mode)) 2893 && (Tcl_FSAccess(pathPtr, R_OK) == 0)) { 2894 /* 2895 * We allow the chdir. 2896 */ 2897 2898 retVal = 0; 2899 } 2900 } 2901 } else { 2902 Tcl_SetErrno(ENOENT); 2903 } 2904 2905 /* 2906 * The cwd changed, or an error was thrown. If an error was thrown, we can 2907 * just continue (and that will report the error to the user). If there 2908 * was no error we must assume that the cwd was actually changed to the 2909 * normalized value we calculated above, and we must therefore cache that 2910 * information. 2911 */ 2912 2913 /* 2914 * If the filesystem in question has a getCwdProc, then the correct logic 2915 * which performs the part below is already part of the Tcl_FSGetCwd() 2916 * call, so no need to replicate it again. This will have a side effect 2917 * though. The private authoritative representation of the current working 2918 * directory stored in cwdPathPtr in static memory will be out-of-sync 2919 * with the real OS-maintained value. The first call to Tcl_FSGetCwd will 2920 * however recalculate the private copy to match the OS-value so 2921 * everything will work right. 2922 * 2923 * However, if there is no getCwdProc, then we _must_ update our private 2924 * storage of the cwd, since this is the only opportunity to do that! 2925 * 2926 * Note: We currently call this block of code irrespective of whether 2927 * there was a getCwdProc or not, but the code should all in principle 2928 * work if we only call this block if fsPtr->getCwdProc == NULL. 2929 */ 2930 2931 if (retVal == 0) { 2932 /* 2933 * Note that this normalized path may be different to what we found 2934 * above (or at least a different object), if the filesystem epoch 2935 * changed recently. This can actually happen with scripted documents 2936 * very easily. Therefore we ask for the normalized path again (the 2937 * correct value will have been cached as a result of the 2938 * Tcl_FSGetFileSystemForPath call above anyway). 2939 */ 2940 2941 Tcl_Obj *normDirName = Tcl_FSGetNormalizedPath(NULL, pathPtr); 2942 2943 if (normDirName == NULL) { 2944 /* Not really true, but what else to do? */ 2945 Tcl_SetErrno(ENOENT); 2946 return -1; 2947 } 2948 2949 if (fsPtr == &tclNativeFilesystem) { 2950 /* 2951 * For the native filesystem, we keep a cache of the native 2952 * representation of the cwd. But, we want to do that for the 2953 * exact format that is returned by 'getcwd' (so that we can later 2954 * compare the two representations for equality), which might not 2955 * be exactly the same char-string as the native representation of 2956 * the fully normalized path (e.g. on Windows there's a 2957 * forward-slash vs backslash difference). Hence we ask for this 2958 * again here. On Unix it might actually be true that we always 2959 * have the correct form in the native rep in which case we could 2960 * simply use: 2961 * cd = Tcl_FSGetNativePath(pathPtr); 2962 * instead. This should be examined by someone on Unix. 2963 */ 2964 2965 ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&tclFsDataKey); 2966 ClientData cd; 2967 ClientData oldcd = tsdPtr->cwdClientData; 2968 2969 /* 2970 * Assumption we are using a filesystem version 2. 2971 */ 2972 2973 TclFSGetCwdProc2 *proc2 = (TclFSGetCwdProc2*)fsPtr->getCwdProc; 2974 cd = (*proc2)(oldcd); 2975 if (cd != oldcd) { 2976 FsUpdateCwd(normDirName, cd); 2977 } 2978 } else { 2979 FsUpdateCwd(normDirName, NULL); 2980 } 2981 } 2982 2983 return retVal; 2984} 2985 2986/* 2987 *---------------------------------------------------------------------- 2988 * 2989 * Tcl_FSLoadFile -- 2990 * 2991 * Dynamically loads a binary code file into memory and returns the 2992 * addresses of two functions within that file, if they are defined. The 2993 * appropriate function for the filesystem to which pathPtr belongs will 2994 * be called. 2995 * 2996 * Note that the native filesystem doesn't actually assume 'pathPtr' is a 2997 * path. Rather it assumes pathPtr is either a path or just the name 2998 * (tail) of a file which can be found somewhere in the environment's 2999 * loadable path. This behaviour is not very compatible with virtual 3000 * filesystems (and has other problems documented in the load man-page), 3001 * so it is advised that full paths are always used. 3002 * 3003 * Results: 3004 * A standard Tcl completion code. If an error occurs, an error message 3005 * is left in the interp's result. 3006 * 3007 * Side effects: 3008 * New code suddenly appears in memory. This may later be unloaded by 3009 * passing the clientData to the unloadProc. 3010 * 3011 *---------------------------------------------------------------------- 3012 */ 3013 3014int 3015Tcl_FSLoadFile( 3016 Tcl_Interp *interp, /* Used for error reporting. */ 3017 Tcl_Obj *pathPtr, /* Name of the file containing the desired 3018 * code. */ 3019 const char *sym1, const char *sym2, 3020 /* Names of two functions to look up in the 3021 * file's symbol table. */ 3022 Tcl_PackageInitProc **proc1Ptr, Tcl_PackageInitProc **proc2Ptr, 3023 /* Where to return the addresses corresponding 3024 * to sym1 and sym2. */ 3025 Tcl_LoadHandle *handlePtr, /* Filled with token for dynamically loaded 3026 * file which will be passed back to 3027 * (*unloadProcPtr)() to unload the file. */ 3028 Tcl_FSUnloadFileProc **unloadProcPtr) 3029 /* Filled with address of Tcl_FSUnloadFileProc 3030 * function which should be used for this 3031 * file. */ 3032{ 3033 const char *symbols[2]; 3034 Tcl_PackageInitProc **procPtrs[2]; 3035 ClientData clientData; 3036 int res; 3037 3038 /* 3039 * Initialize the arrays. 3040 */ 3041 3042 symbols[0] = sym1; 3043 symbols[1] = sym2; 3044 procPtrs[0] = proc1Ptr; 3045 procPtrs[1] = proc2Ptr; 3046 3047 /* 3048 * Perform the load. 3049 */ 3050 3051 res = TclLoadFile(interp, pathPtr, 2, symbols, procPtrs, handlePtr, 3052 &clientData, unloadProcPtr); 3053 3054 /* 3055 * Due to an unfortunate mis-design in Tcl 8.4 fs, when loading a shared 3056 * library, we don't keep the loadHandle (for TclpFindSymbol) and the 3057 * clientData (for the unloadProc) separately. In fact we effectively 3058 * throw away the loadHandle and only use the clientData. It just so 3059 * happens, for the native filesystem only, that these two are identical. 3060 * 3061 * This also means that the signatures Tcl_FSUnloadFileProc and 3062 * Tcl_FSLoadFileProc are both misleading. 3063 */ 3064 3065 *handlePtr = (Tcl_LoadHandle) clientData; 3066 return res; 3067} 3068 3069/* 3070 *---------------------------------------------------------------------- 3071 * 3072 * TclLoadFile -- 3073 * 3074 * Dynamically loads a binary code file into memory and returns the 3075 * addresses of a number of given functions within that file, if they are 3076 * defined. The appropriate function for the filesystem to which pathPtr 3077 * belongs will be called. 3078 * 3079 * Note that the native filesystem doesn't actually assume 'pathPtr' is a 3080 * path. Rather it assumes pathPtr is either a path or just the name 3081 * (tail) of a file which can be found somewhere in the environment's 3082 * loadable path. This behaviour is not very compatible with virtual 3083 * filesystems (and has other problems documented in the load man-page), 3084 * so it is advised that full paths are always used. 3085 * 3086 * This function is currently private to Tcl. It may be exported in the 3087 * future and its interface fixed (but we should clean up the 3088 * loadHandle/clientData confusion at that time -- see the above comments 3089 * in Tcl_FSLoadFile for details). For a public function, see 3090 * Tcl_FSLoadFile. 3091 * 3092 * Results: 3093 * A standard Tcl completion code. If an error occurs, an error message 3094 * is left in the interp's result. 3095 * 3096 * Side effects: 3097 * New code suddenly appears in memory. This may later be unloaded by 3098 * passing the clientData to the unloadProc. 3099 * 3100 *---------------------------------------------------------------------- 3101 */ 3102 3103int 3104TclLoadFile( 3105 Tcl_Interp *interp, /* Used for error reporting. */ 3106 Tcl_Obj *pathPtr, /* Name of the file containing the desired 3107 * code. */ 3108 int symc, /* Number of symbols/procPtrs in the next two 3109 * arrays. */ 3110 const char *symbols[], /* Names of functions to look up in the file's 3111 * symbol table. */ 3112 Tcl_PackageInitProc **procPtrs[], 3113 /* Where to return the addresses corresponding 3114 * to symbols[]. */ 3115 Tcl_LoadHandle *handlePtr, /* Filled with token for shared library 3116 * information which can be used in 3117 * TclpFindSymbol. */ 3118 ClientData *clientDataPtr, /* Filled with token for dynamically loaded 3119 * file which will be passed back to 3120 * (*unloadProcPtr)() to unload the file. */ 3121 Tcl_FSUnloadFileProc **unloadProcPtr) 3122 /* Filled with address of Tcl_FSUnloadFileProc 3123 * function which should be used for this 3124 * file. */ 3125{ 3126 const Tcl_Filesystem *fsPtr = Tcl_FSGetFileSystemForPath(pathPtr); 3127 Tcl_FSLoadFileProc *proc; 3128 Tcl_Filesystem *copyFsPtr; 3129 Tcl_Obj *copyToPtr; 3130 Tcl_LoadHandle newLoadHandle = NULL; 3131 ClientData newClientData = NULL; 3132 Tcl_FSUnloadFileProc *newUnloadProcPtr = NULL; 3133 FsDivertLoad *tvdlPtr; 3134 int retVal; 3135 3136 if (fsPtr == NULL) { 3137 Tcl_SetErrno(ENOENT); 3138 return TCL_ERROR; 3139 } 3140 3141 proc = fsPtr->loadFileProc; 3142 if (proc != NULL) { 3143 int retVal = (*proc)(interp, pathPtr, handlePtr, unloadProcPtr); 3144 if (retVal == TCL_OK) { 3145 if (*handlePtr == NULL) { 3146 return TCL_ERROR; 3147 } 3148 3149 /* 3150 * Copy this across, since both are equal for the native fs. 3151 */ 3152 3153 *clientDataPtr = (ClientData)*handlePtr; 3154 Tcl_ResetResult(interp); 3155 goto resolveSymbols; 3156 } 3157 if (Tcl_GetErrno() != EXDEV) { 3158 return retVal; 3159 } 3160 } 3161 3162 /* 3163 * The filesystem doesn't support 'load', so we fall back on the following 3164 * technique: 3165 * 3166 * First check if it is readable -- and exists! 3167 */ 3168 3169 if (Tcl_FSAccess(pathPtr, R_OK) != 0) { 3170 Tcl_AppendResult(interp, "couldn't load library \"", 3171 Tcl_GetString(pathPtr), "\": ", Tcl_PosixError(interp), NULL); 3172 return TCL_ERROR; 3173 } 3174 3175#ifdef TCL_LOAD_FROM_MEMORY 3176 /* 3177 * The platform supports loading code from memory, so ask for a buffer of 3178 * the appropriate size, read the file into it and load the code from the 3179 * buffer: 3180 */ 3181 3182 { 3183 int ret, size; 3184 void *buffer; 3185 Tcl_StatBuf statBuf; 3186 Tcl_Channel data; 3187 3188 ret = Tcl_FSStat(pathPtr, &statBuf); 3189 if (ret < 0) { 3190 goto mustCopyToTempAnyway; 3191 } 3192 size = (int) statBuf.st_size; 3193 3194 /* 3195 * Tcl_Read takes an int: check that file size isn't wide. 3196 */ 3197 3198 if (size != (Tcl_WideInt) statBuf.st_size) { 3199 goto mustCopyToTempAnyway; 3200 } 3201 data = Tcl_FSOpenFileChannel(interp, pathPtr, "rb", 0666); 3202 if (!data) { 3203 goto mustCopyToTempAnyway; 3204 } 3205 buffer = TclpLoadMemoryGetBuffer(interp, size); 3206 if (!buffer) { 3207 Tcl_Close(interp, data); 3208 goto mustCopyToTempAnyway; 3209 } 3210 ret = Tcl_Read(data, buffer, size); 3211 Tcl_Close(interp, data); 3212 ret = TclpLoadMemory(interp, buffer, size, ret, handlePtr, 3213 unloadProcPtr); 3214 if (ret == TCL_OK && *handlePtr != NULL) { 3215 *clientDataPtr = (ClientData) *handlePtr; 3216 goto resolveSymbols; 3217 } 3218 } 3219 3220 mustCopyToTempAnyway: 3221 Tcl_ResetResult(interp); 3222#endif 3223 3224 /* 3225 * Get a temporary filename to use, first to copy the file into, and then 3226 * to load. 3227 */ 3228 3229 copyToPtr = TclpTempFileName(); 3230 if (copyToPtr == NULL) { 3231 Tcl_AppendResult(interp, "couldn't create temporary file: ", 3232 Tcl_PosixError(interp), NULL); 3233 return TCL_ERROR; 3234 } 3235 Tcl_IncrRefCount(copyToPtr); 3236 3237 copyFsPtr = Tcl_FSGetFileSystemForPath(copyToPtr); 3238 if ((copyFsPtr == NULL) || (copyFsPtr == fsPtr)) { 3239 /* 3240 * We already know we can't use Tcl_FSLoadFile from this filesystem, 3241 * and we must avoid a possible infinite loop. Try to delete the file 3242 * we probably created, and then exit. 3243 */ 3244 3245 Tcl_FSDeleteFile(copyToPtr); 3246 Tcl_DecrRefCount(copyToPtr); 3247 Tcl_AppendResult(interp, "couldn't load from current filesystem",NULL); 3248 return TCL_ERROR; 3249 } 3250 3251 if (TclCrossFilesystemCopy(interp, pathPtr, copyToPtr) != TCL_OK) { 3252 /* 3253 * Cross-platform copy failed. 3254 */ 3255 3256 Tcl_FSDeleteFile(copyToPtr); 3257 Tcl_DecrRefCount(copyToPtr); 3258 return TCL_ERROR; 3259 } 3260 3261#if !defined(__WIN32__) 3262 /* 3263 * Do we need to set appropriate permissions on the file? This may be 3264 * required on some systems. On Unix we could loop over the file 3265 * attributes, and set any that are called "-permissions" to 0700. However 3266 * we just do this directly, like this: 3267 */ 3268 3269 { 3270 int index; 3271 Tcl_Obj *perm; 3272 3273 TclNewLiteralStringObj(perm, "0700"); 3274 Tcl_IncrRefCount(perm); 3275 if (TclFSFileAttrIndex(copyToPtr, "-permissions", &index) == TCL_OK) { 3276 Tcl_FSFileAttrsSet(NULL, index, copyToPtr, perm); 3277 } 3278 Tcl_DecrRefCount(perm); 3279 } 3280#endif 3281 3282 /* 3283 * We need to reset the result now, because the cross-filesystem copy may 3284 * have stored the number of bytes in the result. 3285 */ 3286 3287 Tcl_ResetResult(interp); 3288 3289 retVal = TclLoadFile(interp, copyToPtr, symc, symbols, procPtrs, 3290 &newLoadHandle, &newClientData, &newUnloadProcPtr); 3291 if (retVal != TCL_OK) { 3292 /* 3293 * The file didn't load successfully. 3294 */ 3295 3296 Tcl_FSDeleteFile(copyToPtr); 3297 Tcl_DecrRefCount(copyToPtr); 3298 return retVal; 3299 } 3300 3301 /* 3302 * Try to delete the file immediately - this is possible in some OSes, and 3303 * avoids any worries about leaving the copy laying around on exit. 3304 */ 3305 3306 if (Tcl_FSDeleteFile(copyToPtr) == TCL_OK) { 3307 Tcl_DecrRefCount(copyToPtr); 3308 3309 /* 3310 * We tell our caller about the real shared library which was loaded. 3311 * Note that this does mean that the package list maintained by 'load' 3312 * will store the original (vfs) path alongside the temporary load 3313 * handle and unload proc ptr. 3314 */ 3315 3316 (*handlePtr) = newLoadHandle; 3317 (*clientDataPtr) = newClientData; 3318 (*unloadProcPtr) = newUnloadProcPtr; 3319 Tcl_ResetResult(interp); 3320 return TCL_OK; 3321 } 3322 3323 /* 3324 * When we unload this file, we need to divert the unloading so we can 3325 * unload and cleanup the temporary file correctly. 3326 */ 3327 3328 tvdlPtr = (FsDivertLoad *) ckalloc(sizeof(FsDivertLoad)); 3329 3330 /* 3331 * Remember three pieces of information. This allows us to cleanup the 3332 * diverted load completely, on platforms which allow proper unloading of 3333 * code. 3334 */ 3335 3336 tvdlPtr->loadHandle = newLoadHandle; 3337 tvdlPtr->unloadProcPtr = newUnloadProcPtr; 3338 3339 if (copyFsPtr != &tclNativeFilesystem) { 3340 /* 3341 * copyToPtr is already incremented for this reference. 3342 */ 3343 3344 tvdlPtr->divertedFile = copyToPtr; 3345 3346 /* 3347 * This is the filesystem we loaded it into. Since we have a reference 3348 * to 'copyToPtr', we already have a refCount on this filesystem, so 3349 * we don't need to worry about it disappearing on us. 3350 */ 3351 3352 tvdlPtr->divertedFilesystem = copyFsPtr; 3353 tvdlPtr->divertedFileNativeRep = NULL; 3354 } else { 3355 /* 3356 * We need the native rep. 3357 */ 3358 3359 tvdlPtr->divertedFileNativeRep = TclNativeDupInternalRep( 3360 Tcl_FSGetInternalRep(copyToPtr, copyFsPtr)); 3361 3362 /* 3363 * We don't need or want references to the copied Tcl_Obj or the 3364 * filesystem if it is the native one. 3365 */ 3366 3367 tvdlPtr->divertedFile = NULL; 3368 tvdlPtr->divertedFilesystem = NULL; 3369 Tcl_DecrRefCount(copyToPtr); 3370 } 3371 3372 copyToPtr = NULL; 3373 (*handlePtr) = newLoadHandle; 3374 (*clientDataPtr) = (ClientData) tvdlPtr; 3375 (*unloadProcPtr) = TclFSUnloadTempFile; 3376 3377 Tcl_ResetResult(interp); 3378 return retVal; 3379 3380 resolveSymbols: 3381 { 3382 int i; 3383 3384 for (i=0 ; i<symc ; i++) { 3385 if (symbols[i] != NULL) { 3386 *procPtrs[i] = TclpFindSymbol(interp, *handlePtr, symbols[i]); 3387 } 3388 } 3389 } 3390 return TCL_OK; 3391} 3392/* 3393 * This function used to be in the platform specific directories, but it has 3394 * now been made to work cross-platform 3395 */ 3396 3397int 3398TclpLoadFile( 3399 Tcl_Interp *interp, /* Used for error reporting. */ 3400 Tcl_Obj *pathPtr, /* Name of the file containing the desired 3401 * code (UTF-8). */ 3402 const char *sym1, CONST char *sym2, 3403 /* Names of two functions to look up in the 3404 * file's symbol table. */ 3405 Tcl_PackageInitProc **proc1Ptr, Tcl_PackageInitProc **proc2Ptr, 3406 /* Where to return the addresses corresponding 3407 * to sym1 and sym2. */ 3408 ClientData *clientDataPtr, /* Filled with token for dynamically loaded 3409 * file which will be passed back to 3410 * (*unloadProcPtr)() to unload the file. */ 3411 Tcl_FSUnloadFileProc **unloadProcPtr) 3412 /* Filled with address of Tcl_FSUnloadFileProc 3413 * function which should be used for this 3414 * file. */ 3415{ 3416 Tcl_LoadHandle handle = NULL; 3417 int res; 3418 3419 res = TclpDlopen(interp, pathPtr, &handle, unloadProcPtr); 3420 3421 if (res != TCL_OK) { 3422 return res; 3423 } 3424 3425 if (handle == NULL) { 3426 return TCL_ERROR; 3427 } 3428 3429 *clientDataPtr = (ClientData) handle; 3430 3431 *proc1Ptr = TclpFindSymbol(interp, handle, sym1); 3432 *proc2Ptr = TclpFindSymbol(interp, handle, sym2); 3433 return TCL_OK; 3434} 3435 3436/* 3437 *--------------------------------------------------------------------------- 3438 * 3439 * TclFSUnloadTempFile -- 3440 * 3441 * This function is called when we loaded a library of code via an 3442 * intermediate temporary file. This function ensures the library is 3443 * correctly unloaded and the temporary file is correctly deleted. 3444 * 3445 * Results: 3446 * None. 3447 * 3448 * Side effects: 3449 * The effects of the 'unload' function called, and of course the 3450 * temporary file will be deleted. 3451 * 3452 *--------------------------------------------------------------------------- 3453 */ 3454 3455void 3456TclFSUnloadTempFile( 3457 Tcl_LoadHandle loadHandle) /* loadHandle returned by a previous call to 3458 * Tcl_FSLoadFile(). The loadHandle is a token 3459 * that represents the loaded file. */ 3460{ 3461 FsDivertLoad *tvdlPtr = (FsDivertLoad *) loadHandle; 3462 3463 /* 3464 * This test should never trigger, since we give the client data in the 3465 * function above. 3466 */ 3467 3468 if (tvdlPtr == NULL) { 3469 return; 3470 } 3471 3472 /* 3473 * Call the real 'unloadfile' proc we actually used. It is very important 3474 * that we call this first, so that the shared library is actually 3475 * unloaded by the OS. Otherwise, the following 'delete' may well fail 3476 * because the shared library is still in use. 3477 */ 3478 3479 if (tvdlPtr->unloadProcPtr != NULL) { 3480 (*tvdlPtr->unloadProcPtr)(tvdlPtr->loadHandle); 3481 } 3482 3483 if (tvdlPtr->divertedFilesystem == NULL) { 3484 /* 3485 * It was the native filesystem, and we have a special function 3486 * available just for this purpose, which we know works even at this 3487 * late stage. 3488 */ 3489 3490 TclpDeleteFile(tvdlPtr->divertedFileNativeRep); 3491 NativeFreeInternalRep(tvdlPtr->divertedFileNativeRep); 3492 3493 } else { 3494 /* 3495 * Remove the temporary file we created. Note, we may crash here 3496 * because encodings have been taken down already. 3497 */ 3498 3499 if (tvdlPtr->divertedFilesystem->deleteFileProc(tvdlPtr->divertedFile) 3500 != TCL_OK) { 3501 /* 3502 * The above may have failed because the filesystem, or something 3503 * it depends upon (e.g. encodings) have been taken down because 3504 * Tcl is exiting. 3505 * 3506 * We may need to work out how to delete this file more robustly 3507 * (or give the filesystem the information it needs to delete the 3508 * file more robustly). 3509 * 3510 * In particular, one problem might be that the filesystem cannot 3511 * extract the information it needs from the above path object 3512 * because Tcl's entire filesystem apparatus (the code in this 3513 * file) has been finalized, and it refuses to pass the internal 3514 * representation to the filesystem. 3515 */ 3516 } 3517 3518 /* 3519 * And free up the allocations. This will also of course remove a 3520 * refCount from the Tcl_Filesystem to which this file belongs, which 3521 * could then free up the filesystem if we are exiting. 3522 */ 3523 3524 Tcl_DecrRefCount(tvdlPtr->divertedFile); 3525 } 3526 3527 ckfree((char*)tvdlPtr); 3528} 3529 3530/* 3531 *--------------------------------------------------------------------------- 3532 * 3533 * Tcl_FSLink -- 3534 * 3535 * This function replaces the library version of readlink() and can also 3536 * be used to make links. The appropriate function for the filesystem to 3537 * which pathPtr belongs will be called. 3538 * 3539 * Results: 3540 * If toPtr is NULL, then the result is a Tcl_Obj specifying the contents 3541 * of the symbolic link given by 'pathPtr', or NULL if the symbolic link 3542 * could not be read. The result is owned by the caller, which should 3543 * call Tcl_DecrRefCount when the result is no longer needed. 3544 * 3545 * If toPtr is non-NULL, then the result is toPtr if the link action was 3546 * successful, or NULL if not. In this case the result has no additional 3547 * reference count, and need not be freed. The actual action to perform 3548 * is given by the 'linkAction' flags, which is an or'd combination of: 3549 * 3550 * TCL_CREATE_SYMBOLIC_LINK 3551 * TCL_CREATE_HARD_LINK 3552 * 3553 * Note that most filesystems will not support linking across to 3554 * different filesystems, so this function will usually fail unless toPtr 3555 * is in the same FS as pathPtr. 3556 * 3557 * Side effects: 3558 * See readlink() documentation. A new filesystem link object may appear. 3559 * 3560 *--------------------------------------------------------------------------- 3561 */ 3562 3563Tcl_Obj * 3564Tcl_FSLink( 3565 Tcl_Obj *pathPtr, /* Path of file to readlink or link */ 3566 Tcl_Obj *toPtr, /* NULL or path to be linked to */ 3567 int linkAction) /* Action to perform */ 3568{ 3569 const Tcl_Filesystem *fsPtr = Tcl_FSGetFileSystemForPath(pathPtr); 3570 3571 if (fsPtr != NULL) { 3572 Tcl_FSLinkProc *proc = fsPtr->linkProc; 3573 3574 if (proc != NULL) { 3575 return (*proc)(pathPtr, toPtr, linkAction); 3576 } 3577 } 3578 3579 /* 3580 * If S_IFLNK isn't defined it means that the machine doesn't support 3581 * symbolic links, so the file can't possibly be a symbolic link. Generate 3582 * an EINVAL error, which is what happens on machines that do support 3583 * symbolic links when you invoke readlink on a file that isn't a symbolic 3584 * link. 3585 */ 3586 3587#ifndef S_IFLNK 3588 errno = EINVAL; 3589#else 3590 Tcl_SetErrno(ENOENT); 3591#endif /* S_IFLNK */ 3592 return NULL; 3593} 3594 3595/* 3596 *--------------------------------------------------------------------------- 3597 * 3598 * Tcl_FSListVolumes -- 3599 * 3600 * Lists the currently mounted volumes. The chain of functions that have 3601 * been "inserted" into the filesystem will be called in succession; each 3602 * may return a list of volumes, all of which are added to the result 3603 * until all mounted file systems are listed. 3604 * 3605 * Notice that we assume the lists returned by each filesystem (if non 3606 * NULL) have been given a refCount for us already. However, we are NOT 3607 * allowed to hang on to the list itself (it belongs to the filesystem we 3608 * called). Therefore we quite naturally add its contents to the result 3609 * we are building, and then decrement the refCount. 3610 * 3611 * Results: 3612 * The list of volumes, in an object which has refCount 0. 3613 * 3614 * Side effects: 3615 * None 3616 * 3617 *--------------------------------------------------------------------------- 3618 */ 3619 3620Tcl_Obj* 3621Tcl_FSListVolumes(void) 3622{ 3623 FilesystemRecord *fsRecPtr; 3624 Tcl_Obj *resultPtr = Tcl_NewObj(); 3625 3626 /* 3627 * Call each of the "listVolumes" function in succession. A non-NULL 3628 * return value indicates the particular function has succeeded. We call 3629 * all the functions registered, since we want a list of all drives from 3630 * all filesystems. 3631 */ 3632 3633 fsRecPtr = FsGetFirstFilesystem(); 3634 while (fsRecPtr != NULL) { 3635 Tcl_FSListVolumesProc *proc = fsRecPtr->fsPtr->listVolumesProc; 3636 if (proc != NULL) { 3637 Tcl_Obj *thisFsVolumes = (*proc)(); 3638 if (thisFsVolumes != NULL) { 3639 Tcl_ListObjAppendList(NULL, resultPtr, thisFsVolumes); 3640 Tcl_DecrRefCount(thisFsVolumes); 3641 } 3642 } 3643 fsRecPtr = fsRecPtr->nextPtr; 3644 } 3645 3646 return resultPtr; 3647} 3648 3649/* 3650 *--------------------------------------------------------------------------- 3651 * 3652 * FsListMounts -- 3653 * 3654 * List all mounts within the given directory, which match the given 3655 * pattern. 3656 * 3657 * Results: 3658 * The list of mounts, in a list object which has refCount 0, or NULL if 3659 * we didn't even find any filesystems to try to list mounts. 3660 * 3661 * Side effects: 3662 * None 3663 * 3664 *--------------------------------------------------------------------------- 3665 */ 3666 3667static Tcl_Obj * 3668FsListMounts( 3669 Tcl_Obj *pathPtr, /* Contains path to directory to search. */ 3670 const char *pattern) /* Pattern to match against. */ 3671{ 3672 FilesystemRecord *fsRecPtr; 3673 Tcl_GlobTypeData mountsOnly = { TCL_GLOB_TYPE_MOUNT, 0, NULL, NULL }; 3674 Tcl_Obj *resultPtr = NULL; 3675 3676 /* 3677 * Call each of the "matchInDirectory" functions in succession, with the 3678 * specific type information 'mountsOnly'. A non-NULL return value 3679 * indicates the particular function has succeeded. We call all the 3680 * functions registered, since we want a list from each filesystems. 3681 */ 3682 3683 fsRecPtr = FsGetFirstFilesystem(); 3684 while (fsRecPtr != NULL) { 3685 if (fsRecPtr->fsPtr != &tclNativeFilesystem) { 3686 Tcl_FSMatchInDirectoryProc *proc = 3687 fsRecPtr->fsPtr->matchInDirectoryProc; 3688 if (proc != NULL) { 3689 if (resultPtr == NULL) { 3690 resultPtr = Tcl_NewObj(); 3691 } 3692 (*proc)(NULL, resultPtr, pathPtr, pattern, &mountsOnly); 3693 } 3694 } 3695 fsRecPtr = fsRecPtr->nextPtr; 3696 } 3697 3698 return resultPtr; 3699} 3700 3701/* 3702 *--------------------------------------------------------------------------- 3703 * 3704 * Tcl_FSSplitPath -- 3705 * 3706 * This function takes the given Tcl_Obj, which should be a valid path, 3707 * and returns a Tcl List object containing each segment of that path as 3708 * an element. 3709 * 3710 * Results: 3711 * Returns list object with refCount of zero. If the passed in lenPtr is 3712 * non-NULL, we use it to return the number of elements in the returned 3713 * list. 3714 * 3715 * Side effects: 3716 * None. 3717 * 3718 *--------------------------------------------------------------------------- 3719 */ 3720 3721Tcl_Obj * 3722Tcl_FSSplitPath( 3723 Tcl_Obj *pathPtr, /* Path to split. */ 3724 int *lenPtr) /* int to store number of path elements. */ 3725{ 3726 Tcl_Obj *result = NULL; /* Needed only to prevent gcc warnings. */ 3727 Tcl_Filesystem *fsPtr; 3728 char separator = '/'; 3729 int driveNameLength; 3730 char *p; 3731 3732 /* 3733 * Perform platform specific splitting. 3734 */ 3735 3736 if (TclFSGetPathType(pathPtr, &fsPtr, 3737 &driveNameLength) == TCL_PATH_ABSOLUTE) { 3738 if (fsPtr == &tclNativeFilesystem) { 3739 return TclpNativeSplitPath(pathPtr, lenPtr); 3740 } 3741 } else { 3742 return TclpNativeSplitPath(pathPtr, lenPtr); 3743 } 3744 3745 /* 3746 * We assume separators are single characters. 3747 */ 3748 3749 if (fsPtr->filesystemSeparatorProc != NULL) { 3750 Tcl_Obj *sep = (*fsPtr->filesystemSeparatorProc)(pathPtr); 3751 if (sep != NULL) { 3752 Tcl_IncrRefCount(sep); 3753 separator = Tcl_GetString(sep)[0]; 3754 Tcl_DecrRefCount(sep); 3755 } 3756 } 3757 3758 /* 3759 * Place the drive name as first element of the result list. The drive 3760 * name may contain strange characters, like colons and multiple forward 3761 * slashes (for example 'ftp://' is a valid vfs drive name) 3762 */ 3763 3764 result = Tcl_NewObj(); 3765 p = Tcl_GetString(pathPtr); 3766 Tcl_ListObjAppendElement(NULL, result, 3767 Tcl_NewStringObj(p, driveNameLength)); 3768 p += driveNameLength; 3769 3770 /* 3771 * Add the remaining path elements to the list. 3772 */ 3773 3774 for (;;) { 3775 char *elementStart = p; 3776 int length; 3777 while ((*p != '\0') && (*p != separator)) { 3778 p++; 3779 } 3780 length = p - elementStart; 3781 if (length > 0) { 3782 Tcl_Obj *nextElt; 3783 if (elementStart[0] == '~') { 3784 TclNewLiteralStringObj(nextElt, "./"); 3785 Tcl_AppendToObj(nextElt, elementStart, length); 3786 } else { 3787 nextElt = Tcl_NewStringObj(elementStart, length); 3788 } 3789 Tcl_ListObjAppendElement(NULL, result, nextElt); 3790 } 3791 if (*p++ == '\0') { 3792 break; 3793 } 3794 } 3795 3796 /* 3797 * Compute the number of elements in the result. 3798 */ 3799 3800 if (lenPtr != NULL) { 3801 TclListObjLength(NULL, result, lenPtr); 3802 } 3803 return result; 3804} 3805 3806/* Simple helper function */ 3807Tcl_Obj * 3808TclFSInternalToNormalized( 3809 Tcl_Filesystem *fromFilesystem, 3810 ClientData clientData, 3811 FilesystemRecord **fsRecPtrPtr) 3812{ 3813 FilesystemRecord *fsRecPtr = FsGetFirstFilesystem(); 3814 3815 while (fsRecPtr != NULL) { 3816 if (fsRecPtr->fsPtr == fromFilesystem) { 3817 *fsRecPtrPtr = fsRecPtr; 3818 break; 3819 } 3820 fsRecPtr = fsRecPtr->nextPtr; 3821 } 3822 3823 if ((fsRecPtr != NULL) 3824 && (fromFilesystem->internalToNormalizedProc != NULL)) { 3825 return (*fromFilesystem->internalToNormalizedProc)(clientData); 3826 } else { 3827 return NULL; 3828 } 3829} 3830 3831/* 3832 *---------------------------------------------------------------------- 3833 * 3834 * TclGetPathType -- 3835 * 3836 * Helper function used by FSGetPathType. 3837 * 3838 * Results: 3839 * Returns one of TCL_PATH_ABSOLUTE, TCL_PATH_RELATIVE, or 3840 * TCL_PATH_VOLUME_RELATIVE. The filesystem reference will be set if and 3841 * only if it is non-NULL and the function's return value is 3842 * TCL_PATH_ABSOLUTE. 3843 * 3844 * Side effects: 3845 * None. 3846 * 3847 *---------------------------------------------------------------------- 3848 */ 3849 3850Tcl_PathType 3851TclGetPathType( 3852 Tcl_Obj *pathPtr, /* Path to determine type for */ 3853 Tcl_Filesystem **filesystemPtrPtr, 3854 /* If absolute path and this is not NULL, then 3855 * set to the filesystem which claims this 3856 * path. */ 3857 int *driveNameLengthPtr, /* If the path is absolute, and this is 3858 * non-NULL, then set to the length of the 3859 * driveName. */ 3860 Tcl_Obj **driveNameRef) /* If the path is absolute, and this is 3861 * non-NULL, then set to the name of the 3862 * drive, network-volume which contains the 3863 * path, already with a refCount for the 3864 * caller. */ 3865{ 3866 int pathLen; 3867 char *path; 3868 Tcl_PathType type; 3869 3870 path = Tcl_GetStringFromObj(pathPtr, &pathLen); 3871 3872 type = TclFSNonnativePathType(path, pathLen, filesystemPtrPtr, 3873 driveNameLengthPtr, driveNameRef); 3874 3875 if (type != TCL_PATH_ABSOLUTE) { 3876 type = TclpGetNativePathType(pathPtr, driveNameLengthPtr, 3877 driveNameRef); 3878 if ((type == TCL_PATH_ABSOLUTE) && (filesystemPtrPtr != NULL)) { 3879 *filesystemPtrPtr = &tclNativeFilesystem; 3880 } 3881 } 3882 return type; 3883} 3884 3885/* 3886 *---------------------------------------------------------------------- 3887 * 3888 * TclFSNonnativePathType -- 3889 * 3890 * Helper function used by TclGetPathType. Its purpose is to check 3891 * whether the given path starts with a string which corresponds to a 3892 * file volume in any registered filesystem except the native one. For 3893 * speed and historical reasons the native filesystem has special 3894 * hard-coded checks dotted here and there in the filesystem code. 3895 * 3896 * Results: 3897 * Returns one of TCL_PATH_ABSOLUTE or TCL_PATH_RELATIVE. The filesystem 3898 * reference will be set if and only if it is non-NULL and the function's 3899 * return value is TCL_PATH_ABSOLUTE. 3900 * 3901 * Side effects: 3902 * None. 3903 * 3904 *---------------------------------------------------------------------- 3905 */ 3906 3907Tcl_PathType 3908TclFSNonnativePathType( 3909 const char *path, /* Path to determine type for */ 3910 int pathLen, /* Length of the path */ 3911 Tcl_Filesystem **filesystemPtrPtr, 3912 /* If absolute path and this is not NULL, then 3913 * set to the filesystem which claims this 3914 * path. */ 3915 int *driveNameLengthPtr, /* If the path is absolute, and this is 3916 * non-NULL, then set to the length of the 3917 * driveName. */ 3918 Tcl_Obj **driveNameRef) /* If the path is absolute, and this is 3919 * non-NULL, then set to the name of the 3920 * drive, network-volume which contains the 3921 * path, already with a refCount for the 3922 * caller. */ 3923{ 3924 FilesystemRecord *fsRecPtr; 3925 Tcl_PathType type = TCL_PATH_RELATIVE; 3926 3927 /* 3928 * Call each of the "listVolumes" function in succession, checking whether 3929 * the given path is an absolute path on any of the volumes returned (this 3930 * is done by checking whether the path's prefix matches). 3931 */ 3932 3933 fsRecPtr = FsGetFirstFilesystem(); 3934 while (fsRecPtr != NULL) { 3935 Tcl_FSListVolumesProc *proc = fsRecPtr->fsPtr->listVolumesProc; 3936 3937 /* 3938 * We want to skip the native filesystem in this loop because 3939 * otherwise we won't necessarily pass all the Tcl testsuite -- this 3940 * is because some of the tests artificially change the current 3941 * platform (between win, unix) but the list of volumes we get by 3942 * calling (*proc) will reflect the current (real) platform only and 3943 * this may cause some tests to fail. In particular, on unix '/' will 3944 * match the beginning of certain absolute Windows paths starting '//' 3945 * and those tests will go wrong. 3946 * 3947 * Besides these test-suite issues, there is one other reason to skip 3948 * the native filesystem --- since the tclFilename.c code has nice 3949 * fast 'absolute path' checkers, we don't want to waste time 3950 * repeating that effort here, and this function is actually called 3951 * quite often, so if we can save the overhead of the native 3952 * filesystem returning us a list of volumes all the time, it is 3953 * better. 3954 */ 3955 3956 if ((fsRecPtr->fsPtr != &tclNativeFilesystem) && (proc != NULL)) { 3957 int numVolumes; 3958 Tcl_Obj *thisFsVolumes = (*proc)(); 3959 3960 if (thisFsVolumes != NULL) { 3961 if (Tcl_ListObjLength(NULL, thisFsVolumes, &numVolumes) 3962 != TCL_OK) { 3963 /* 3964 * This is VERY bad; the Tcl_FSListVolumesProc didn't 3965 * return a valid list. Set numVolumes to -1 so that we 3966 * skip the while loop below and just return with the 3967 * current value of 'type'. 3968 * 3969 * It would be better if we could signal an error here 3970 * (but Tcl_Panic seems a bit excessive). 3971 */ 3972 3973 numVolumes = -1; 3974 } 3975 while (numVolumes > 0) { 3976 Tcl_Obj *vol; 3977 int len; 3978 char *strVol; 3979 3980 numVolumes--; 3981 Tcl_ListObjIndex(NULL, thisFsVolumes, numVolumes, &vol); 3982 strVol = Tcl_GetStringFromObj(vol,&len); 3983 if (pathLen < len) { 3984 continue; 3985 } 3986 if (strncmp(strVol, path, (size_t) len) == 0) { 3987 type = TCL_PATH_ABSOLUTE; 3988 if (filesystemPtrPtr != NULL) { 3989 *filesystemPtrPtr = fsRecPtr->fsPtr; 3990 } 3991 if (driveNameLengthPtr != NULL) { 3992 *driveNameLengthPtr = len; 3993 } 3994 if (driveNameRef != NULL) { 3995 *driveNameRef = vol; 3996 Tcl_IncrRefCount(vol); 3997 } 3998 break; 3999 } 4000 } 4001 Tcl_DecrRefCount(thisFsVolumes); 4002 if (type == TCL_PATH_ABSOLUTE) { 4003 /* 4004 * We don't need to examine any more filesystems. 4005 */ 4006 break; 4007 } 4008 } 4009 } 4010 fsRecPtr = fsRecPtr->nextPtr; 4011 } 4012 return type; 4013} 4014 4015/* 4016 *--------------------------------------------------------------------------- 4017 * 4018 * Tcl_FSRenameFile -- 4019 * 4020 * If the two paths given belong to the same filesystem, we call that 4021 * filesystems rename function. Otherwise we simply return the POSIX 4022 * error 'EXDEV', and -1. 4023 * 4024 * Results: 4025 * Standard Tcl error code if a function was called. 4026 * 4027 * Side effects: 4028 * A file may be renamed. 4029 * 4030 *--------------------------------------------------------------------------- 4031 */ 4032 4033int 4034Tcl_FSRenameFile( 4035 Tcl_Obj* srcPathPtr, /* Pathname of file or dir to be renamed 4036 * (UTF-8). */ 4037 Tcl_Obj *destPathPtr) /* New pathname of file or directory 4038 * (UTF-8). */ 4039{ 4040 int retVal = -1; 4041 const Tcl_Filesystem *fsPtr, *fsPtr2; 4042 fsPtr = Tcl_FSGetFileSystemForPath(srcPathPtr); 4043 fsPtr2 = Tcl_FSGetFileSystemForPath(destPathPtr); 4044 4045 if ((fsPtr == fsPtr2) && (fsPtr != NULL)) { 4046 Tcl_FSRenameFileProc *proc = fsPtr->renameFileProc; 4047 if (proc != NULL) { 4048 retVal = (*proc)(srcPathPtr, destPathPtr); 4049 } 4050 } 4051 if (retVal == -1) { 4052 Tcl_SetErrno(EXDEV); 4053 } 4054 return retVal; 4055} 4056 4057/* 4058 *--------------------------------------------------------------------------- 4059 * 4060 * Tcl_FSCopyFile -- 4061 * 4062 * If the two paths given belong to the same filesystem, we call that 4063 * filesystem's copy function. Otherwise we simply return the POSIX error 4064 * 'EXDEV', and -1. 4065 * 4066 * Note that in the native filesystems, 'copyFileProc' is defined to copy 4067 * soft links (i.e. it copies the links themselves, not the things they 4068 * point to). 4069 * 4070 * Results: 4071 * Standard Tcl error code if a function was called. 4072 * 4073 * Side effects: 4074 * A file may be copied. 4075 * 4076 *--------------------------------------------------------------------------- 4077 */ 4078 4079int 4080Tcl_FSCopyFile( 4081 Tcl_Obj *srcPathPtr, /* Pathname of file to be copied (UTF-8). */ 4082 Tcl_Obj *destPathPtr) /* Pathname of file to copy to (UTF-8). */ 4083{ 4084 int retVal = -1; 4085 const Tcl_Filesystem *fsPtr, *fsPtr2; 4086 fsPtr = Tcl_FSGetFileSystemForPath(srcPathPtr); 4087 fsPtr2 = Tcl_FSGetFileSystemForPath(destPathPtr); 4088 4089 if (fsPtr == fsPtr2 && fsPtr != NULL) { 4090 Tcl_FSCopyFileProc *proc = fsPtr->copyFileProc; 4091 if (proc != NULL) { 4092 retVal = (*proc)(srcPathPtr, destPathPtr); 4093 } 4094 } 4095 if (retVal == -1) { 4096 Tcl_SetErrno(EXDEV); 4097 } 4098 return retVal; 4099} 4100 4101/* 4102 *--------------------------------------------------------------------------- 4103 * 4104 * TclCrossFilesystemCopy -- 4105 * 4106 * Helper for above function, and for Tcl_FSLoadFile, to copy files from 4107 * one filesystem to another. This function will overwrite the target 4108 * file if it already exists. 4109 * 4110 * Results: 4111 * Standard Tcl error code. 4112 * 4113 * Side effects: 4114 * A file may be created. 4115 * 4116 *--------------------------------------------------------------------------- 4117 */ 4118int 4119TclCrossFilesystemCopy( 4120 Tcl_Interp *interp, /* For error messages */ 4121 Tcl_Obj *source, /* Pathname of file to be copied (UTF-8). */ 4122 Tcl_Obj *target) /* Pathname of file to copy to (UTF-8). */ 4123{ 4124 int result = TCL_ERROR; 4125 int prot = 0666; 4126 Tcl_Channel in, out; 4127 Tcl_StatBuf sourceStatBuf; 4128 struct utimbuf tval; 4129 4130 out = Tcl_FSOpenFileChannel(interp, target, "wb", prot); 4131 if (out == NULL) { 4132 /* 4133 * It looks like we cannot copy it over. Bail out... 4134 */ 4135 goto done; 4136 } 4137 4138 in = Tcl_FSOpenFileChannel(interp, source, "rb", prot); 4139 if (in == NULL) { 4140 /* 4141 * This is very strange, caller should have checked this... 4142 */ 4143 4144 Tcl_Close(interp, out); 4145 goto done; 4146 } 4147 4148 /* 4149 * Copy it synchronously. We might wish to add an asynchronous option to 4150 * support vfs's which are slow (e.g. network sockets). 4151 */ 4152 4153 if (TclCopyChannel(interp, in, out, -1, NULL) == TCL_OK) { 4154 result = TCL_OK; 4155 } 4156 4157 /* 4158 * If the copy failed, assume that copy channel left a good error message. 4159 */ 4160 4161 Tcl_Close(interp, in); 4162 Tcl_Close(interp, out); 4163 4164 /* 4165 * Set modification date of copied file. 4166 */ 4167 4168 if (Tcl_FSLstat(source, &sourceStatBuf) == 0) { 4169 tval.actime = sourceStatBuf.st_atime; 4170 tval.modtime = sourceStatBuf.st_mtime; 4171 Tcl_FSUtime(target, &tval); 4172 } 4173 4174 done: 4175 return result; 4176} 4177 4178/* 4179 *--------------------------------------------------------------------------- 4180 * 4181 * Tcl_FSDeleteFile -- 4182 * 4183 * The appropriate function for the filesystem to which pathPtr belongs 4184 * will be called. 4185 * 4186 * Results: 4187 * Standard Tcl error code. 4188 * 4189 * Side effects: 4190 * A file may be deleted. 4191 * 4192 *--------------------------------------------------------------------------- 4193 */ 4194 4195int 4196Tcl_FSDeleteFile( 4197 Tcl_Obj *pathPtr) /* Pathname of file to be removed (UTF-8). */ 4198{ 4199 const Tcl_Filesystem *fsPtr = Tcl_FSGetFileSystemForPath(pathPtr); 4200 if (fsPtr != NULL) { 4201 Tcl_FSDeleteFileProc *proc = fsPtr->deleteFileProc; 4202 if (proc != NULL) { 4203 return (*proc)(pathPtr); 4204 } 4205 } 4206 Tcl_SetErrno(ENOENT); 4207 return -1; 4208} 4209 4210/* 4211 *--------------------------------------------------------------------------- 4212 * 4213 * Tcl_FSCreateDirectory -- 4214 * 4215 * The appropriate function for the filesystem to which pathPtr belongs 4216 * will be called. 4217 * 4218 * Results: 4219 * Standard Tcl error code. 4220 * 4221 * Side effects: 4222 * A directory may be created. 4223 * 4224 *--------------------------------------------------------------------------- 4225 */ 4226 4227int 4228Tcl_FSCreateDirectory( 4229 Tcl_Obj *pathPtr) /* Pathname of directory to create (UTF-8). */ 4230{ 4231 const Tcl_Filesystem *fsPtr = Tcl_FSGetFileSystemForPath(pathPtr); 4232 if (fsPtr != NULL) { 4233 Tcl_FSCreateDirectoryProc *proc = fsPtr->createDirectoryProc; 4234 if (proc != NULL) { 4235 return (*proc)(pathPtr); 4236 } 4237 } 4238 Tcl_SetErrno(ENOENT); 4239 return -1; 4240} 4241 4242/* 4243 *--------------------------------------------------------------------------- 4244 * 4245 * Tcl_FSCopyDirectory -- 4246 * 4247 * If the two paths given belong to the same filesystem, we call that 4248 * filesystems copy-directory function. Otherwise we simply return the 4249 * POSIX error 'EXDEV', and -1. 4250 * 4251 * Results: 4252 * Standard Tcl error code if a function was called. 4253 * 4254 * Side effects: 4255 * A directory may be copied. 4256 * 4257 *--------------------------------------------------------------------------- 4258 */ 4259 4260int 4261Tcl_FSCopyDirectory( 4262 Tcl_Obj* srcPathPtr, /* Pathname of directory to be copied 4263 * (UTF-8). */ 4264 Tcl_Obj *destPathPtr, /* Pathname of target directory (UTF-8). */ 4265 Tcl_Obj **errorPtr) /* If non-NULL, then will be set to a new 4266 * object containing name of file causing 4267 * error, with refCount 1. */ 4268{ 4269 int retVal = -1; 4270 const Tcl_Filesystem *fsPtr, *fsPtr2; 4271 fsPtr = Tcl_FSGetFileSystemForPath(srcPathPtr); 4272 fsPtr2 = Tcl_FSGetFileSystemForPath(destPathPtr); 4273 4274 if (fsPtr == fsPtr2 && fsPtr != NULL) { 4275 Tcl_FSCopyDirectoryProc *proc = fsPtr->copyDirectoryProc; 4276 if (proc != NULL) { 4277 retVal = (*proc)(srcPathPtr, destPathPtr, errorPtr); 4278 } 4279 } 4280 if (retVal == -1) { 4281 Tcl_SetErrno(EXDEV); 4282 } 4283 return retVal; 4284} 4285 4286/* 4287 *--------------------------------------------------------------------------- 4288 * 4289 * Tcl_FSRemoveDirectory -- 4290 * 4291 * The appropriate function for the filesystem to which pathPtr belongs 4292 * will be called. 4293 * 4294 * Results: 4295 * Standard Tcl error code. 4296 * 4297 * Side effects: 4298 * A directory may be deleted. 4299 * 4300 *--------------------------------------------------------------------------- 4301 */ 4302 4303int 4304Tcl_FSRemoveDirectory( 4305 Tcl_Obj *pathPtr, /* Pathname of directory to be removed 4306 * (UTF-8). */ 4307 int recursive, /* If non-zero, removes directories that are 4308 * nonempty. Otherwise, will only remove empty 4309 * directories. */ 4310 Tcl_Obj **errorPtr) /* If non-NULL, then will be set to a new 4311 * object containing name of file causing 4312 * error, with refCount 1. */ 4313{ 4314 const Tcl_Filesystem *fsPtr = Tcl_FSGetFileSystemForPath(pathPtr); 4315 if (fsPtr != NULL && fsPtr->removeDirectoryProc != NULL) { 4316 Tcl_FSRemoveDirectoryProc *proc = fsPtr->removeDirectoryProc; 4317 if (recursive) { 4318 /* 4319 * We check whether the cwd lies inside this directory and move it 4320 * if it does. 4321 */ 4322 4323 Tcl_Obj *cwdPtr = Tcl_FSGetCwd(NULL); 4324 4325 if (cwdPtr != NULL) { 4326 char *cwdStr, *normPathStr; 4327 int cwdLen, normLen; 4328 Tcl_Obj *normPath = Tcl_FSGetNormalizedPath(NULL, pathPtr); 4329 4330 if (normPath != NULL) { 4331 normPathStr = Tcl_GetStringFromObj(normPath, &normLen); 4332 cwdStr = Tcl_GetStringFromObj(cwdPtr, &cwdLen); 4333 if ((cwdLen >= normLen) && (strncmp(normPathStr, cwdStr, 4334 (size_t) normLen) == 0)) { 4335 /* 4336 * The cwd is inside the directory, so we perform a 4337 * 'cd [file dirname $path]'. 4338 */ 4339 4340 Tcl_Obj *dirPtr = TclPathPart(NULL, pathPtr, 4341 TCL_PATH_DIRNAME); 4342 4343 Tcl_FSChdir(dirPtr); 4344 Tcl_DecrRefCount(dirPtr); 4345 } 4346 } 4347 Tcl_DecrRefCount(cwdPtr); 4348 } 4349 } 4350 return (*proc)(pathPtr, recursive, errorPtr); 4351 } 4352 Tcl_SetErrno(ENOENT); 4353 return -1; 4354} 4355 4356/* 4357 *--------------------------------------------------------------------------- 4358 * 4359 * Tcl_FSGetFileSystemForPath -- 4360 * 4361 * This function determines which filesystem to use for a particular path 4362 * object, and returns the filesystem which accepts this file. If no 4363 * filesystem will accept this object as a valid file path, then NULL is 4364 * returned. 4365 * 4366 * Results: 4367 * NULL or a filesystem which will accept this path. 4368 * 4369 * Side effects: 4370 * The object may be converted to a path type. 4371 * 4372 *--------------------------------------------------------------------------- 4373 */ 4374 4375Tcl_Filesystem * 4376Tcl_FSGetFileSystemForPath( 4377 Tcl_Obj* pathPtr) 4378{ 4379 FilesystemRecord *fsRecPtr; 4380 Tcl_Filesystem* retVal = NULL; 4381 4382 if (pathPtr == NULL) { 4383 Tcl_Panic("Tcl_FSGetFileSystemForPath called with NULL object"); 4384 return NULL; 4385 } 4386 4387 /* 4388 * If the object has a refCount of zero, we reject it. This is to avoid 4389 * possible segfaults or nondeterministic memory leaks (i.e. the user 4390 * doesn't know if they should decrement the ref count on return or not). 4391 */ 4392 4393 if (pathPtr->refCount == 0) { 4394 Tcl_Panic("Tcl_FSGetFileSystemForPath called with object with refCount == 0"); 4395 return NULL; 4396 } 4397 4398 /* 4399 * Check if the filesystem has changed in some way since this object's 4400 * internal representation was calculated. Before doing that, assure we 4401 * have the most up-to-date copy of the master filesystem. This is 4402 * accomplished by the FsGetFirstFilesystem() call. 4403 */ 4404 4405 fsRecPtr = FsGetFirstFilesystem(); 4406 4407 if (TclFSEnsureEpochOk(pathPtr, &retVal) != TCL_OK) { 4408 return NULL; 4409 } 4410 4411 /* 4412 * Call each of the "pathInFilesystem" functions in succession. A 4413 * non-return value of -1 indicates the particular function has succeeded. 4414 */ 4415 4416 while ((retVal == NULL) && (fsRecPtr != NULL)) { 4417 Tcl_FSPathInFilesystemProc *proc = 4418 fsRecPtr->fsPtr->pathInFilesystemProc; 4419 4420 if (proc != NULL) { 4421 ClientData clientData = NULL; 4422 if ((*proc)(pathPtr, &clientData) != -1) { 4423 /* 4424 * We assume the type of pathPtr hasn't been changed by the 4425 * above call to the pathInFilesystemProc. 4426 */ 4427 4428 TclFSSetPathDetails(pathPtr, fsRecPtr, clientData); 4429 retVal = fsRecPtr->fsPtr; 4430 } 4431 } 4432 fsRecPtr = fsRecPtr->nextPtr; 4433 } 4434 4435 return retVal; 4436} 4437 4438/* 4439 *--------------------------------------------------------------------------- 4440 * 4441 * Tcl_FSGetNativePath -- 4442 * 4443 * This function is for use by the Win/Unix native filesystems, so that 4444 * they can easily retrieve the native (char* or TCHAR*) representation 4445 * of a path. Other filesystems will probably want to implement similar 4446 * functions. They basically act as a safety net around 4447 * Tcl_FSGetInternalRep. Normally your file-system functions will always 4448 * be called with path objects already converted to the correct 4449 * filesystem, but if for some reason they are called directly (i.e. by 4450 * functions not in this file), then one cannot necessarily guarantee 4451 * that the path object pointer is from the correct filesystem. 4452 * 4453 * Note: in the future it might be desireable to have separate versions 4454 * of this function with different signatures, for example 4455 * Tcl_FSGetNativeWinPath, Tcl_FSGetNativeUnixPath etc. Right now, since 4456 * native paths are all string based, we use just one function. 4457 * 4458 * Results: 4459 * NULL or a valid native path. 4460 * 4461 * Side effects: 4462 * See Tcl_FSGetInternalRep. 4463 * 4464 *--------------------------------------------------------------------------- 4465 */ 4466 4467const char * 4468Tcl_FSGetNativePath( 4469 Tcl_Obj *pathPtr) 4470{ 4471 return (const char *) Tcl_FSGetInternalRep(pathPtr, &tclNativeFilesystem); 4472} 4473 4474/* 4475 *--------------------------------------------------------------------------- 4476 * 4477 * NativeFreeInternalRep -- 4478 * 4479 * Free a native internal representation, which will be non-NULL. 4480 * 4481 * Results: 4482 * None. 4483 * 4484 * Side effects: 4485 * Memory is released. 4486 * 4487 *--------------------------------------------------------------------------- 4488 */ 4489 4490static void 4491NativeFreeInternalRep( 4492 ClientData clientData) 4493{ 4494 ckfree((char *) clientData); 4495} 4496 4497/* 4498 *--------------------------------------------------------------------------- 4499 * 4500 * Tcl_FSFileSystemInfo -- 4501 * 4502 * This function returns a list of two elements. The first element is the 4503 * name of the filesystem (e.g. "native" or "vfs"), and the second is the 4504 * particular type of the given path within that filesystem. 4505 * 4506 * Results: 4507 * A list of two elements. 4508 * 4509 * Side effects: 4510 * The object may be converted to a path type. 4511 * 4512 *--------------------------------------------------------------------------- 4513 */ 4514 4515Tcl_Obj * 4516Tcl_FSFileSystemInfo( 4517 Tcl_Obj *pathPtr) 4518{ 4519 Tcl_Obj *resPtr; 4520 Tcl_FSFilesystemPathTypeProc *proc; 4521 const Tcl_Filesystem *fsPtr = Tcl_FSGetFileSystemForPath(pathPtr); 4522 4523 if (fsPtr == NULL) { 4524 return NULL; 4525 } 4526 4527 resPtr = Tcl_NewListObj(0, NULL); 4528 Tcl_ListObjAppendElement(NULL,resPtr,Tcl_NewStringObj(fsPtr->typeName,-1)); 4529 4530 proc = fsPtr->filesystemPathTypeProc; 4531 if (proc != NULL) { 4532 Tcl_Obj *typePtr = (*proc)(pathPtr); 4533 if (typePtr != NULL) { 4534 Tcl_ListObjAppendElement(NULL, resPtr, typePtr); 4535 } 4536 } 4537 4538 return resPtr; 4539} 4540 4541/* 4542 *--------------------------------------------------------------------------- 4543 * 4544 * Tcl_FSPathSeparator -- 4545 * 4546 * This function returns the separator to be used for a given path. The 4547 * object returned should have a refCount of zero 4548 * 4549 * Results: 4550 * A Tcl object, with a refCount of zero. If the caller needs to retain a 4551 * reference to the object, it should call Tcl_IncrRefCount, and should 4552 * otherwise free the object. 4553 * 4554 * Side effects: 4555 * The path object may be converted to a path type. 4556 * 4557 *--------------------------------------------------------------------------- 4558 */ 4559 4560Tcl_Obj * 4561Tcl_FSPathSeparator( 4562 Tcl_Obj *pathPtr) 4563{ 4564 const Tcl_Filesystem *fsPtr = Tcl_FSGetFileSystemForPath(pathPtr); 4565 4566 if (fsPtr == NULL) { 4567 return NULL; 4568 } 4569 if (fsPtr->filesystemSeparatorProc != NULL) { 4570 return (*fsPtr->filesystemSeparatorProc)(pathPtr); 4571 } else { 4572 Tcl_Obj *resultObj; 4573 4574 /* 4575 * Allow filesystems not to provide a filesystemSeparatorProc if they 4576 * wish to use the standard forward slash. 4577 */ 4578 4579 TclNewLiteralStringObj(resultObj, "/"); 4580 return resultObj; 4581 } 4582} 4583 4584/* 4585 *--------------------------------------------------------------------------- 4586 * 4587 * NativeFilesystemSeparator -- 4588 * 4589 * This function is part of the native filesystem support, and returns 4590 * the separator for the given path. 4591 * 4592 * Results: 4593 * String object containing the separator character. 4594 * 4595 * Side effects: 4596 * None. 4597 * 4598 *--------------------------------------------------------------------------- 4599 */ 4600 4601static Tcl_Obj * 4602NativeFilesystemSeparator( 4603 Tcl_Obj *pathPtr) 4604{ 4605 const char *separator = NULL; /* lint */ 4606 switch (tclPlatform) { 4607 case TCL_PLATFORM_UNIX: 4608 separator = "/"; 4609 break; 4610 case TCL_PLATFORM_WINDOWS: 4611 separator = "\\"; 4612 break; 4613 } 4614 return Tcl_NewStringObj(separator,1); 4615} 4616 4617/* Everything from here on is contained in this obsolete ifdef */ 4618#ifdef USE_OBSOLETE_FS_HOOKS 4619 4620/* 4621 *---------------------------------------------------------------------- 4622 * 4623 * TclStatInsertProc -- 4624 * 4625 * Insert the passed function pointer at the head of the list of 4626 * functions which are used during a call to 'TclStat(...)'. The passed 4627 * function should behave exactly like 'TclStat' when called during that 4628 * time (see 'TclStat(...)' for more information). The function will be 4629 * added even if it already in the list. 4630 * 4631 * Results: 4632 * Normally TCL_OK; TCL_ERROR if memory for a new node in the list could 4633 * not be allocated. 4634 * 4635 * Side effects: 4636 * Memory allocated and modifies the link list for 'TclStat' functions. 4637 * 4638 *---------------------------------------------------------------------- 4639 */ 4640 4641int 4642TclStatInsertProc( 4643 TclStatProc_ *proc) 4644{ 4645 int retVal = TCL_ERROR; 4646 4647 if (proc != NULL) { 4648 StatProc *newStatProcPtr; 4649 4650 newStatProcPtr = (StatProc *)ckalloc(sizeof(StatProc)); 4651 4652 if (newStatProcPtr != NULL) { 4653 newStatProcPtr->proc = proc; 4654 Tcl_MutexLock(&obsoleteFsHookMutex); 4655 newStatProcPtr->nextPtr = statProcList; 4656 statProcList = newStatProcPtr; 4657 Tcl_MutexUnlock(&obsoleteFsHookMutex); 4658 4659 retVal = TCL_OK; 4660 } 4661 } 4662 4663 return retVal; 4664} 4665 4666/* 4667 *---------------------------------------------------------------------- 4668 * 4669 * TclStatDeleteProc -- 4670 * 4671 * Removed the passed function pointer from the list of 'TclStat' 4672 * functions. Ensures that the built-in stat function is not removable. 4673 * 4674 * Results: 4675 * TCL_OK if the function pointer was successfully removed, TCL_ERROR 4676 * otherwise. 4677 * 4678 * Side effects: 4679 * Memory is deallocated and the respective list updated. 4680 * 4681 *---------------------------------------------------------------------- 4682 */ 4683 4684int 4685TclStatDeleteProc( 4686 TclStatProc_ *proc) 4687{ 4688 int retVal = TCL_ERROR; 4689 StatProc *tmpStatProcPtr; 4690 StatProc *prevStatProcPtr = NULL; 4691 4692 Tcl_MutexLock(&obsoleteFsHookMutex); 4693 tmpStatProcPtr = statProcList; 4694 4695 /* 4696 * Traverse the 'statProcList' looking for the particular node whose 4697 * 'proc' member matches 'proc' and remove that one from the list. Ensure 4698 * that the "default" node cannot be removed. 4699 */ 4700 4701 while ((retVal == TCL_ERROR) && (tmpStatProcPtr != NULL)) { 4702 if (tmpStatProcPtr->proc == proc) { 4703 if (prevStatProcPtr == NULL) { 4704 statProcList = tmpStatProcPtr->nextPtr; 4705 } else { 4706 prevStatProcPtr->nextPtr = tmpStatProcPtr->nextPtr; 4707 } 4708 4709 ckfree((char *)tmpStatProcPtr); 4710 4711 retVal = TCL_OK; 4712 } else { 4713 prevStatProcPtr = tmpStatProcPtr; 4714 tmpStatProcPtr = tmpStatProcPtr->nextPtr; 4715 } 4716 } 4717 4718 Tcl_MutexUnlock(&obsoleteFsHookMutex); 4719 4720 return retVal; 4721} 4722 4723/* 4724 *---------------------------------------------------------------------- 4725 * 4726 * TclAccessInsertProc -- 4727 * 4728 * Insert the passed function pointer at the head of the list of 4729 * functions which are used during a call to 'TclAccess(...)'. The passed 4730 * function should behave exactly like 'TclAccess' when called during 4731 * that time (see 'TclAccess(...)' for more information). The function 4732 * will be added even if it already in the list. 4733 * 4734 * Results: 4735 * Normally TCL_OK; TCL_ERROR if memory for a new node in the list could 4736 * not be allocated. 4737 * 4738 * Side effects: 4739 * Memory allocated and modifies the link list for 'TclAccess' functions. 4740 * 4741 *---------------------------------------------------------------------- 4742 */ 4743 4744int 4745TclAccessInsertProc( 4746 TclAccessProc_ *proc) 4747{ 4748 int retVal = TCL_ERROR; 4749 4750 if (proc != NULL) { 4751 AccessProc *newAccessProcPtr; 4752 4753 newAccessProcPtr = (AccessProc *)ckalloc(sizeof(AccessProc)); 4754 4755 if (newAccessProcPtr != NULL) { 4756 newAccessProcPtr->proc = proc; 4757 Tcl_MutexLock(&obsoleteFsHookMutex); 4758 newAccessProcPtr->nextPtr = accessProcList; 4759 accessProcList = newAccessProcPtr; 4760 Tcl_MutexUnlock(&obsoleteFsHookMutex); 4761 4762 retVal = TCL_OK; 4763 } 4764 } 4765 4766 return retVal; 4767} 4768 4769/* 4770 *---------------------------------------------------------------------- 4771 * 4772 * TclAccessDeleteProc -- 4773 * 4774 * Removed the passed function pointer from the list of 'TclAccess' 4775 * functions. Ensures that the built-in access function is not removable. 4776 * 4777 * Results: 4778 * TCL_OK if the function pointer was successfully removed, TCL_ERROR 4779 * otherwise. 4780 * 4781 * Side effects: 4782 * Memory is deallocated and the respective list updated. 4783 * 4784 *---------------------------------------------------------------------- 4785 */ 4786 4787int 4788TclAccessDeleteProc( 4789 TclAccessProc_ *proc) 4790{ 4791 int retVal = TCL_ERROR; 4792 AccessProc *tmpAccessProcPtr; 4793 AccessProc *prevAccessProcPtr = NULL; 4794 4795 /* 4796 * Traverse the 'accessProcList' looking for the particular node whose 4797 * 'proc' member matches 'proc' and remove that one from the list. Ensure 4798 * that the "default" node cannot be removed. 4799 */ 4800 4801 Tcl_MutexLock(&obsoleteFsHookMutex); 4802 tmpAccessProcPtr = accessProcList; 4803 while ((retVal == TCL_ERROR) && (tmpAccessProcPtr != NULL)) { 4804 if (tmpAccessProcPtr->proc == proc) { 4805 if (prevAccessProcPtr == NULL) { 4806 accessProcList = tmpAccessProcPtr->nextPtr; 4807 } else { 4808 prevAccessProcPtr->nextPtr = tmpAccessProcPtr->nextPtr; 4809 } 4810 4811 ckfree((char *)tmpAccessProcPtr); 4812 4813 retVal = TCL_OK; 4814 } else { 4815 prevAccessProcPtr = tmpAccessProcPtr; 4816 tmpAccessProcPtr = tmpAccessProcPtr->nextPtr; 4817 } 4818 } 4819 Tcl_MutexUnlock(&obsoleteFsHookMutex); 4820 4821 return retVal; 4822} 4823 4824/* 4825 *---------------------------------------------------------------------- 4826 * 4827 * TclOpenFileChannelInsertProc -- 4828 * 4829 * Insert the passed function pointer at the head of the list of 4830 * functions which are used during a call to 'Tcl_OpenFileChannel(...)'. 4831 * The passed function should behave exactly like 'Tcl_OpenFileChannel' 4832 * when called during that time (see 'Tcl_OpenFileChannel(...)' for more 4833 * information). The function will be added even if it already in the 4834 * list. 4835 * 4836 * Results: 4837 * Normally TCL_OK; TCL_ERROR if memory for a new node in the list could 4838 * not be allocated. 4839 * 4840 * Side effects: 4841 * Memory allocated and modifies the link list for 'Tcl_OpenFileChannel' 4842 * functions. 4843 * 4844 *---------------------------------------------------------------------- 4845 */ 4846 4847int 4848TclOpenFileChannelInsertProc( 4849 TclOpenFileChannelProc_ *proc) 4850{ 4851 int retVal = TCL_ERROR; 4852 4853 if (proc != NULL) { 4854 OpenFileChannelProc *newOpenFileChannelProcPtr; 4855 4856 newOpenFileChannelProcPtr = (OpenFileChannelProc *) 4857 ckalloc(sizeof(OpenFileChannelProc)); 4858 4859 newOpenFileChannelProcPtr->proc = proc; 4860 Tcl_MutexLock(&obsoleteFsHookMutex); 4861 newOpenFileChannelProcPtr->nextPtr = openFileChannelProcList; 4862 openFileChannelProcList = newOpenFileChannelProcPtr; 4863 Tcl_MutexUnlock(&obsoleteFsHookMutex); 4864 4865 retVal = TCL_OK; 4866 } 4867 4868 return retVal; 4869} 4870 4871/* 4872 *---------------------------------------------------------------------- 4873 * 4874 * TclOpenFileChannelDeleteProc -- 4875 * 4876 * Removed the passed function pointer from the list of 4877 * 'Tcl_OpenFileChannel' functions. Ensures that the built-in open file 4878 * channel function is not removable. 4879 * 4880 * Results: 4881 * TCL_OK if the function pointer was successfully removed, TCL_ERROR 4882 * otherwise. 4883 * 4884 * Side effects: 4885 * Memory is deallocated and the respective list updated. 4886 * 4887 *---------------------------------------------------------------------- 4888 */ 4889 4890int 4891TclOpenFileChannelDeleteProc( 4892 TclOpenFileChannelProc_ *proc) 4893{ 4894 int retVal = TCL_ERROR; 4895 OpenFileChannelProc *tmpOpenFileChannelProcPtr = openFileChannelProcList; 4896 OpenFileChannelProc *prevOpenFileChannelProcPtr = NULL; 4897 4898 /* 4899 * Traverse the 'openFileChannelProcList' looking for the particular node 4900 * whose 'proc' member matches 'proc' and remove that one from the list. 4901 */ 4902 4903 Tcl_MutexLock(&obsoleteFsHookMutex); 4904 tmpOpenFileChannelProcPtr = openFileChannelProcList; 4905 while ((retVal == TCL_ERROR) && 4906 (tmpOpenFileChannelProcPtr != NULL)) { 4907 if (tmpOpenFileChannelProcPtr->proc == proc) { 4908 if (prevOpenFileChannelProcPtr == NULL) { 4909 openFileChannelProcList = tmpOpenFileChannelProcPtr->nextPtr; 4910 } else { 4911 prevOpenFileChannelProcPtr->nextPtr = 4912 tmpOpenFileChannelProcPtr->nextPtr; 4913 } 4914 4915 ckfree((char *) tmpOpenFileChannelProcPtr); 4916 4917 retVal = TCL_OK; 4918 } else { 4919 prevOpenFileChannelProcPtr = tmpOpenFileChannelProcPtr; 4920 tmpOpenFileChannelProcPtr = tmpOpenFileChannelProcPtr->nextPtr; 4921 } 4922 } 4923 Tcl_MutexUnlock(&obsoleteFsHookMutex); 4924 4925 return retVal; 4926} 4927#endif /* USE_OBSOLETE_FS_HOOKS */ 4928 4929/* 4930 * Local Variables: 4931 * mode: c 4932 * c-basic-offset: 4 4933 * fill-column: 78 4934 * End: 4935 */ 4936