1/* 2 * vfs.c -- 3 * 4 * This file contains the implementation of the Vfs extension 5 * to Tcl. It provides a script level interface to Tcl's 6 * virtual file system support, and therefore allows 7 * vfs's to be implemented in Tcl. 8 * 9 * Some of this file could be used as a basis for a hard-coded 10 * vfs implemented in C (e.g. a zipvfs). 11 * 12 * The code is thread-safe. Although under normal use only 13 * one interpreter will be used to add/remove mounts and volumes, 14 * it does cope with multiple interpreters in multiple threads. 15 * 16 * Copyright (c) 2001-2004 Vince Darley. 17 * Copyright (c) 2006 ActiveState Software Inc. 18 * 19 * See the file "license.terms" for information on usage and redistribution 20 * of this file, and for a DISCLAIMER OF ALL WARRANTIES. 21 */ 22 23#include <tcl.h> 24/* Required to access the 'stat' structure fields, and TclInExit() */ 25#include "tclInt.h" 26#include "tclPort.h" 27 28/* 29 * Windows needs to know which symbols to export. Unix does not. 30 * BUILD_vfs should be undefined for Unix. 31 */ 32 33#ifdef BUILD_vfs 34#undef TCL_STORAGE_CLASS 35#define TCL_STORAGE_CLASS DLLEXPORT 36#endif /* BUILD_vfs */ 37 38#ifndef TCL_GLOB_TYPE_MOUNT 39#define TCL_GLOB_TYPE_MOUNT (1<<7) 40#endif 41 42/* 43 * tclvfs will return this code instead of TCL_OK/ERROR/etc. to propagate 44 * through the Tcl_Eval* calls to indicate a posix error has been raised by 45 * some vfs implementation. -1 is what Tcl expects, adopts from posix's 46 * standard error value. 47 */ 48#define TCLVFS_POSIXERROR (-1) 49 50#ifndef CONST86 51#define CONST86 52#endif 53 54/* 55 * Only the _Init function is exported. 56 */ 57 58EXTERN int Vfs_Init _ANSI_ARGS_((Tcl_Interp*)); 59 60/* 61 * Functions to add and remove a volume from the list of volumes. 62 * These aren't currently exported, but could be in the future. 63 */ 64static void Vfs_AddVolume _ANSI_ARGS_((Tcl_Obj*)); 65static int Vfs_RemoveVolume _ANSI_ARGS_((Tcl_Obj*)); 66 67/* 68 * struct Vfs_InterpCmd -- 69 * 70 * Any vfs action which is exposed to Tcl requires both an interpreter 71 * and a command prefix for evaluation. To carry out any filesystem 72 * action inside a vfs, this extension will lappend various additional 73 * parameters to the command string, evaluate it in the interpreter and 74 * then extract the result (the way the result is handled is documented 75 * in each individual vfs callback below). 76 * 77 * We retain a refCount on the 'mountCmd' object, but there is no need 78 * for us to register our interpreter reference, since we will be 79 * made invalid when the interpreter disappears. Also, Tcl_Objs of 80 * "path" type which use one of these structures as part of their 81 * internal representation also do not need to add to any refCounts, 82 * because if this object disappears, all internal representations will 83 * be made invalid. 84 */ 85 86typedef struct Vfs_InterpCmd { 87 Tcl_Obj *mountCmd; /* The Tcl command prefix which will be used 88 * to perform all filesystem actions on this 89 * file. */ 90 Tcl_Interp *interp; /* The Tcl interpreter in which the above 91 * command will be evaluated. */ 92} Vfs_InterpCmd; 93 94/* 95 * struct VfsNativeRep -- 96 * 97 * Structure used for the native representation of a path in a Tcl vfs. 98 * To fully specify a file, the string representation is also required. 99 * 100 * When a Tcl interpreter is deleted, all mounts whose callbacks 101 * are in it are removed and freed. This also means that the 102 * global filesystem epoch that Tcl retains is modified, and all 103 * path internal representations are therefore discarded. Therefore we 104 * don't have to worry about vfs files containing stale VfsNativeRep 105 * structures (but it also means we mustn't touch the fsCmd field 106 * of one of these structures if the interpreter has gone). This 107 * means when we free one of these structures, we just free the 108 * memory allocated, and ignore the fsCmd pointer (which may or may 109 * not point to valid memory). 110 */ 111 112typedef struct VfsNativeRep { 113 int splitPosition; /* The index into the string representation 114 * of the file which indicates where the 115 * vfs filesystem is mounted. */ 116 Vfs_InterpCmd* fsCmd; /* The Tcl interpreter and command pair 117 * which will be used to perform all filesystem 118 * actions on this file. */ 119} VfsNativeRep; 120 121/* 122 * struct VfsChannelCleanupInfo -- 123 * 124 * Structure we use to retain sufficient information about 125 * a channel that we can properly clean up all resources 126 * when the channel is closed. This is required when using 127 * 'open' on things inside the vfs. 128 * 129 * When the channel in question is begin closed, we will 130 * temporarily register the channel with the given interpreter, 131 * evaluate the closeCallBack, and then detach the channel 132 * from the interpreter and return (allowing Tcl to continue 133 * closing the channel as normal). 134 * 135 * Nothing in the callback can prevent the channel from 136 * being closed. 137 */ 138 139typedef struct VfsChannelCleanupInfo { 140 Tcl_Channel channel; /* The channel which needs cleaning up */ 141 Tcl_Obj* closeCallback; /* The Tcl command string to evaluate 142 * when the channel is closing, which will 143 * carry out any cleanup that is necessary. */ 144 Tcl_Interp* interp; /* The interpreter in which to evaluate the 145 * cleanup operation. */ 146} VfsChannelCleanupInfo; 147 148 149/* 150 * Forward declarations for procedures defined later in this file: 151 */ 152 153static int VfsFilesystemObjCmd _ANSI_ARGS_((ClientData dummy, 154 Tcl_Interp *interp, int objc, 155 Tcl_Obj *CONST objv[])); 156 157/* 158 * Now we define the virtual filesystem callbacks. Note that some 159 * of these callbacks are passed a Tcl_Interp for error messages. 160 * We will copy over the error messages from the vfs interp to the 161 * calling interp. Currently this is done directly, but we 162 * could investigate using 'TclTransferResult' which would allow 163 * error traces to be copied over as well. 164 */ 165 166static Tcl_FSStatProc VfsStat; 167static Tcl_FSAccessProc VfsAccess; 168static Tcl_FSOpenFileChannelProc VfsOpenFileChannel; 169static Tcl_FSMatchInDirectoryProc VfsMatchInDirectory; 170static Tcl_FSDeleteFileProc VfsDeleteFile; 171static Tcl_FSCreateDirectoryProc VfsCreateDirectory; 172static Tcl_FSRemoveDirectoryProc VfsRemoveDirectory; 173static Tcl_FSFileAttrStringsProc VfsFileAttrStrings; 174static Tcl_FSFileAttrsGetProc VfsFileAttrsGet; 175static Tcl_FSFileAttrsSetProc VfsFileAttrsSet; 176static Tcl_FSUtimeProc VfsUtime; 177static Tcl_FSPathInFilesystemProc VfsPathInFilesystem; 178static Tcl_FSFilesystemPathTypeProc VfsFilesystemPathType; 179static Tcl_FSFilesystemSeparatorProc VfsFilesystemSeparator; 180static Tcl_FSFreeInternalRepProc VfsFreeInternalRep; 181static Tcl_FSDupInternalRepProc VfsDupInternalRep; 182static Tcl_FSListVolumesProc VfsListVolumes; 183 184static Tcl_Filesystem vfsFilesystem = { 185 "tclvfs", 186 sizeof(Tcl_Filesystem), 187 TCL_FILESYSTEM_VERSION_1, 188 &VfsPathInFilesystem, 189 &VfsDupInternalRep, 190 &VfsFreeInternalRep, 191 /* No internal to normalized, since we don't create any 192 * pure 'internal' Tcl_Obj path representations */ 193 NULL, 194 /* No create native rep function, since we don't use it 195 * or 'Tcl_FSNewNativePath' */ 196 NULL, 197 /* Normalize path isn't needed - we assume paths only have 198 * one representation */ 199 NULL, 200 &VfsFilesystemPathType, 201 &VfsFilesystemSeparator, 202 &VfsStat, 203 &VfsAccess, 204 &VfsOpenFileChannel, 205 &VfsMatchInDirectory, 206 &VfsUtime, 207 /* We choose not to support symbolic links inside our vfs's */ 208 NULL, 209 &VfsListVolumes, 210 &VfsFileAttrStrings, 211 &VfsFileAttrsGet, 212 &VfsFileAttrsSet, 213 &VfsCreateDirectory, 214 &VfsRemoveDirectory, 215 &VfsDeleteFile, 216 /* No copy file - fallback will occur at Tcl level */ 217 NULL, 218 /* No rename file - fallback will occur at Tcl level */ 219 NULL, 220 /* No copy directory - fallback will occur at Tcl level */ 221 NULL, 222 /* Use stat for lstat */ 223 NULL, 224 /* No load - fallback on core implementation */ 225 NULL, 226 /* We don't need a getcwd or chdir - fallback on Tcl's versions */ 227 NULL, 228 NULL 229}; 230 231/* 232 * struct VfsMount -- 233 * 234 * Each filesystem mount point which is registered will result in 235 * the allocation of one of these structures. They are stored 236 * in a linked list whose head is 'listOfMounts'. 237 */ 238 239typedef struct VfsMount { 240 CONST char* mountPoint; 241 int mountLen; 242 int isVolume; 243 Vfs_InterpCmd interpCmd; 244 struct VfsMount* nextMount; 245} VfsMount; 246 247#define TCL_TSD_INIT(keyPtr) (ThreadSpecificData *)Tcl_GetThreadData((keyPtr), sizeof(ThreadSpecificData)) 248 249/* 250 * Declare a thread-specific list of vfs mounts and volumes. 251 * 252 * Stores the list of volumes registered with the vfs (and therefore 253 * also registered with Tcl). It is maintained as a valid Tcl list at 254 * all times, or NULL if there are none (we don't keep it as an empty 255 * list just as a slight optimisation to improve Tcl's efficiency in 256 * determining whether paths are absolute or relative). 257 * 258 * We keep a refCount on this object whenever it is non-NULL. 259 * 260 * internalErrorScript is evaluated when an internal error is detected in 261 * a tclvfs implementation. This is most useful for debugging. 262 * 263 * When it is not NULL we keep a refCount on it. 264 */ 265 266typedef struct ThreadSpecificData { 267 VfsMount *listOfMounts; 268 Tcl_Obj *vfsVolumes; 269 Tcl_Obj *internalErrorScript; 270} ThreadSpecificData; 271static Tcl_ThreadDataKey dataKey; 272 273/* We might wish to consider exporting these in the future */ 274 275static int Vfs_AddMount(Tcl_Obj* mountPoint, int isVolume, 276 Tcl_Interp *interp, Tcl_Obj* mountCmd); 277static int Vfs_RemoveMount(Tcl_Obj* mountPoint, Tcl_Interp* interp); 278static Vfs_InterpCmd* Vfs_FindMount(Tcl_Obj *pathMount, int mountLen); 279static Tcl_Obj* Vfs_ListMounts(void); 280static void Vfs_UnregisterWithInterp _ANSI_ARGS_((ClientData, 281 Tcl_Interp*)); 282static void Vfs_RegisterWithInterp _ANSI_ARGS_((Tcl_Interp*)); 283 284/* Some private helper procedures */ 285 286static VfsNativeRep* VfsGetNativePath(Tcl_Obj* pathPtr); 287static Tcl_CloseProc VfsCloseProc; 288static void VfsExitProc(ClientData clientData); 289static void VfsThreadExitProc(ClientData clientData); 290static Tcl_Obj* VfsFullyNormalizePath(Tcl_Interp *interp, 291 Tcl_Obj *pathPtr); 292static Tcl_Obj* VfsBuildCommandForPath(Tcl_Interp **iRef, 293 CONST char* cmd, Tcl_Obj * pathPtr); 294static void VfsInternalError(Tcl_Interp* interp); 295 296/* 297 * Hard-code platform dependencies. We do not need to worry 298 * about backslash-separators on windows, because a normalized 299 * path will never contain them. 300 */ 301#ifdef MAC_TCL 302 #define VFS_SEPARATOR ':' 303#else 304 #define VFS_SEPARATOR '/' 305#endif 306 307 308/* 309 *---------------------------------------------------------------------- 310 * 311 * Vfs_Init -- 312 * 313 * This procedure is the main initialisation point of the Vfs 314 * extension. 315 * 316 * Results: 317 * Returns a standard Tcl completion code, and leaves an error 318 * message in the interp's result if an error occurs. 319 * 320 * Side effects: 321 * Adds a command to the Tcl interpreter. 322 * 323 *---------------------------------------------------------------------- 324 */ 325 326int 327Vfs_Init(interp) 328 Tcl_Interp *interp; /* Interpreter for application. */ 329{ 330 if (Tcl_InitStubs(interp, "8.4", 0) == NULL) { 331 return TCL_ERROR; 332 } 333 if (Tcl_PkgRequire(interp, "Tcl", "8.4", 0) == NULL) { 334 return TCL_ERROR; 335 } 336 337 /* 338 * Safe interpreters are not allowed to modify the filesystem! 339 * (Since those modifications will affect other interpreters). 340 */ 341 if (Tcl_IsSafe(interp)) { 342 return TCL_ERROR; 343 } 344 345#ifndef PACKAGE_VERSION 346 /* keep in sync with actual version */ 347#define PACKAGE_VERSION "1.4" 348#endif 349 if (Tcl_PkgProvide(interp, "vfs", PACKAGE_VERSION) == TCL_ERROR) { 350 return TCL_ERROR; 351 } 352 353 /* 354 * Create 'vfs::filesystem' command, and interpreter-specific 355 * initialisation. 356 */ 357 358 Tcl_CreateObjCommand(interp, "vfs::filesystem", VfsFilesystemObjCmd, 359 (ClientData) NULL, (Tcl_CmdDeleteProc *) NULL); 360 Vfs_RegisterWithInterp(interp); 361 return TCL_OK; 362} 363 364 365/* 366 *---------------------------------------------------------------------- 367 * 368 * Vfs_RegisterWithInterp -- 369 * 370 * Allow the given interpreter to be used to handle vfs callbacks. 371 * 372 * Results: 373 * None. 374 * 375 * Side effects: 376 * May register the entire vfs code (if not previously registered). 377 * Registers some cleanup action for when this interpreter is 378 * deleted. 379 * 380 *---------------------------------------------------------------------- 381 */ 382static void 383Vfs_RegisterWithInterp(interp) 384 Tcl_Interp *interp; 385{ 386 ClientData vfsAlreadyRegistered; 387 /* 388 * We need to know if the interpreter is deleted, so we can 389 * remove all interp-specific mounts. 390 */ 391 Tcl_SetAssocData(interp, "vfs::inUse", (Tcl_InterpDeleteProc*) 392 Vfs_UnregisterWithInterp, (ClientData) 1); 393 /* 394 * Perform one-off registering of our filesystem if that 395 * has not happened before. 396 */ 397 vfsAlreadyRegistered = Tcl_FSData(&vfsFilesystem); 398 if (vfsAlreadyRegistered == NULL) { 399 Tcl_FSRegister((ClientData)1, &vfsFilesystem); 400 Tcl_CreateExitHandler(VfsExitProc, (ClientData)NULL); 401 Tcl_CreateThreadExitHandler(VfsThreadExitProc, NULL); 402 } 403} 404 405 406/* 407 *---------------------------------------------------------------------- 408 * 409 * Vfs_UnregisterWithInterp -- 410 * 411 * Remove all of the mount points that this interpreter handles. 412 * 413 * Results: 414 * None. 415 * 416 * Side effects: 417 * None. 418 * 419 *---------------------------------------------------------------------- 420 */ 421static void 422Vfs_UnregisterWithInterp(dummy, interp) 423 ClientData dummy; 424 Tcl_Interp *interp; 425{ 426 int res = TCL_OK; 427 /* Remove all of this interpreters mount points */ 428 while (res == TCL_OK) { 429 res = Vfs_RemoveMount(NULL, interp); 430 } 431 /* Make sure our assoc data has been deleted */ 432 Tcl_DeleteAssocData(interp, "vfs::inUse"); 433} 434 435 436/* 437 *---------------------------------------------------------------------- 438 * 439 * Vfs_AddMount -- 440 * 441 * Adds a new vfs mount point. After this call all filesystem 442 * access within that mount point will be redirected to the 443 * interpreter/mountCmd pair. 444 * 445 * This command must not be called unless 'interp' has already 446 * been registered with 'Vfs_RegisterWithInterp' above. This 447 * usually happens automatically with a 'package require vfs'. 448 * 449 * Results: 450 * TCL_OK unless the inputs are bad or a memory allocation 451 * error occurred, or the interpreter is not vfs-registered. 452 * 453 * Side effects: 454 * A new volume may be added to the list of available volumes. 455 * Future filesystem access inside the mountPoint will be 456 * redirected. Tcl is informed that a new mount has been added 457 * and this will make all cached path representations invalid. 458 * 459 *---------------------------------------------------------------------- 460 */ 461static int 462Vfs_AddMount(mountPoint, isVolume, interp, mountCmd) 463 Tcl_Obj* mountPoint; 464 int isVolume; 465 Tcl_Interp* interp; 466 Tcl_Obj* mountCmd; 467{ 468 char *strRep; 469 int len; 470 VfsMount *newMount; 471 ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey); 472 473 if (mountPoint == NULL || interp == NULL || mountCmd == NULL) { 474 return TCL_ERROR; 475 } 476 /* 477 * Check whether this intepreter can properly clean up 478 * mounts on exit. If not, throw an error. 479 */ 480 if (Tcl_GetAssocData(interp, "vfs::inUse", NULL) == NULL) { 481 return TCL_ERROR; 482 } 483 484 newMount = (VfsMount*) ckalloc(sizeof(VfsMount)); 485 486 if (newMount == NULL) { 487 return TCL_ERROR; 488 } 489 strRep = Tcl_GetStringFromObj(mountPoint, &len); 490 newMount->mountPoint = (char*) ckalloc(1+(unsigned)len); 491 newMount->mountLen = len; 492 493 if (newMount->mountPoint == NULL) { 494 ckfree((char*)newMount); 495 return TCL_ERROR; 496 } 497 498 strcpy((char*)newMount->mountPoint, strRep); 499 newMount->interpCmd.mountCmd = mountCmd; 500 newMount->interpCmd.interp = interp; 501 newMount->isVolume = isVolume; 502 Tcl_IncrRefCount(mountCmd); 503 504 newMount->nextMount = tsdPtr->listOfMounts; 505 tsdPtr->listOfMounts = newMount; 506 507 if (isVolume) { 508 Vfs_AddVolume(mountPoint); 509 } 510 Tcl_FSMountsChanged(&vfsFilesystem); 511 return TCL_OK; 512} 513 514 515/* 516 *---------------------------------------------------------------------- 517 * 518 * Vfs_RemoveMount -- 519 * 520 * This procedure searches for a matching mount point and removes 521 * it if one is found. If 'mountPoint' is given, then both it and 522 * the interpreter must match for a mount point to be removed. 523 * 524 * If 'mountPoint' is NULL, then the first mount point for the 525 * given interpreter is removed (if any). 526 * 527 * Results: 528 * TCL_OK if a mount was removed, TCL_ERROR otherwise. 529 * 530 * Side effects: 531 * A volume may be removed from the current list of volumes 532 * (as returned by 'file volumes'). A vfs may be removed from 533 * the filesystem. If successful, Tcl will be informed that 534 * the list of current mounts has changed, and all cached file 535 * representations will be made invalid. 536 * 537 *---------------------------------------------------------------------- 538 */ 539static int 540Vfs_RemoveMount(mountPoint, interp) 541 Tcl_Obj* mountPoint; 542 Tcl_Interp *interp; 543{ 544 /* These two are only used if mountPoint is non-NULL */ 545 char *strRep = NULL; 546 int len = 0; 547 ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey); 548 549 VfsMount *mountIter; 550 /* Set to NULL just to avoid warnings */ 551 VfsMount *lastMount = NULL; 552 553 if (mountPoint != NULL) { 554 strRep = Tcl_GetStringFromObj(mountPoint, &len); 555 } 556 557 mountIter = tsdPtr->listOfMounts; 558 559 while (mountIter != NULL) { 560 if ((interp == mountIter->interpCmd.interp) 561 && ((mountPoint == NULL) || 562 (mountIter->mountLen == len && 563 !strcmp(mountIter->mountPoint, strRep)))) { 564 /* We've found the mount. */ 565 if (mountIter == tsdPtr->listOfMounts) { 566 tsdPtr->listOfMounts = mountIter->nextMount; 567 } else { 568 lastMount->nextMount = mountIter->nextMount; 569 } 570 /* Free the allocated memory */ 571 if (mountIter->isVolume) { 572 if (mountPoint == NULL) { 573 Tcl_Obj *volObj = Tcl_NewStringObj(mountIter->mountPoint, 574 mountIter->mountLen); 575 Tcl_IncrRefCount(volObj); 576 Vfs_RemoveVolume(volObj); 577 Tcl_DecrRefCount(volObj); 578 } else { 579 Vfs_RemoveVolume(mountPoint); 580 } 581 } 582 ckfree((char*)mountIter->mountPoint); 583 Tcl_DecrRefCount(mountIter->interpCmd.mountCmd); 584 ckfree((char*)mountIter); 585 Tcl_FSMountsChanged(&vfsFilesystem); 586 return TCL_OK; 587 } 588 lastMount = mountIter; 589 mountIter = mountIter->nextMount; 590 } 591 return TCL_ERROR; 592} 593 594 595/* 596 *---------------------------------------------------------------------- 597 * 598 * Vfs_FindMount -- 599 * 600 * This procedure searches all currently mounted paths for one 601 * which matches the given path. The given path must be the 602 * absolute, normalized, unique representation for the given path. 603 * If 'len' is -1, we use the entire string representation of the 604 * mountPoint, otherwise we treat 'len' as the length of the mount 605 * we are comparing. 606 * 607 * Results: 608 * Returns the interpreter, command-prefix pair for the given 609 * mount point, if one is found, otherwise NULL. 610 * 611 * Side effects: 612 * None. 613 * 614 *---------------------------------------------------------------------- 615 */ 616static Vfs_InterpCmd* 617Vfs_FindMount(pathMount, mountLen) 618 Tcl_Obj *pathMount; 619 int mountLen; 620{ 621 VfsMount *mountIter; 622 char *mountStr; 623 ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey); 624 625 if (pathMount == NULL) { 626 return NULL; 627 } 628 629 if (mountLen == -1) { 630 mountStr = Tcl_GetStringFromObj(pathMount, &mountLen); 631 } else { 632 mountStr = Tcl_GetString(pathMount); 633 } 634 635 mountIter = tsdPtr->listOfMounts; 636 while (mountIter != NULL) { 637 if (mountIter->mountLen == mountLen && 638 !strncmp(mountIter->mountPoint, mountStr, (size_t)mountLen)) { 639 Vfs_InterpCmd *ret = &mountIter->interpCmd; 640 return ret; 641 } 642 mountIter = mountIter->nextMount; 643 } 644 return NULL; 645} 646 647 648/* 649 *---------------------------------------------------------------------- 650 * 651 * Vfs_ListMounts -- 652 * 653 * Returns a valid Tcl list, with refCount of zero, containing 654 * all currently mounted paths. 655 * 656 *---------------------------------------------------------------------- 657 */ 658static Tcl_Obj* 659Vfs_ListMounts(void) 660{ 661 VfsMount *mountIter; 662 Tcl_Obj *res = Tcl_NewObj(); 663 ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey); 664 665 /* Build list of mounts */ 666 mountIter = tsdPtr->listOfMounts; 667 while (mountIter != NULL) { 668 Tcl_Obj* mount = Tcl_NewStringObj(mountIter->mountPoint, 669 mountIter->mountLen); 670 Tcl_ListObjAppendElement(NULL, res, mount); 671 mountIter = mountIter->nextMount; 672 } 673 return res; 674} 675 676/* 677 *---------------------------------------------------------------------- 678 * 679 * VfsFilesystemObjCmd -- 680 * 681 * This procedure implements the "vfs::filesystem" command. It is 682 * used to mount/unmount particular interfaces to new filesystems, 683 * or to query for what is mounted where. 684 * 685 * Results: 686 * A standard Tcl result. 687 * 688 * Side effects: 689 * Inserts or removes a filesystem from Tcl's stack. 690 * 691 *---------------------------------------------------------------------- 692 */ 693 694static int 695VfsFilesystemObjCmd(dummy, interp, objc, objv) 696 ClientData dummy; 697 Tcl_Interp *interp; 698 int objc; 699 Tcl_Obj *CONST objv[]; 700{ 701 int index; 702 ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey); 703 704 static CONST char *optionStrings[] = { 705 "info", "internalerror", "mount", "unmount", 706 "fullynormalize", "posixerror", 707 NULL 708 }; 709 710 enum options { 711 VFS_INFO, VFS_INTERNAL_ERROR, VFS_MOUNT, VFS_UNMOUNT, 712 VFS_NORMALIZE, VFS_POSIXERROR 713 }; 714 715 if (objc < 2) { 716 Tcl_WrongNumArgs(interp, 1, objv, "option ?arg ...?"); 717 return TCL_ERROR; 718 } 719 if (Tcl_GetIndexFromObj(interp, objv[1], optionStrings, "option", 0, 720 &index) != TCL_OK) { 721 return TCL_ERROR; 722 } 723 724 switch ((enum options) index) { 725 case VFS_INTERNAL_ERROR: { 726 if (objc > 3) { 727 Tcl_WrongNumArgs(interp, 2, objv, "?script?"); 728 return TCL_ERROR; 729 } 730 if (objc == 2) { 731 /* Return the current script */ 732 if (tsdPtr->internalErrorScript != NULL) { 733 Tcl_SetObjResult(interp, tsdPtr->internalErrorScript); 734 } 735 } else { 736 /* Set the script */ 737 int len; 738 if (tsdPtr->internalErrorScript != NULL) { 739 Tcl_DecrRefCount(tsdPtr->internalErrorScript); 740 } 741 Tcl_GetStringFromObj(objv[2], &len); 742 if (len == 0) { 743 /* Clear our script */ 744 tsdPtr->internalErrorScript = NULL; 745 } else { 746 /* Set it */ 747 tsdPtr->internalErrorScript = objv[2]; 748 Tcl_IncrRefCount(tsdPtr->internalErrorScript); 749 } 750 } 751 return TCL_OK; 752 } 753 case VFS_POSIXERROR: { 754 int posixError = -1; 755 if (objc != 3) { 756 Tcl_WrongNumArgs(interp, 2, objv, "errorcode"); 757 return TCL_ERROR; 758 } 759 if (Tcl_GetIntFromObj(NULL, objv[2], &posixError) != TCL_OK) { 760 return TCL_ERROR; 761 } 762 Tcl_SetErrno(posixError); 763 /* 764 * This special error code propagate to the Tcl_Eval* calls in 765 * other parts of the vfs C code to indicate a posix error 766 * being raised by some vfs implementation. 767 */ 768 return TCLVFS_POSIXERROR; 769 } 770 case VFS_NORMALIZE: { 771 Tcl_Obj *path; 772 if (objc != 3) { 773 Tcl_WrongNumArgs(interp, 2, objv, "path"); 774 return TCL_ERROR; 775 } 776 path = VfsFullyNormalizePath(interp, objv[2]); 777 if (path == NULL) { 778 Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), 779 "not a valid path \"", Tcl_GetString(objv[2]), 780 "\"", (char *) NULL); 781 } else { 782 Tcl_SetObjResult(interp, path); 783 Tcl_DecrRefCount(path); 784 return TCL_OK; 785 } 786 } 787 case VFS_MOUNT: { 788 if (objc < 4 || objc > 5) { 789 Tcl_WrongNumArgs(interp, 1, objv, "mount ?-volume? path cmd"); 790 return TCL_ERROR; 791 } 792 if (objc == 5) { 793 char *option = Tcl_GetString(objv[2]); 794 if (strcmp("-volume", option)) { 795 Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), 796 "bad option \"", option, 797 "\": must be -volume", (char *) NULL); 798 return TCL_ERROR; 799 } 800 return Vfs_AddMount(objv[3], 1, interp, objv[4]); 801 } else { 802 Tcl_Obj *path; 803 int retVal; 804 path = VfsFullyNormalizePath(interp, objv[2]); 805 retVal = Vfs_AddMount(path, 0, interp, objv[3]); 806 if (path != NULL) { Tcl_DecrRefCount(path); } 807 return retVal; 808 } 809 break; 810 } 811 case VFS_INFO: { 812 if (objc > 3) { 813 Tcl_WrongNumArgs(interp, 2, objv, "path"); 814 return TCL_ERROR; 815 } 816 if (objc == 2) { 817 Tcl_SetObjResult(interp, Vfs_ListMounts()); 818 } else { 819 Vfs_InterpCmd *val; 820 821 val = Vfs_FindMount(objv[2], -1); 822 if (val == NULL) { 823 Tcl_Obj *path; 824 path = VfsFullyNormalizePath(interp, objv[2]); 825 val = Vfs_FindMount(path, -1); 826 Tcl_DecrRefCount(path); 827 if (val == NULL) { 828 Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), 829 "no such mount \"", Tcl_GetString(objv[2]), 830 "\"", (char *) NULL); 831 return TCL_ERROR; 832 } 833 } 834 Tcl_SetObjResult(interp, val->mountCmd); 835 } 836 break; 837 } 838 case VFS_UNMOUNT: { 839 if (objc != 3) { 840 Tcl_WrongNumArgs(interp, 2, objv, "path"); 841 return TCL_ERROR; 842 } 843 if (Vfs_RemoveMount(objv[2], interp) == TCL_ERROR) { 844 Tcl_Obj *path; 845 int retVal; 846 path = VfsFullyNormalizePath(interp, objv[2]); 847 retVal = Vfs_RemoveMount(path, interp); 848 Tcl_DecrRefCount(path); 849 if (retVal == TCL_ERROR) { 850 Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), 851 "no such mount \"", Tcl_GetString(objv[2]), 852 "\"", (char *) NULL); 853 return TCL_ERROR; 854 } 855 } 856 return TCL_OK; 857 } 858 } 859 return TCL_OK; 860} 861 862/* Handle an error thrown by a tcl vfs implementation */ 863static void 864VfsInternalError(Tcl_Interp* interp) 865{ 866 if (interp != NULL) { 867 ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey); 868 if (tsdPtr->internalErrorScript != NULL) { 869 Tcl_EvalObjEx(interp, tsdPtr->internalErrorScript, 870 TCL_EVAL_GLOBAL | TCL_EVAL_DIRECT); 871 } 872 } 873} 874 875/* Return fully normalized path owned by the caller */ 876static Tcl_Obj* 877VfsFullyNormalizePath(Tcl_Interp *interp, Tcl_Obj *pathPtr) { 878 Tcl_Obj *path; 879 int counter = 0; 880 881 Tcl_IncrRefCount(pathPtr); 882 while (1) { 883 path = Tcl_FSLink(pathPtr,NULL,0); 884 if (path == NULL) { 885 break; 886 } 887 if (Tcl_FSGetPathType(path) != TCL_PATH_ABSOLUTE) { 888 /* 889 * This is more complex, we need to find the path 890 * relative to the original file, effectively: 891 * 892 * file join [file dirname $pathPtr] $path 893 * 894 * or 895 * 896 * file join $pathPtr .. $path 897 * 898 * So... 899 */ 900 Tcl_Obj *dotdotPtr, *joinedPtr; 901 Tcl_Obj *joinElements[2]; 902 903 dotdotPtr = Tcl_NewStringObj("..",2); 904 Tcl_IncrRefCount(dotdotPtr); 905 906 joinElements[0] = dotdotPtr; 907 joinElements[1] = path; 908 909 joinedPtr = Tcl_FSJoinToPath(pathPtr, 2, joinElements); 910 911 if (joinedPtr != NULL) { 912 Tcl_IncrRefCount(joinedPtr); 913 Tcl_DecrRefCount(path); 914 path = joinedPtr; 915 } else { 916 /* We failed, and our action is undefined */ 917 } 918 Tcl_DecrRefCount(dotdotPtr); 919 } 920 Tcl_DecrRefCount(pathPtr); 921 pathPtr = path; 922 counter++; 923 if (counter > 10) { 924 /* Too many links */ 925 Tcl_DecrRefCount(pathPtr); 926 return NULL; 927 } 928 } 929 path = Tcl_FSGetNormalizedPath(interp, pathPtr); 930 Tcl_IncrRefCount(path); 931 Tcl_DecrRefCount(pathPtr); 932 return path; 933} 934 935/* 936 *---------------------------------------------------------------------- 937 * 938 * VfsPathInFilesystem -- 939 * 940 * Check whether a path is in any of the mounted points in this 941 * vfs. 942 * 943 * If it is in the vfs, set the clientData given to our private 944 * internal representation for a vfs path. 945 * 946 * Results: 947 * Returns TCL_OK on success, or 'TCLVFS_POSIXERROR' on failure. 948 * If Tcl is exiting, we always return a failure code. 949 * 950 * Side effects: 951 * On success, we allocate some memory for our internal 952 * representation structure. Tcl will call us to free this 953 * when necessary. 954 * 955 *---------------------------------------------------------------------- 956 */ 957static int 958VfsPathInFilesystem(Tcl_Obj *pathPtr, ClientData *clientDataPtr) { 959 Tcl_Obj *normedObj; 960 int len, splitPosition; 961 char *normed; 962 VfsNativeRep *nativeRep; 963 Vfs_InterpCmd *interpCmd = NULL; 964 965 if (TclInExit()) { 966 /* 967 * Even Tcl_FSGetNormalizedPath may fail due to lack of system 968 * encodings, so we just say we can't handle anything if we are 969 * in the middle of the exit sequence. We could perhaps be 970 * more subtle than this! 971 */ 972 return TCLVFS_POSIXERROR; 973 } 974 975 normedObj = Tcl_FSGetNormalizedPath(NULL, pathPtr); 976 if (normedObj == NULL) { 977 return TCLVFS_POSIXERROR; 978 } 979 normed = Tcl_GetStringFromObj(normedObj, &len); 980 splitPosition = len; 981 982 /* 983 * Find the most specific mount point for this path. 984 * Mount points are specified by unique strings, so 985 * we have to use a unique normalised path for the 986 * checks here. 987 * 988 * Given mount points are paths, 'most specific' means 989 * longest path, so we scan from end to beginning 990 * checking for valid mount points at each separator. 991 */ 992 while (1) { 993 /* 994 * We need this test here both for an empty string being 995 * passed in above, and so that if we are testing a unix 996 * absolute path /foo/bar we will come around the loop 997 * with splitPosition at 0 for the last iteration, and we 998 * must return then. 999 */ 1000 if (splitPosition == 0) { 1001 return TCLVFS_POSIXERROR; 1002 } 1003 1004 /* Is the path up to 'splitPosition' a valid moint point? */ 1005 interpCmd = Vfs_FindMount(normedObj, splitPosition); 1006 if (interpCmd != NULL) break; 1007 1008 while (normed[--splitPosition] != VFS_SEPARATOR) { 1009 if (splitPosition == 0) { 1010 /* 1011 * We've reached the beginning of the string without 1012 * finding a mount, so we've failed. 1013 */ 1014 return TCLVFS_POSIXERROR; 1015 } 1016 } 1017 1018 /* 1019 * We now know that normed[splitPosition] is a separator. 1020 * However, we might have mounted a root filesystem with a 1021 * name (for example 'ftp://') which actually includes a 1022 * separator. Therefore we test whether the path with 1023 * a separator is a mount point. 1024 * 1025 * Since we must have decremented splitPosition at least once 1026 * already (above) 'splitPosition+1 <= len' so this won't 1027 * access invalid memory. 1028 */ 1029 interpCmd = Vfs_FindMount(normedObj, splitPosition+1); 1030 if (interpCmd != NULL) { 1031 splitPosition++; 1032 break; 1033 } 1034 } 1035 1036 /* 1037 * If we reach here we have a valid mount point, since the 1038 * only way to escape the above loop is through a 'break' when 1039 * an interpCmd is non-NULL. 1040 */ 1041 nativeRep = (VfsNativeRep*) ckalloc(sizeof(VfsNativeRep)); 1042 nativeRep->splitPosition = splitPosition; 1043 nativeRep->fsCmd = interpCmd; 1044 *clientDataPtr = (ClientData)nativeRep; 1045 return TCL_OK; 1046} 1047 1048/* 1049 * Simple helper function to extract the native vfs representation of a 1050 * path object, or NULL if no such representation exists. 1051 */ 1052static VfsNativeRep* 1053VfsGetNativePath(Tcl_Obj* pathPtr) { 1054 return (VfsNativeRep*) Tcl_FSGetInternalRep(pathPtr, &vfsFilesystem); 1055} 1056 1057static void 1058VfsFreeInternalRep(ClientData clientData) { 1059 VfsNativeRep *nativeRep = (VfsNativeRep*)clientData; 1060 if (nativeRep != NULL) { 1061 /* Free the native memory allocation */ 1062 ckfree((char*)nativeRep); 1063 } 1064} 1065 1066static ClientData 1067VfsDupInternalRep(ClientData clientData) { 1068 VfsNativeRep *original = (VfsNativeRep*)clientData; 1069 1070 VfsNativeRep *nativeRep = (VfsNativeRep*) ckalloc(sizeof(VfsNativeRep)); 1071 nativeRep->splitPosition = original->splitPosition; 1072 nativeRep->fsCmd = original->fsCmd; 1073 1074 return (ClientData)nativeRep; 1075} 1076 1077static Tcl_Obj* 1078VfsFilesystemPathType(Tcl_Obj *pathPtr) { 1079 VfsNativeRep* nativeRep = VfsGetNativePath(pathPtr); 1080 if (nativeRep == NULL) { 1081 return NULL; 1082 } else { 1083 return nativeRep->fsCmd->mountCmd; 1084 } 1085} 1086 1087static Tcl_Obj* 1088VfsFilesystemSeparator(Tcl_Obj* pathPtr) { 1089 char sep=VFS_SEPARATOR; 1090 return Tcl_NewStringObj(&sep,1); 1091} 1092 1093static int 1094VfsStat(pathPtr, bufPtr) 1095 Tcl_Obj *pathPtr; /* Path of file to stat (in current CP). */ 1096 Tcl_StatBuf *bufPtr; /* Filled with results of stat call. */ 1097{ 1098 Tcl_Obj *mountCmd = NULL; 1099 Tcl_SavedResult savedResult; 1100 int returnVal; 1101 Tcl_Interp* interp; 1102 1103 mountCmd = VfsBuildCommandForPath(&interp, "stat", pathPtr); 1104 if (mountCmd == NULL) { 1105 return TCLVFS_POSIXERROR; 1106 } 1107 1108 Tcl_SaveResult(interp, &savedResult); 1109 /* Now we execute this mount point's callback. */ 1110 returnVal = Tcl_EvalObjEx(interp, mountCmd, 1111 TCL_EVAL_GLOBAL | TCL_EVAL_DIRECT); 1112 if (returnVal == TCL_OK) { 1113 int statListLength; 1114 Tcl_Obj* resPtr = Tcl_GetObjResult(interp); 1115 if (Tcl_ListObjLength(interp, resPtr, &statListLength) == TCL_ERROR) { 1116 returnVal = TCL_ERROR; 1117 } else if (statListLength & 1) { 1118 /* It is odd! */ 1119 returnVal = TCL_ERROR; 1120 } else { 1121 /* 1122 * The st_mode field is set part by the 'mode' 1123 * and part by the 'type' stat fields. 1124 */ 1125 bufPtr->st_mode = 0; 1126 while (statListLength > 0) { 1127 Tcl_Obj *field, *val; 1128 char *fieldName; 1129 statListLength -= 2; 1130 Tcl_ListObjIndex(interp, resPtr, statListLength, &field); 1131 Tcl_ListObjIndex(interp, resPtr, statListLength+1, &val); 1132 fieldName = Tcl_GetString(field); 1133 if (!strcmp(fieldName,"dev")) { 1134 long v; 1135 if (Tcl_GetLongFromObj(interp, val, &v) != TCL_OK) { 1136 returnVal = TCL_ERROR; 1137 break; 1138 } 1139 bufPtr->st_dev = v; 1140 } else if (!strcmp(fieldName,"ino")) { 1141 long v; 1142 if (Tcl_GetLongFromObj(interp, val, &v) != TCL_OK) { 1143 returnVal = TCL_ERROR; 1144 break; 1145 } 1146 bufPtr->st_ino = (unsigned short)v; 1147 } else if (!strcmp(fieldName,"mode")) { 1148 int v; 1149 if (Tcl_GetIntFromObj(interp, val, &v) != TCL_OK) { 1150 returnVal = TCL_ERROR; 1151 break; 1152 } 1153 bufPtr->st_mode |= v; 1154 } else if (!strcmp(fieldName,"nlink")) { 1155 long v; 1156 if (Tcl_GetLongFromObj(interp, val, &v) != TCL_OK) { 1157 returnVal = TCL_ERROR; 1158 break; 1159 } 1160 bufPtr->st_nlink = (short)v; 1161 } else if (!strcmp(fieldName,"uid")) { 1162 long v; 1163 if (Tcl_GetLongFromObj(interp, val, &v) != TCL_OK) { 1164 returnVal = TCL_ERROR; 1165 break; 1166 } 1167 bufPtr->st_uid = (short)v; 1168 } else if (!strcmp(fieldName,"gid")) { 1169 long v; 1170 if (Tcl_GetLongFromObj(interp, val, &v) != TCL_OK) { 1171 returnVal = TCL_ERROR; 1172 break; 1173 } 1174 bufPtr->st_gid = (short)v; 1175 } else if (!strcmp(fieldName,"size")) { 1176 Tcl_WideInt v; 1177 if (Tcl_GetWideIntFromObj(interp, val, &v) != TCL_OK) { 1178 returnVal = TCL_ERROR; 1179 break; 1180 } 1181 bufPtr->st_size = v; 1182 } else if (!strcmp(fieldName,"atime")) { 1183 long v; 1184 if (Tcl_GetLongFromObj(interp, val, &v) != TCL_OK) { 1185 returnVal = TCL_ERROR; 1186 break; 1187 } 1188 bufPtr->st_atime = v; 1189 } else if (!strcmp(fieldName,"mtime")) { 1190 long v; 1191 if (Tcl_GetLongFromObj(interp, val, &v) != TCL_OK) { 1192 returnVal = TCL_ERROR; 1193 break; 1194 } 1195 bufPtr->st_mtime = v; 1196 } else if (!strcmp(fieldName,"ctime")) { 1197 long v; 1198 if (Tcl_GetLongFromObj(interp, val, &v) != TCL_OK) { 1199 returnVal = TCL_ERROR; 1200 break; 1201 } 1202 bufPtr->st_ctime = v; 1203 } else if (!strcmp(fieldName,"type")) { 1204 char *str; 1205 str = Tcl_GetString(val); 1206 if (!strcmp(str,"directory")) { 1207 bufPtr->st_mode |= S_IFDIR; 1208 } else if (!strcmp(str,"file")) { 1209 bufPtr->st_mode |= S_IFREG; 1210#ifdef S_ISLNK 1211 } else if (!strcmp(str,"link")) { 1212 bufPtr->st_mode |= S_IFLNK; 1213#endif 1214 } else { 1215 /* 1216 * Do nothing. This means we do not currently 1217 * support anything except files and directories 1218 */ 1219 } 1220 } else { 1221 /* Ignore additional stat arguments */ 1222 } 1223 } 1224 } 1225 } 1226 1227 if (returnVal != TCL_OK && returnVal != TCLVFS_POSIXERROR) { 1228 VfsInternalError(interp); 1229 } 1230 1231 Tcl_RestoreResult(interp, &savedResult); 1232 Tcl_DecrRefCount(mountCmd); 1233 1234 if (returnVal != TCL_OK && returnVal != TCLVFS_POSIXERROR) { 1235 Tcl_SetErrno(ENOENT); 1236 return TCLVFS_POSIXERROR; 1237 } else { 1238 return returnVal; 1239 } 1240} 1241 1242static int 1243VfsAccess(pathPtr, mode) 1244 Tcl_Obj *pathPtr; /* Path of file to access (in current CP). */ 1245 int mode; /* Permission setting. */ 1246{ 1247 Tcl_Obj *mountCmd = NULL; 1248 Tcl_SavedResult savedResult; 1249 int returnVal; 1250 Tcl_Interp* interp; 1251 1252 mountCmd = VfsBuildCommandForPath(&interp, "access", pathPtr); 1253 if (mountCmd == NULL) { 1254 return TCLVFS_POSIXERROR; 1255 } 1256 1257 Tcl_ListObjAppendElement(interp, mountCmd, Tcl_NewIntObj(mode)); 1258 /* Now we execute this mount point's callback. */ 1259 Tcl_SaveResult(interp, &savedResult); 1260 returnVal = Tcl_EvalObjEx(interp, mountCmd, 1261 TCL_EVAL_GLOBAL | TCL_EVAL_DIRECT); 1262 if (returnVal != TCL_OK && returnVal != TCLVFS_POSIXERROR) { 1263 VfsInternalError(interp); 1264 } 1265 Tcl_RestoreResult(interp, &savedResult); 1266 Tcl_DecrRefCount(mountCmd); 1267 1268 if (returnVal != 0) { 1269 Tcl_SetErrno(ENOENT); 1270 return TCLVFS_POSIXERROR; 1271 } else { 1272 return returnVal; 1273 } 1274} 1275 1276static Tcl_Obj* 1277VfsGetMode(int mode) { 1278 Tcl_Obj *ret = Tcl_NewObj(); 1279 if (mode & O_RDONLY) { 1280 Tcl_AppendToObj(ret, "r", 1); 1281 } else if (mode & O_WRONLY || mode & O_RDWR) { 1282 if (mode & O_TRUNC) { 1283 Tcl_AppendToObj(ret, "w", 1); 1284 } else { 1285 Tcl_AppendToObj(ret, "a", 1); 1286 } 1287 if (mode & O_RDWR) { 1288 Tcl_AppendToObj(ret, "+", 1); 1289 } 1290 } 1291 return ret; 1292} 1293 1294static Tcl_Channel 1295VfsOpenFileChannel(cmdInterp, pathPtr, mode, permissions) 1296 Tcl_Interp *cmdInterp; /* Interpreter for error reporting; 1297 * can be NULL. */ 1298 Tcl_Obj *pathPtr; /* Name of file to open. */ 1299 int mode; /* POSIX open mode. */ 1300 int permissions; /* If the open involves creating a 1301 * file, with what modes to create 1302 * it? */ 1303{ 1304 Tcl_Channel chan = NULL; 1305 Tcl_Obj *mountCmd = NULL; 1306 Tcl_Obj *closeCallback = NULL; 1307 Tcl_SavedResult savedResult; 1308 int returnVal; 1309 Tcl_Interp* interp; 1310 1311 mountCmd = VfsBuildCommandForPath(&interp, "open", pathPtr); 1312 if (mountCmd == NULL) { 1313 return NULL; 1314 } 1315 1316 Tcl_ListObjAppendElement(interp, mountCmd, VfsGetMode(mode)); 1317 Tcl_ListObjAppendElement(interp, mountCmd, Tcl_NewIntObj(permissions)); 1318 Tcl_SaveResult(interp, &savedResult); 1319 /* Now we execute this mount point's callback. */ 1320 returnVal = Tcl_EvalObjEx(interp, mountCmd, 1321 TCL_EVAL_GLOBAL | TCL_EVAL_DIRECT); 1322 if (returnVal == TCL_OK) { 1323 int reslen; 1324 Tcl_Obj *resultObj; 1325 /* 1326 * There may be file channel leaks on these two 1327 * error conditions, if the open command actually 1328 * created a channel, but then passed us a bogus list. 1329 */ 1330 resultObj = Tcl_GetObjResult(interp); 1331 if ((Tcl_ListObjLength(interp, resultObj, &reslen) == TCL_ERROR) 1332 || (reslen > 2) || (reslen == 0)) { 1333 returnVal = TCL_ERROR; 1334 } else { 1335 Tcl_Obj *element; 1336 Tcl_ListObjIndex(interp, resultObj, 0, &element); 1337 chan = Tcl_GetChannel(interp, Tcl_GetString(element), 0); 1338 1339 if (chan == NULL) { 1340 returnVal = TCL_ERROR; 1341 } else { 1342 if (reslen == 2) { 1343 Tcl_ListObjIndex(interp, resultObj, 1, &element); 1344 closeCallback = element; 1345 Tcl_IncrRefCount(closeCallback); 1346 } 1347 } 1348 } 1349 Tcl_RestoreResult(interp, &savedResult); 1350 } else { 1351 /* Leave an error message if the cmdInterp is non NULL */ 1352 if (cmdInterp != NULL) { 1353 if (returnVal == TCLVFS_POSIXERROR) { 1354 Tcl_ResetResult(cmdInterp); 1355 Tcl_AppendResult(cmdInterp, "couldn't open \"", 1356 Tcl_GetString(pathPtr), "\": ", 1357 Tcl_PosixError(cmdInterp), (char *) NULL); 1358 } else { 1359 Tcl_Obj* error = Tcl_GetObjResult(interp); 1360 /* 1361 * Copy over the error message to cmdInterp, 1362 * duplicating it in case of threading issues. 1363 */ 1364 Tcl_SetObjResult(cmdInterp, Tcl_DuplicateObj(error)); 1365 } 1366 } else { 1367 /* Report any error, since otherwise it is lost */ 1368 if (returnVal != TCLVFS_POSIXERROR) { 1369 VfsInternalError(interp); 1370 } 1371 } 1372 if (interp == cmdInterp) { 1373 /* 1374 * We want our error message to propagate up, 1375 * so we want to forget this result 1376 */ 1377 Tcl_DiscardResult(&savedResult); 1378 } else { 1379 Tcl_RestoreResult(interp, &savedResult); 1380 } 1381 } 1382 1383 Tcl_DecrRefCount(mountCmd); 1384 1385 if (chan != NULL) { 1386 /* 1387 * We got the Channel from some Tcl code. This means it was 1388 * registered with the interpreter. But we want a pristine 1389 * channel which hasn't been registered with anyone. We use 1390 * Tcl_DetachChannel to do this for us. We must use the 1391 * correct interpreter. 1392 */ 1393 if (Tcl_IsStandardChannel(chan)) { 1394 /* 1395 * If we have somehow ended up with a VFS channel being a std 1396 * channel, it is likely auto-inherited, which we need to reverse. 1397 * [Bug 1468291] 1398 */ 1399 if (chan == Tcl_GetStdChannel(TCL_STDIN)) { 1400 Tcl_SetStdChannel(NULL, TCL_STDIN); 1401 } else if (chan == Tcl_GetStdChannel(TCL_STDOUT)) { 1402 Tcl_SetStdChannel(NULL, TCL_STDOUT); 1403 } else if (chan == Tcl_GetStdChannel(TCL_STDERR)) { 1404 Tcl_SetStdChannel(NULL, TCL_STDERR); 1405 } 1406 Tcl_UnregisterChannel(NULL, chan); 1407 } 1408 Tcl_DetachChannel(interp, chan); 1409 1410 if (closeCallback != NULL) { 1411 VfsChannelCleanupInfo *channelRet = NULL; 1412 channelRet = (VfsChannelCleanupInfo*) 1413 ckalloc(sizeof(VfsChannelCleanupInfo)); 1414 channelRet->channel = chan; 1415 channelRet->interp = interp; 1416 channelRet->closeCallback = closeCallback; 1417 /* The channelRet structure will be freed in the callback */ 1418 Tcl_CreateCloseHandler(chan, &VfsCloseProc, 1419 (ClientData)channelRet); 1420 } 1421 } 1422 return chan; 1423} 1424 1425/* 1426 * IMPORTANT: This procedure must *not* modify the interpreter's result 1427 * this leads to the objResultPtr being corrupted (somehow), and curious 1428 * crashes in the future (which are very hard to debug ;-). 1429 * 1430 * This is particularly important since we are evaluating arbitrary 1431 * Tcl code in the callback. 1432 * 1433 * Also note we are relying on the close-callback to occur just before 1434 * the channel is about to be properly closed, but after all output 1435 * has been flushed. That way we can, in the callback, read in the 1436 * entire contents of the channel and, say, compress it for storage 1437 * into a tclkit or zip archive. 1438 */ 1439static void 1440VfsCloseProc(ClientData clientData) { 1441 VfsChannelCleanupInfo * channelRet = (VfsChannelCleanupInfo*) clientData; 1442 int returnVal; 1443 Tcl_SavedResult savedResult; 1444 Tcl_Channel chan = channelRet->channel; 1445 Tcl_Interp * interp = channelRet->interp; 1446 1447 Tcl_SaveResult(interp, &savedResult); 1448 1449 /* 1450 * The interpreter needs to know about the channel, else the Tcl 1451 * callback will fail, so we register the channel (this allows 1452 * the Tcl code to use the channel's string-name). 1453 */ 1454 if (!Tcl_IsStandardChannel(chan)) { 1455 Tcl_RegisterChannel(interp, chan); 1456 } 1457 1458 if (!(Tcl_GetChannelMode(chan) & TCL_READABLE)) { 1459 /* 1460 * We need to make this channel readable, since tclvfs 1461 * documents that close callbacks are allowed to read 1462 * from the channels we create. 1463 */ 1464 1465 /* Currently if we reach here we have a bug */ 1466 } 1467 1468 returnVal = Tcl_EvalObjEx(interp, channelRet->closeCallback, 1469 TCL_EVAL_GLOBAL | TCL_EVAL_DIRECT); 1470 if (returnVal != TCL_OK) { 1471 VfsInternalError(interp); 1472 } 1473 Tcl_DecrRefCount(channelRet->closeCallback); 1474 1475 /* 1476 * More complications; we can't just unregister the channel, 1477 * because it is in the middle of being cleaned up, and the cleanup 1478 * code doesn't like a channel to be closed again while it is 1479 * already being closed. So, we do the same trick as above to 1480 * unregister it without cleanup. 1481 */ 1482 if (!Tcl_IsStandardChannel(chan)) { 1483 Tcl_DetachChannel(interp, chan); 1484 } 1485 1486 Tcl_RestoreResult(interp, &savedResult); 1487 ckfree((char*)channelRet); 1488} 1489 1490static int 1491VfsMatchInDirectory( 1492 Tcl_Interp *cmdInterp, /* Interpreter to receive error msgs. */ 1493 Tcl_Obj *returnPtr, /* Object to receive results. */ 1494 Tcl_Obj *dirPtr, /* Contains path to directory to search. */ 1495 CONST char *pattern, /* Pattern to match against. */ 1496 Tcl_GlobTypeData *types) /* Object containing list of acceptable types. 1497 * May be NULL. */ 1498{ 1499 if ((types != NULL) && (types->type & TCL_GLOB_TYPE_MOUNT)) { 1500 VfsMount *mountIter; 1501 int len; 1502 CONST char *prefix; 1503 ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey); 1504 1505 prefix = Tcl_GetStringFromObj(Tcl_FSGetNormalizedPath(NULL, dirPtr), 1506 &len); 1507 if (prefix[len-1] == '/') { 1508 /* 1509 * It's a root directory; we must subtract one for 1510 * our comparisons below 1511 */ 1512 len--; 1513 } 1514 1515 /* Build list of mounts */ 1516 mountIter = tsdPtr->listOfMounts; 1517 while (mountIter != NULL) { 1518 if (mountIter->mountLen > (len+1) 1519 && !strncmp(mountIter->mountPoint, prefix, (size_t)len) 1520 && mountIter->mountPoint[len] == '/' 1521 && strchr(mountIter->mountPoint+len+1, '/') == NULL 1522 && Tcl_StringCaseMatch(mountIter->mountPoint+len+1, 1523 pattern, 0)) { 1524 Tcl_Obj* mount = Tcl_NewStringObj(mountIter->mountPoint, 1525 mountIter->mountLen); 1526 Tcl_ListObjAppendElement(NULL, returnPtr, mount); 1527 } 1528 mountIter = mountIter->nextMount; 1529 } 1530 return TCL_OK; 1531 } else { 1532 Tcl_Obj *mountCmd = NULL; 1533 Tcl_SavedResult savedResult; 1534 int returnVal; 1535 Tcl_Interp* interp; 1536 int type = 0; 1537 Tcl_Obj *vfsResultPtr = NULL; 1538 1539 mountCmd = VfsBuildCommandForPath(&interp, "matchindirectory", dirPtr); 1540 if (mountCmd == NULL) { 1541 return TCLVFS_POSIXERROR; 1542 } 1543 1544 if (types != NULL) { 1545 type = types->type; 1546 } 1547 1548 if (pattern == NULL) { 1549 Tcl_ListObjAppendElement(interp, mountCmd, Tcl_NewObj()); 1550 } else { 1551 Tcl_ListObjAppendElement(interp, mountCmd, 1552 Tcl_NewStringObj(pattern,-1)); 1553 } 1554 Tcl_ListObjAppendElement(interp, mountCmd, Tcl_NewIntObj(type)); 1555 Tcl_SaveResult(interp, &savedResult); 1556 /* Now we execute this mount point's callback. */ 1557 returnVal = Tcl_EvalObjEx(interp, mountCmd, 1558 TCL_EVAL_GLOBAL | TCL_EVAL_DIRECT); 1559 if (returnVal != TCLVFS_POSIXERROR) { 1560 vfsResultPtr = Tcl_DuplicateObj(Tcl_GetObjResult(interp)); 1561 } 1562 Tcl_RestoreResult(interp, &savedResult); 1563 Tcl_DecrRefCount(mountCmd); 1564 1565 if (vfsResultPtr != NULL) { 1566 if (returnVal == TCL_OK) { 1567 Tcl_IncrRefCount(vfsResultPtr); 1568 Tcl_ListObjAppendList(cmdInterp, returnPtr, vfsResultPtr); 1569 Tcl_DecrRefCount(vfsResultPtr); 1570 } else { 1571 if (cmdInterp != NULL) { 1572 Tcl_SetObjResult(cmdInterp, vfsResultPtr); 1573 } else { 1574 Tcl_DecrRefCount(vfsResultPtr); 1575 } 1576 } 1577 } 1578 return returnVal; 1579 } 1580} 1581 1582static int 1583VfsDeleteFile( 1584 Tcl_Obj *pathPtr) /* Pathname of file to be removed */ 1585{ 1586 Tcl_Obj *mountCmd = NULL; 1587 Tcl_SavedResult savedResult; 1588 int returnVal; 1589 Tcl_Interp* interp; 1590 1591 mountCmd = VfsBuildCommandForPath(&interp, "deletefile", pathPtr); 1592 if (mountCmd == NULL) { 1593 return TCLVFS_POSIXERROR; 1594 } 1595 1596 /* Now we execute this mount point's callback. */ 1597 Tcl_SaveResult(interp, &savedResult); 1598 returnVal = Tcl_EvalObjEx(interp, mountCmd, 1599 TCL_EVAL_GLOBAL | TCL_EVAL_DIRECT); 1600 if (returnVal != TCL_OK && returnVal != TCLVFS_POSIXERROR) { 1601 VfsInternalError(interp); 1602 } 1603 Tcl_RestoreResult(interp, &savedResult); 1604 Tcl_DecrRefCount(mountCmd); 1605 return returnVal; 1606} 1607 1608static int 1609VfsCreateDirectory( 1610 Tcl_Obj *pathPtr) /* Pathname of directory to create */ 1611{ 1612 Tcl_Obj *mountCmd = NULL; 1613 Tcl_SavedResult savedResult; 1614 int returnVal; 1615 Tcl_Interp* interp; 1616 1617 mountCmd = VfsBuildCommandForPath(&interp, "createdirectory", pathPtr); 1618 if (mountCmd == NULL) { 1619 return TCLVFS_POSIXERROR; 1620 } 1621 1622 /* Now we execute this mount point's callback. */ 1623 Tcl_SaveResult(interp, &savedResult); 1624 returnVal = Tcl_EvalObjEx(interp, mountCmd, 1625 TCL_EVAL_GLOBAL | TCL_EVAL_DIRECT); 1626 if (returnVal != TCL_OK && returnVal != TCLVFS_POSIXERROR) { 1627 VfsInternalError(interp); 1628 } 1629 Tcl_RestoreResult(interp, &savedResult); 1630 Tcl_DecrRefCount(mountCmd); 1631 return returnVal; 1632} 1633 1634static int 1635VfsRemoveDirectory( 1636 Tcl_Obj *pathPtr, /* Pathname of directory to be removed 1637 * (UTF-8). */ 1638 int recursive, /* If non-zero, removes directories that 1639 * are nonempty. Otherwise, will only remove 1640 * empty directories. */ 1641 Tcl_Obj **errorPtr) /* Location to store name of file 1642 * causing error. */ 1643{ 1644 Tcl_Obj *mountCmd = NULL; 1645 Tcl_SavedResult savedResult; 1646 int returnVal; 1647 Tcl_Interp* interp; 1648 1649 mountCmd = VfsBuildCommandForPath(&interp, "removedirectory", pathPtr); 1650 if (mountCmd == NULL) { 1651 return TCLVFS_POSIXERROR; 1652 } 1653 1654 Tcl_ListObjAppendElement(interp, mountCmd, Tcl_NewIntObj(recursive)); 1655 /* Now we execute this mount point's callback. */ 1656 Tcl_SaveResult(interp, &savedResult); 1657 returnVal = Tcl_EvalObjEx(interp, mountCmd, 1658 TCL_EVAL_GLOBAL | TCL_EVAL_DIRECT); 1659 if (returnVal != TCL_OK && returnVal != TCLVFS_POSIXERROR) { 1660 VfsInternalError(interp); 1661 } 1662 Tcl_RestoreResult(interp, &savedResult); 1663 Tcl_DecrRefCount(mountCmd); 1664 1665 if (returnVal == TCL_ERROR) { 1666 /* Assume there was a problem with the directory being non-empty */ 1667 if (errorPtr != NULL) { 1668 *errorPtr = pathPtr; 1669 Tcl_IncrRefCount(*errorPtr); 1670 } 1671 Tcl_SetErrno(EEXIST); 1672 } 1673 return returnVal; 1674} 1675 1676static CONST char * CONST86 * 1677VfsFileAttrStrings(pathPtr, objPtrRef) 1678 Tcl_Obj* pathPtr; 1679 Tcl_Obj** objPtrRef; 1680{ 1681 Tcl_Obj *mountCmd = NULL; 1682 Tcl_SavedResult savedResult; 1683 int returnVal; 1684 Tcl_Interp* interp; 1685 1686 mountCmd = VfsBuildCommandForPath(&interp, "fileattributes", pathPtr); 1687 if (mountCmd == NULL) { 1688 *objPtrRef = NULL; 1689 return NULL; 1690 } 1691 1692 Tcl_SaveResult(interp, &savedResult); 1693 /* Now we execute this mount point's callback. */ 1694 returnVal = Tcl_EvalObjEx(interp, mountCmd, 1695 TCL_EVAL_GLOBAL | TCL_EVAL_DIRECT); 1696 if (returnVal != TCL_OK && returnVal != TCLVFS_POSIXERROR) { 1697 VfsInternalError(interp); 1698 } 1699 if (returnVal == TCL_OK) { 1700 *objPtrRef = Tcl_DuplicateObj(Tcl_GetObjResult(interp)); 1701 } else { 1702 *objPtrRef = NULL; 1703 } 1704 Tcl_RestoreResult(interp, &savedResult); 1705 Tcl_DecrRefCount(mountCmd); 1706 return NULL; 1707} 1708 1709static int 1710VfsFileAttrsGet(cmdInterp, index, pathPtr, objPtrRef) 1711 Tcl_Interp *cmdInterp; /* The interpreter for error reporting. */ 1712 int index; /* index of the attribute command. */ 1713 Tcl_Obj *pathPtr; /* filename we are operating on. */ 1714 Tcl_Obj **objPtrRef; /* for output. */ 1715{ 1716 Tcl_Obj *mountCmd = NULL; 1717 Tcl_SavedResult savedResult; 1718 int returnVal; 1719 Tcl_Interp* interp; 1720 1721 mountCmd = VfsBuildCommandForPath(&interp, "fileattributes", pathPtr); 1722 if (mountCmd == NULL) { 1723 return TCLVFS_POSIXERROR; 1724 } 1725 1726 Tcl_ListObjAppendElement(interp, mountCmd, Tcl_NewIntObj(index)); 1727 Tcl_SaveResult(interp, &savedResult); 1728 /* Now we execute this mount point's callback. */ 1729 returnVal = Tcl_EvalObjEx(interp, mountCmd, 1730 TCL_EVAL_GLOBAL | TCL_EVAL_DIRECT); 1731 if (returnVal != TCLVFS_POSIXERROR) { 1732 *objPtrRef = Tcl_DuplicateObj(Tcl_GetObjResult(interp)); 1733 } 1734 Tcl_RestoreResult(interp, &savedResult); 1735 Tcl_DecrRefCount(mountCmd); 1736 1737 if (returnVal != TCLVFS_POSIXERROR) { 1738 if (returnVal == TCL_OK) { 1739 /* 1740 * Our caller expects a ref count of zero in 1741 * the returned object pointer. 1742 */ 1743 } else { 1744 /* Leave error message in correct interp */ 1745 if (cmdInterp != NULL) { 1746 Tcl_SetObjResult(cmdInterp, *objPtrRef); 1747 } else { 1748 Tcl_DecrRefCount(*objPtrRef); 1749 } 1750 *objPtrRef = NULL; 1751 } 1752 } else { 1753 if (cmdInterp != NULL) { 1754 Tcl_ResetResult(cmdInterp); 1755 Tcl_AppendResult(cmdInterp, "couldn't read attributes for \"", 1756 Tcl_GetString(pathPtr), "\": ", 1757 Tcl_PosixError(cmdInterp), (char *) NULL); 1758 } 1759 } 1760 1761 return returnVal; 1762} 1763 1764static int 1765VfsFileAttrsSet(cmdInterp, index, pathPtr, objPtr) 1766 Tcl_Interp *cmdInterp; /* The interpreter for error reporting. */ 1767 int index; /* index of the attribute command. */ 1768 Tcl_Obj *pathPtr; /* filename we are operating on. */ 1769 Tcl_Obj *objPtr; /* for input. */ 1770{ 1771 Tcl_Obj *mountCmd = NULL; 1772 Tcl_SavedResult savedResult; 1773 int returnVal; 1774 Tcl_Interp* interp; 1775 Tcl_Obj *errorPtr = NULL; 1776 1777 mountCmd = VfsBuildCommandForPath(&interp, "fileattributes", pathPtr); 1778 if (mountCmd == NULL) { 1779 return TCLVFS_POSIXERROR; 1780 } 1781 1782 Tcl_ListObjAppendElement(interp, mountCmd, Tcl_NewIntObj(index)); 1783 Tcl_ListObjAppendElement(interp, mountCmd, objPtr); 1784 Tcl_SaveResult(interp, &savedResult); 1785 /* Now we execute this mount point's callback. */ 1786 returnVal = Tcl_EvalObjEx(interp, mountCmd, 1787 TCL_EVAL_GLOBAL | TCL_EVAL_DIRECT); 1788 if (returnVal != TCLVFS_POSIXERROR && returnVal != TCL_OK) { 1789 errorPtr = Tcl_DuplicateObj(Tcl_GetObjResult(interp)); 1790 } 1791 1792 Tcl_RestoreResult(interp, &savedResult); 1793 Tcl_DecrRefCount(mountCmd); 1794 1795 if (cmdInterp != NULL) { 1796 if (returnVal == TCLVFS_POSIXERROR) { 1797 Tcl_ResetResult(cmdInterp); 1798 Tcl_AppendResult(cmdInterp, "couldn't set attributes for \"", 1799 Tcl_GetString(pathPtr), "\": ", 1800 Tcl_PosixError(cmdInterp), (char *) NULL); 1801 } else if (errorPtr != NULL) { 1802 /* 1803 * Leave error message in correct interp, errorPtr was 1804 * duplicated above, in case of threading issues. 1805 */ 1806 Tcl_SetObjResult(cmdInterp, errorPtr); 1807 } 1808 } else if (errorPtr != NULL) { 1809 Tcl_DecrRefCount(errorPtr); 1810 } 1811 return returnVal; 1812} 1813 1814static int 1815VfsUtime(pathPtr, tval) 1816 Tcl_Obj* pathPtr; 1817 struct utimbuf *tval; 1818{ 1819 Tcl_Obj *mountCmd = NULL; 1820 Tcl_SavedResult savedResult; 1821 int returnVal; 1822 Tcl_Interp* interp; 1823 1824 mountCmd = VfsBuildCommandForPath(&interp, "utime", pathPtr); 1825 if (mountCmd == NULL) { 1826 return TCLVFS_POSIXERROR; 1827 } 1828 1829 Tcl_ListObjAppendElement(interp, mountCmd, Tcl_NewLongObj(tval->actime)); 1830 Tcl_ListObjAppendElement(interp, mountCmd, Tcl_NewLongObj(tval->modtime)); 1831 /* Now we execute this mount point's callback. */ 1832 Tcl_SaveResult(interp, &savedResult); 1833 returnVal = Tcl_EvalObjEx(interp, mountCmd, 1834 TCL_EVAL_GLOBAL | TCL_EVAL_DIRECT); 1835 if (returnVal != TCL_OK && returnVal != TCLVFS_POSIXERROR) { 1836 VfsInternalError(interp); 1837 } 1838 Tcl_RestoreResult(interp, &savedResult); 1839 Tcl_DecrRefCount(mountCmd); 1840 1841 return returnVal; 1842} 1843 1844static Tcl_Obj* 1845VfsListVolumes(void) 1846{ 1847 Tcl_Obj *retVal; 1848 ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey); 1849 1850 if (tsdPtr->vfsVolumes != NULL) { 1851 Tcl_IncrRefCount(tsdPtr->vfsVolumes); 1852 retVal = tsdPtr->vfsVolumes; 1853 } else { 1854 retVal = NULL; 1855 } 1856 1857 return retVal; 1858} 1859 1860static void 1861Vfs_AddVolume(volume) 1862 Tcl_Obj *volume; 1863{ 1864 ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey); 1865 1866 if (tsdPtr->vfsVolumes == NULL) { 1867 tsdPtr->vfsVolumes = Tcl_NewObj(); 1868 Tcl_IncrRefCount(tsdPtr->vfsVolumes); 1869 } else { 1870#if 0 1871 if (Tcl_IsShared(tsdPtr->vfsVolumes)) { 1872 /* 1873 * Another thread is using this object, so we duplicate the 1874 * object and reduce the refCount on the shared one. 1875 */ 1876 Tcl_Obj *oldVols = tsdPtr->vfsVolumes; 1877 tsdPtr->vfsVolumes = Tcl_DuplicateObj(oldVols); 1878 Tcl_IncrRefCount(tsdPtr->vfsVolumes); 1879 Tcl_DecrRefCount(oldVols); 1880 } 1881#endif 1882 } 1883 Tcl_ListObjAppendElement(NULL, tsdPtr->vfsVolumes, volume); 1884} 1885 1886static int 1887Vfs_RemoveVolume(volume) 1888 Tcl_Obj *volume; 1889{ 1890 int i, len; 1891 ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey); 1892 1893 Tcl_ListObjLength(NULL, tsdPtr->vfsVolumes, &len); 1894 for (i = 0;i < len; i++) { 1895 Tcl_Obj *vol; 1896 Tcl_ListObjIndex(NULL, tsdPtr->vfsVolumes, i, &vol); 1897 if (!strcmp(Tcl_GetString(vol),Tcl_GetString(volume))) { 1898 /* It's in the list, at index i */ 1899 if (len == 1) { 1900 /* An optimization here */ 1901 Tcl_DecrRefCount(tsdPtr->vfsVolumes); 1902 tsdPtr->vfsVolumes = NULL; 1903 } else { 1904 /* 1905 * Make ourselves the unique owner 1906 * XXX: May be unnecessary now that it is tsd 1907 */ 1908 if (Tcl_IsShared(tsdPtr->vfsVolumes)) { 1909 Tcl_Obj *oldVols = tsdPtr->vfsVolumes; 1910 tsdPtr->vfsVolumes = Tcl_DuplicateObj(oldVols); 1911 Tcl_IncrRefCount(tsdPtr->vfsVolumes); 1912 Tcl_DecrRefCount(oldVols); 1913 } 1914 /* Remove the element */ 1915 Tcl_ListObjReplace(NULL, tsdPtr->vfsVolumes, i, 1, 0, NULL); 1916 return TCL_OK; 1917 } 1918 } 1919 } 1920 1921 return TCL_ERROR; 1922} 1923 1924 1925/* 1926 *---------------------------------------------------------------------- 1927 * 1928 * VfsBuildCommandForPath -- 1929 * 1930 * Given a path object which we know belongs to the vfs, and a 1931 * command string (one of the standard filesystem operations 1932 * "stat", "matchindirectory" etc), build the standard vfs 1933 * Tcl command and arguments to carry out that operation. 1934 * 1935 * If the command is successfully built, it is returned to the 1936 * caller with a refCount of 1. The caller also needs to know 1937 * which Tcl interpreter to evaluate the command in; this 1938 * is returned in the 'iRef' provided. 1939 * 1940 * Each mount-point dictates a command prefix to use for a 1941 * particular file. We start with that and then add 4 parameters, 1942 * as follows: 1943 * 1944 * (1) the 'cmd' to use 1945 * (2) the mount point of this path (which is the portion of the 1946 * path string which lies outside the vfs). 1947 * (3) the remainder of the path which lies inside the vfs 1948 * (4) the original (possibly unnormalized) path string used 1949 * in the command. 1950 * 1951 * Example (i): 1952 * 1953 * If 'C:/Apps/data.zip' is mounted on top of 1954 * itself, then if we do: 1955 * 1956 * cd C:/Apps 1957 * file exists data.zip/foo/bar.txt 1958 * 1959 * this will lead to: 1960 * 1961 * <mountcmd> "access" C:/Apps/data.zip foo/bar.txt data.zip/foo/bar.txt 1962 * 1963 * Example (ii) 1964 * 1965 * If 'ftp://' is mounted as a new volume, 1966 * then 'glob -dir ftp://ftp.scriptics.com *' will lead to: 1967 * 1968 * <mountcmd> "matchindirectory" ftp:// ftp.scriptics.com \ 1969 * ftp://ftp.scriptics.com 1970 * 1971 * 1972 * Results: 1973 * Returns a list containing the command, or NULL if an 1974 * error occurred. If the interpreter for this vfs command 1975 * is in the process of being deleted, we always return NULL. 1976 * 1977 * Side effects: 1978 * None except memory allocation. 1979 * 1980 *---------------------------------------------------------------------- 1981 */ 1982 1983static Tcl_Obj* 1984VfsBuildCommandForPath(Tcl_Interp **iRef, CONST char* cmd, Tcl_Obj *pathPtr) { 1985 Tcl_Obj *normed; 1986 Tcl_Obj *mountCmd; 1987 int len; 1988 int splitPosition; 1989 int dummyLen; 1990 VfsNativeRep *nativeRep; 1991 Tcl_Interp *interp; 1992 1993 char *normedString; 1994 1995 nativeRep = VfsGetNativePath(pathPtr); 1996 if (nativeRep == NULL) { 1997 return NULL; 1998 } 1999 2000 interp = nativeRep->fsCmd->interp; 2001 2002 if (Tcl_InterpDeleted(interp)) { 2003 return NULL; 2004 } 2005 2006 splitPosition = nativeRep->splitPosition; 2007 normed = Tcl_FSGetNormalizedPath(NULL, pathPtr); 2008 normedString = Tcl_GetStringFromObj(normed, &len); 2009 2010 mountCmd = Tcl_DuplicateObj(nativeRep->fsCmd->mountCmd); 2011 Tcl_IncrRefCount(mountCmd); 2012 if (Tcl_ListObjLength(NULL, mountCmd, &dummyLen) == TCL_ERROR) { 2013 Tcl_DecrRefCount(mountCmd); 2014 return NULL; 2015 } 2016 Tcl_ListObjAppendElement(NULL, mountCmd, Tcl_NewStringObj(cmd,-1)); 2017 if (splitPosition == len) { 2018 Tcl_ListObjAppendElement(NULL, mountCmd, normed); 2019 Tcl_ListObjAppendElement(NULL, mountCmd, Tcl_NewStringObj("",0)); 2020 } else { 2021 Tcl_ListObjAppendElement(NULL, mountCmd, 2022 Tcl_NewStringObj(normedString,splitPosition)); 2023 if ((normedString[splitPosition] != VFS_SEPARATOR) 2024 || (VFS_SEPARATOR ==':')) { 2025 /* This will occur if we mount 'ftp://' */ 2026 splitPosition--; 2027 } 2028 Tcl_ListObjAppendElement(NULL, mountCmd, 2029 Tcl_NewStringObj(normedString+splitPosition+1, 2030 len-splitPosition-1)); 2031 } 2032 Tcl_ListObjAppendElement(NULL, mountCmd, pathPtr); 2033 2034 if (iRef != NULL) { 2035 *iRef = interp; 2036 } 2037 2038 return mountCmd; 2039} 2040 2041static void 2042VfsExitProc(ClientData clientData) 2043{ 2044 Tcl_FSUnregister(&vfsFilesystem); 2045} 2046 2047static void 2048VfsThreadExitProc(ClientData clientData) 2049{ 2050 ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey); 2051 /* 2052 * This is probably no longer needed, because each individual 2053 * interp's cleanup will trigger removal of all volumes which 2054 * belong to it. 2055 */ 2056 if (tsdPtr->vfsVolumes != NULL) { 2057 Tcl_DecrRefCount(tsdPtr->vfsVolumes); 2058 tsdPtr->vfsVolumes = NULL; 2059 } 2060 if (tsdPtr->internalErrorScript != NULL) { 2061 Tcl_DecrRefCount(tsdPtr->internalErrorScript); 2062 tsdPtr->internalErrorScript = NULL; 2063 } 2064} 2065