os/persistentdata/persistentstorage/sqlite3api/TEST/TCL/tcldistribution/generic/tclIOUtil.c
1.1 --- /dev/null Thu Jan 01 00:00:00 1970 +0000
1.2 +++ b/os/persistentdata/persistentstorage/sqlite3api/TEST/TCL/tcldistribution/generic/tclIOUtil.c Fri Jun 15 03:10:57 2012 +0200
1.3 @@ -0,0 +1,6515 @@
1.4 +/*
1.5 + * tclIOUtil.c --
1.6 + *
1.7 + * This file contains the implementation of Tcl's generic
1.8 + * filesystem code, which supports a pluggable filesystem
1.9 + * architecture allowing both platform specific filesystems and
1.10 + * 'virtual filesystems'. All filesystem access should go through
1.11 + * the functions defined in this file. Most of this code was
1.12 + * contributed by Vince Darley.
1.13 + *
1.14 + * Parts of this file are based on code contributed by Karl
1.15 + * Lehenbauer, Mark Diekhans and Peter da Silva.
1.16 + *
1.17 + * Copyright (c) 1991-1994 The Regents of the University of California.
1.18 + * Copyright (c) 1994-1997 Sun Microsystems, Inc.
1.19 + * Portions Copyright (c) 2007-2008 Nokia Corporation and/or its subsidiaries. All rights reserved.
1.20 + *
1.21 + * See the file "license.terms" for information on usage and redistribution
1.22 + * of this file, and for a DISCLAIMER OF ALL WARRANTIES.
1.23 + *
1.24 + * RCS: @(#) $Id: tclIOUtil.c,v 1.77.2.34 2007/02/19 23:49:05 hobbs Exp $
1.25 + */
1.26 +
1.27 +#include "tclInt.h"
1.28 +#include "tclPort.h"
1.29 +#ifdef MAC_TCL
1.30 +#include "tclMacInt.h"
1.31 +#endif
1.32 +#ifdef __WIN32__
1.33 +/* for tclWinProcs->useWide */
1.34 +#include "tclWinInt.h"
1.35 +#endif
1.36 +#if defined(__SYMBIAN32__) && defined(__WINSCW__)
1.37 +#include "tclSymbianGlobals.h"
1.38 +#define dataKey getdataKey(4)
1.39 +#endif
1.40 +
1.41 +/*
1.42 + * struct FilesystemRecord --
1.43 + *
1.44 + * A filesystem record is used to keep track of each
1.45 + * filesystem currently registered with the core,
1.46 + * in a linked list. Pointers to these structures
1.47 + * are also kept by each "path" Tcl_Obj, and we must
1.48 + * retain a refCount on the number of such references.
1.49 + */
1.50 +typedef struct FilesystemRecord {
1.51 + ClientData clientData; /* Client specific data for the new
1.52 + * filesystem (can be NULL) */
1.53 + Tcl_Filesystem *fsPtr; /* Pointer to filesystem dispatch
1.54 + * table. */
1.55 + int fileRefCount; /* How many Tcl_Obj's use this
1.56 + * filesystem. */
1.57 + struct FilesystemRecord *nextPtr;
1.58 + /* The next filesystem registered
1.59 + * to Tcl, or NULL if no more. */
1.60 + struct FilesystemRecord *prevPtr;
1.61 + /* The previous filesystem registered
1.62 + * to Tcl, or NULL if no more. */
1.63 +} FilesystemRecord;
1.64 +
1.65 +/*
1.66 + * The internal TclFS API provides routines for handling and
1.67 + * manipulating paths efficiently, taking direct advantage of
1.68 + * the "path" Tcl_Obj type.
1.69 + *
1.70 + * These functions are not exported at all at present.
1.71 + */
1.72 +
1.73 +int TclFSCwdPointerEquals _ANSI_ARGS_((Tcl_Obj* objPtr));
1.74 +int TclFSMakePathFromNormalized _ANSI_ARGS_((Tcl_Interp *interp,
1.75 + Tcl_Obj *objPtr, ClientData clientData));
1.76 +int TclFSNormalizeToUniquePath _ANSI_ARGS_((Tcl_Interp *interp,
1.77 + Tcl_Obj *pathPtr, int startAt, ClientData *clientDataPtr));
1.78 +Tcl_Obj* TclFSMakePathRelative _ANSI_ARGS_((Tcl_Interp *interp,
1.79 + Tcl_Obj *objPtr, Tcl_Obj *cwdPtr));
1.80 +Tcl_Obj* TclFSInternalToNormalized _ANSI_ARGS_((
1.81 + Tcl_Filesystem *fromFilesystem, ClientData clientData,
1.82 + FilesystemRecord **fsRecPtrPtr));
1.83 +int TclFSEnsureEpochOk _ANSI_ARGS_((Tcl_Obj* pathObjPtr,
1.84 + Tcl_Filesystem **fsPtrPtr));
1.85 +void TclFSSetPathDetails _ANSI_ARGS_((Tcl_Obj *pathObjPtr,
1.86 + FilesystemRecord *fsRecPtr, ClientData clientData));
1.87 +
1.88 +/*
1.89 + * Private variables for use in this file
1.90 + */
1.91 +extern Tcl_Filesystem tclNativeFilesystem;
1.92 +extern int theFilesystemEpoch;
1.93 +
1.94 +/*
1.95 + * Private functions for use in this file
1.96 + */
1.97 +static Tcl_PathType FSGetPathType _ANSI_ARGS_((Tcl_Obj *pathObjPtr,
1.98 + Tcl_Filesystem **filesystemPtrPtr,
1.99 + int *driveNameLengthPtr));
1.100 +static Tcl_PathType GetPathType _ANSI_ARGS_((Tcl_Obj *pathObjPtr,
1.101 + Tcl_Filesystem **filesystemPtrPtr,
1.102 + int *driveNameLengthPtr, Tcl_Obj **driveNameRef));
1.103 +static Tcl_FSPathInFilesystemProc NativePathInFilesystem;
1.104 +static Tcl_Obj* TclFSNormalizeAbsolutePath
1.105 + _ANSI_ARGS_((Tcl_Interp* interp, Tcl_Obj *pathPtr,
1.106 + ClientData *clientDataPtr));
1.107 +/*
1.108 + * Prototypes for procedures defined later in this file.
1.109 + */
1.110 +
1.111 +static FilesystemRecord* FsGetFirstFilesystem(void);
1.112 +static void FsThrExitProc(ClientData cd);
1.113 +static Tcl_Obj* FsListMounts _ANSI_ARGS_((Tcl_Obj *pathPtr,
1.114 + CONST char *pattern));
1.115 +static Tcl_Obj* FsAddMountsToGlobResult _ANSI_ARGS_((Tcl_Obj *result,
1.116 + Tcl_Obj *pathPtr, CONST char *pattern, Tcl_GlobTypeData *types));
1.117 +
1.118 +#ifdef TCL_THREADS
1.119 +static void FsRecacheFilesystemList(void);
1.120 +#endif
1.121 +
1.122 +/*
1.123 + * These form part of the native filesystem support. They are needed
1.124 + * here because we have a few native filesystem functions (which are
1.125 + * the same for mac/win/unix) in this file. There is no need to place
1.126 + * them in tclInt.h, because they are not (and should not be) used
1.127 + * anywhere else.
1.128 + */
1.129 +extern CONST char * tclpFileAttrStrings[];
1.130 +extern CONST TclFileAttrProcs tclpFileAttrProcs[];
1.131 +
1.132 +/*
1.133 + * The following functions are obsolete string based APIs, and should
1.134 + * be removed in a future release (Tcl 9 would be a good time).
1.135 + */
1.136 +
1.137 +/* Obsolete */
1.138 +EXPORT_C int
1.139 +Tcl_Stat(path, oldStyleBuf)
1.140 + CONST char *path; /* Path of file to stat (in current CP). */
1.141 + struct stat *oldStyleBuf; /* Filled with results of stat call. */
1.142 +{
1.143 + int ret;
1.144 + Tcl_StatBuf buf;
1.145 + Tcl_Obj *pathPtr = Tcl_NewStringObj(path,-1);
1.146 +
1.147 + Tcl_IncrRefCount(pathPtr);
1.148 + ret = Tcl_FSStat(pathPtr, &buf);
1.149 + Tcl_DecrRefCount(pathPtr);
1.150 + if (ret != -1) {
1.151 +#ifndef TCL_WIDE_INT_IS_LONG
1.152 +# define OUT_OF_RANGE(x) \
1.153 + (((Tcl_WideInt)(x)) < Tcl_LongAsWide(LONG_MIN) || \
1.154 + ((Tcl_WideInt)(x)) > Tcl_LongAsWide(LONG_MAX))
1.155 +#if defined(__GNUC__) && __GNUC__ >= 2
1.156 +/*
1.157 + * Workaround gcc warning of "comparison is always false due to limited range of
1.158 + * data type" in this macro by checking max type size, and when necessary ANDing
1.159 + * with the complement of ULONG_MAX instead of the comparison:
1.160 + */
1.161 +# define OUT_OF_URANGE(x) \
1.162 + ((((Tcl_WideUInt)(~ (__typeof__(x)) 0)) > (Tcl_WideUInt)ULONG_MAX) && \
1.163 + (((Tcl_WideUInt)(x)) & ~(Tcl_WideUInt)ULONG_MAX))
1.164 +#else
1.165 +# define OUT_OF_URANGE(x) \
1.166 + (((Tcl_WideUInt)(x)) > (Tcl_WideUInt)ULONG_MAX)
1.167 +#endif
1.168 +
1.169 + /*
1.170 + * Perform the result-buffer overflow check manually.
1.171 + *
1.172 + * Note that ino_t/ino64_t is unsigned...
1.173 + */
1.174 +
1.175 + if (OUT_OF_URANGE(buf.st_ino) || OUT_OF_RANGE(buf.st_size)
1.176 +#ifdef HAVE_ST_BLOCKS
1.177 + || OUT_OF_RANGE(buf.st_blocks)
1.178 +#endif
1.179 + ) {
1.180 +#ifdef EFBIG
1.181 + errno = EFBIG;
1.182 +#else
1.183 +# ifdef EOVERFLOW
1.184 + errno = EOVERFLOW;
1.185 +# else
1.186 +# error "What status should be returned for file size out of range?"
1.187 +# endif
1.188 +#endif
1.189 + return -1;
1.190 + }
1.191 +
1.192 +# undef OUT_OF_RANGE
1.193 +# undef OUT_OF_URANGE
1.194 +#endif /* !TCL_WIDE_INT_IS_LONG */
1.195 +
1.196 + /*
1.197 + * Copy across all supported fields, with possible type
1.198 + * coercions on those fields that change between the normal
1.199 + * and lf64 versions of the stat structure (on Solaris at
1.200 + * least.) This is slow when the structure sizes coincide,
1.201 + * but that's what you get for using an obsolete interface.
1.202 + */
1.203 +
1.204 + oldStyleBuf->st_mode = buf.st_mode;
1.205 + oldStyleBuf->st_ino = (ino_t) buf.st_ino;
1.206 + oldStyleBuf->st_dev = buf.st_dev;
1.207 + oldStyleBuf->st_rdev = buf.st_rdev;
1.208 + oldStyleBuf->st_nlink = buf.st_nlink;
1.209 + oldStyleBuf->st_uid = buf.st_uid;
1.210 + oldStyleBuf->st_gid = buf.st_gid;
1.211 + oldStyleBuf->st_size = (off_t) buf.st_size;
1.212 + oldStyleBuf->st_atime = buf.st_atime;
1.213 + oldStyleBuf->st_mtime = buf.st_mtime;
1.214 + oldStyleBuf->st_ctime = buf.st_ctime;
1.215 +#ifdef HAVE_ST_BLOCKS
1.216 + oldStyleBuf->st_blksize = buf.st_blksize;
1.217 + oldStyleBuf->st_blocks = (blkcnt_t) buf.st_blocks;
1.218 +#endif
1.219 + }
1.220 + return ret;
1.221 +}
1.222 +
1.223 +/* Obsolete */
1.224 +EXPORT_C int
1.225 +Tcl_Access(path, mode)
1.226 + CONST char *path; /* Path of file to access (in current CP). */
1.227 + int mode; /* Permission setting. */
1.228 +{
1.229 + int ret;
1.230 + Tcl_Obj *pathPtr = Tcl_NewStringObj(path,-1);
1.231 + Tcl_IncrRefCount(pathPtr);
1.232 + ret = Tcl_FSAccess(pathPtr,mode);
1.233 + Tcl_DecrRefCount(pathPtr);
1.234 + return ret;
1.235 +}
1.236 +
1.237 +/* Obsolete */
1.238 +EXPORT_C Tcl_Channel
1.239 +Tcl_OpenFileChannel(interp, path, modeString, permissions)
1.240 + Tcl_Interp *interp; /* Interpreter for error reporting;
1.241 + * can be NULL. */
1.242 + CONST char *path; /* Name of file to open. */
1.243 + CONST char *modeString; /* A list of POSIX open modes or
1.244 + * a string such as "rw". */
1.245 + int permissions; /* If the open involves creating a
1.246 + * file, with what modes to create
1.247 + * it? */
1.248 +{
1.249 + Tcl_Channel ret;
1.250 + Tcl_Obj *pathPtr = Tcl_NewStringObj(path,-1);
1.251 + Tcl_IncrRefCount(pathPtr);
1.252 + ret = Tcl_FSOpenFileChannel(interp, pathPtr, modeString, permissions);
1.253 + Tcl_DecrRefCount(pathPtr);
1.254 + return ret;
1.255 +
1.256 +}
1.257 +
1.258 +/* Obsolete */
1.259 +EXPORT_C int
1.260 +Tcl_Chdir(dirName)
1.261 + CONST char *dirName;
1.262 +{
1.263 + int ret;
1.264 + Tcl_Obj *pathPtr = Tcl_NewStringObj(dirName,-1);
1.265 + Tcl_IncrRefCount(pathPtr);
1.266 + ret = Tcl_FSChdir(pathPtr);
1.267 + Tcl_DecrRefCount(pathPtr);
1.268 + return ret;
1.269 +}
1.270 +
1.271 +/* Obsolete */
1.272 +EXPORT_C char *
1.273 +Tcl_GetCwd(interp, cwdPtr)
1.274 + Tcl_Interp *interp;
1.275 + Tcl_DString *cwdPtr;
1.276 +{
1.277 + Tcl_Obj *cwd;
1.278 + cwd = Tcl_FSGetCwd(interp);
1.279 + if (cwd == NULL) {
1.280 + return NULL;
1.281 + } else {
1.282 + Tcl_DStringInit(cwdPtr);
1.283 + Tcl_DStringAppend(cwdPtr, Tcl_GetString(cwd), -1);
1.284 + Tcl_DecrRefCount(cwd);
1.285 + return Tcl_DStringValue(cwdPtr);
1.286 + }
1.287 +}
1.288 +
1.289 +/* Obsolete */
1.290 +EXPORT_C int
1.291 +Tcl_EvalFile(interp, fileName)
1.292 + Tcl_Interp *interp; /* Interpreter in which to process file. */
1.293 + CONST char *fileName; /* Name of file to process. Tilde-substitution
1.294 + * will be performed on this name. */
1.295 +{
1.296 + int ret;
1.297 + Tcl_Obj *pathPtr = Tcl_NewStringObj(fileName,-1);
1.298 + Tcl_IncrRefCount(pathPtr);
1.299 + ret = Tcl_FSEvalFile(interp, pathPtr);
1.300 + Tcl_DecrRefCount(pathPtr);
1.301 + return ret;
1.302 +}
1.303 +
1.304 +
1.305 +/*
1.306 + * The 3 hooks for Stat, Access and OpenFileChannel are obsolete. The
1.307 + * complete, general hooked filesystem APIs should be used instead.
1.308 + * This define decides whether to include the obsolete hooks and
1.309 + * related code. If these are removed, we'll also want to remove them
1.310 + * from stubs/tclInt. The only known users of these APIs are prowrap
1.311 + * and mktclapp. New code/extensions should not use them, since they
1.312 + * do not provide as full support as the full filesystem API.
1.313 + *
1.314 + * As soon as prowrap and mktclapp are updated to use the full
1.315 + * filesystem support, I suggest all these hooks are removed.
1.316 + */
1.317 +#define USE_OBSOLETE_FS_HOOKS
1.318 +
1.319 +
1.320 +#ifdef USE_OBSOLETE_FS_HOOKS
1.321 +/*
1.322 + * The following typedef declarations allow for hooking into the chain
1.323 + * of functions maintained for 'Tcl_Stat(...)', 'Tcl_Access(...)' &
1.324 + * 'Tcl_OpenFileChannel(...)'. Basically for each hookable function
1.325 + * a linked list is defined.
1.326 + */
1.327 +
1.328 +typedef struct StatProc {
1.329 + TclStatProc_ *proc; /* Function to process a 'stat()' call */
1.330 + struct StatProc *nextPtr; /* The next 'stat()' function to call */
1.331 +} StatProc;
1.332 +
1.333 +typedef struct AccessProc {
1.334 + TclAccessProc_ *proc; /* Function to process a 'access()' call */
1.335 + struct AccessProc *nextPtr; /* The next 'access()' function to call */
1.336 +} AccessProc;
1.337 +
1.338 +typedef struct OpenFileChannelProc {
1.339 + TclOpenFileChannelProc_ *proc; /* Function to process a
1.340 + * 'Tcl_OpenFileChannel()' call */
1.341 + struct OpenFileChannelProc *nextPtr;
1.342 + /* The next 'Tcl_OpenFileChannel()'
1.343 + * function to call */
1.344 +} OpenFileChannelProc;
1.345 +
1.346 +/*
1.347 + * For each type of (obsolete) hookable function, a static node is
1.348 + * declared to hold the function pointer for the "built-in" routine
1.349 + * (e.g. 'TclpStat(...)') and the respective list is initialized as a
1.350 + * pointer to that node.
1.351 + *
1.352 + * The "delete" functions (e.g. 'TclStatDeleteProc(...)') ensure that
1.353 + * these statically declared list entry cannot be inadvertently removed.
1.354 + *
1.355 + * This method avoids the need to call any sort of "initialization"
1.356 + * function.
1.357 + *
1.358 + * All three lists are protected by a global obsoleteFsHookMutex.
1.359 + */
1.360 +
1.361 +static StatProc *statProcList = NULL;
1.362 +static AccessProc *accessProcList = NULL;
1.363 +static OpenFileChannelProc *openFileChannelProcList = NULL;
1.364 +
1.365 +TCL_DECLARE_MUTEX(obsoleteFsHookMutex)
1.366 +
1.367 +#endif /* USE_OBSOLETE_FS_HOOKS */
1.368 +
1.369 +/*
1.370 + * Declare the native filesystem support. These functions should
1.371 + * be considered private to Tcl, and should really not be called
1.372 + * directly by any code other than this file (i.e. neither by
1.373 + * Tcl's core nor by extensions). Similarly, the old string-based
1.374 + * Tclp... native filesystem functions should not be called.
1.375 + *
1.376 + * The correct API to use now is the Tcl_FS... set of functions,
1.377 + * which ensure correct and complete virtual filesystem support.
1.378 + *
1.379 + * We cannot make all of these static, since some of them
1.380 + * are implemented in the platform-specific directories.
1.381 + */
1.382 +static Tcl_FSFilesystemSeparatorProc NativeFilesystemSeparator;
1.383 +static Tcl_FSFreeInternalRepProc NativeFreeInternalRep;
1.384 +static Tcl_FSCreateInternalRepProc NativeCreateNativeRep;
1.385 +static Tcl_FSFileAttrStringsProc NativeFileAttrStrings;
1.386 +static Tcl_FSFileAttrsGetProc NativeFileAttrsGet;
1.387 +static Tcl_FSFileAttrsSetProc NativeFileAttrsSet;
1.388 +
1.389 +/*
1.390 + * The only reason these functions are not static is that they
1.391 + * are either called by code in the native (win/unix/mac) directories
1.392 + * or they are actually implemented in those directories. They
1.393 + * should simply not be called by code outside Tcl's native
1.394 + * filesystem core. i.e. they should be considered 'static' to
1.395 + * Tcl's filesystem code (if we ever built the native filesystem
1.396 + * support into a separate code library, this could actually be
1.397 + * enforced).
1.398 + */
1.399 +Tcl_FSFilesystemPathTypeProc TclpFilesystemPathType;
1.400 +Tcl_FSInternalToNormalizedProc TclpNativeToNormalized;
1.401 +Tcl_FSStatProc TclpObjStat;
1.402 +Tcl_FSAccessProc TclpObjAccess;
1.403 +Tcl_FSMatchInDirectoryProc TclpMatchInDirectory;
1.404 +Tcl_FSGetCwdProc TclpObjGetCwd;
1.405 +Tcl_FSChdirProc TclpObjChdir;
1.406 +Tcl_FSLstatProc TclpObjLstat;
1.407 +Tcl_FSCopyFileProc TclpObjCopyFile;
1.408 +Tcl_FSDeleteFileProc TclpObjDeleteFile;
1.409 +Tcl_FSRenameFileProc TclpObjRenameFile;
1.410 +Tcl_FSCreateDirectoryProc TclpObjCreateDirectory;
1.411 +Tcl_FSCopyDirectoryProc TclpObjCopyDirectory;
1.412 +Tcl_FSRemoveDirectoryProc TclpObjRemoveDirectory;
1.413 +Tcl_FSUnloadFileProc TclpUnloadFile;
1.414 +Tcl_FSLinkProc TclpObjLink;
1.415 +Tcl_FSListVolumesProc TclpObjListVolumes;
1.416 +
1.417 +/*
1.418 + * Define the native filesystem dispatch table. If necessary, it
1.419 + * is ok to make this non-static, but it should only be accessed
1.420 + * by the functions actually listed within it (or perhaps other
1.421 + * helper functions of them). Anything which is not part of this
1.422 + * 'native filesystem implementation' should not be delving inside
1.423 + * here!
1.424 + */
1.425 +Tcl_Filesystem tclNativeFilesystem = {
1.426 + "native",
1.427 + sizeof(Tcl_Filesystem),
1.428 + TCL_FILESYSTEM_VERSION_1,
1.429 + &NativePathInFilesystem,
1.430 + &TclNativeDupInternalRep,
1.431 + &NativeFreeInternalRep,
1.432 + &TclpNativeToNormalized,
1.433 + &NativeCreateNativeRep,
1.434 + &TclpObjNormalizePath,
1.435 + &TclpFilesystemPathType,
1.436 + &NativeFilesystemSeparator,
1.437 + &TclpObjStat,
1.438 + &TclpObjAccess,
1.439 + &TclpOpenFileChannel,
1.440 + &TclpMatchInDirectory,
1.441 + &TclpUtime,
1.442 +#ifndef S_IFLNK
1.443 + NULL,
1.444 +#else
1.445 + &TclpObjLink,
1.446 +#endif /* S_IFLNK */
1.447 + &TclpObjListVolumes,
1.448 + &NativeFileAttrStrings,
1.449 + &NativeFileAttrsGet,
1.450 + &NativeFileAttrsSet,
1.451 + &TclpObjCreateDirectory,
1.452 + &TclpObjRemoveDirectory,
1.453 + &TclpObjDeleteFile,
1.454 + &TclpObjCopyFile,
1.455 + &TclpObjRenameFile,
1.456 + &TclpObjCopyDirectory,
1.457 + &TclpObjLstat,
1.458 + &TclpDlopen,
1.459 + &TclpObjGetCwd,
1.460 + &TclpObjChdir
1.461 +};
1.462 +
1.463 +/*
1.464 + * Define the tail of the linked list. Note that for unconventional
1.465 + * uses of Tcl without a native filesystem, we may in the future wish
1.466 + * to modify the current approach of hard-coding the native filesystem
1.467 + * in the lookup list 'filesystemList' below.
1.468 + *
1.469 + * We initialize the record so that it thinks one file uses it. This
1.470 + * means it will never be freed.
1.471 + */
1.472 +static FilesystemRecord nativeFilesystemRecord = {
1.473 + NULL,
1.474 + &tclNativeFilesystem,
1.475 + 1,
1.476 + NULL
1.477 +};
1.478 +
1.479 +/*
1.480 + * This is incremented each time we modify the linked list of
1.481 + * filesystems. Any time it changes, all cached filesystem
1.482 + * representations are suspect and must be freed.
1.483 + * For multithreading builds, change of the filesystem epoch
1.484 + * will trigger cache cleanup in all threads.
1.485 + */
1.486 +int theFilesystemEpoch = 0;
1.487 +
1.488 +/*
1.489 + * Stores the linked list of filesystems. A 1:1 copy of this
1.490 + * list is also maintained in the TSD for each thread. This
1.491 + * is to avoid synchronization issues.
1.492 + */
1.493 +static FilesystemRecord *filesystemList = &nativeFilesystemRecord;
1.494 +
1.495 +TCL_DECLARE_MUTEX(filesystemMutex)
1.496 +
1.497 +#if !defined(__SYMBIAN32__) || !defined(__WINSCW__)
1.498 +/*
1.499 + * Used to implement Tcl_FSGetCwd in a file-system independent way.
1.500 + */
1.501 +static Tcl_Obj* cwdPathPtr = NULL;
1.502 +static int cwdPathEpoch = 0;
1.503 +#endif
1.504 +TCL_DECLARE_MUTEX(cwdMutex)
1.505 +
1.506 +/*
1.507 + * This structure holds per-thread private copies of
1.508 + * some global data. This way we avoid most of the
1.509 + * synchronization calls which boosts performance, at
1.510 + * cost of having to update this information each
1.511 + * time the corresponding epoch counter changes.
1.512 + *
1.513 + */
1.514 +typedef struct ThreadSpecificData {
1.515 + int initialized;
1.516 + int cwdPathEpoch;
1.517 + int filesystemEpoch;
1.518 + Tcl_Obj *cwdPathPtr;
1.519 + FilesystemRecord *filesystemList;
1.520 +} ThreadSpecificData;
1.521 +
1.522 +#if !defined(__SYMBIAN32__) || !defined(__WINSCW__)
1.523 +static Tcl_ThreadDataKey dataKey;
1.524 +#endif
1.525 +
1.526 +/*
1.527 + * Declare fallback support function and
1.528 + * information for Tcl_FSLoadFile
1.529 + */
1.530 +static Tcl_FSUnloadFileProc FSUnloadTempFile;
1.531 +
1.532 +/*
1.533 + * One of these structures is used each time we successfully load a
1.534 + * file from a file system by way of making a temporary copy of the
1.535 + * file on the native filesystem. We need to store both the actual
1.536 + * unloadProc/clientData combination which was used, and the original
1.537 + * and modified filenames, so that we can correctly undo the entire
1.538 + * operation when we want to unload the code.
1.539 + */
1.540 +typedef struct FsDivertLoad {
1.541 + Tcl_LoadHandle loadHandle;
1.542 + Tcl_FSUnloadFileProc *unloadProcPtr;
1.543 + Tcl_Obj *divertedFile;
1.544 + Tcl_Filesystem *divertedFilesystem;
1.545 + ClientData divertedFileNativeRep;
1.546 +} FsDivertLoad;
1.547 +
1.548 +/* Now move on to the basic filesystem implementation */
1.549 +
1.550 +static void
1.551 +FsThrExitProc(cd)
1.552 + ClientData cd;
1.553 +{
1.554 + ThreadSpecificData *tsdPtr = (ThreadSpecificData*)cd;
1.555 + FilesystemRecord *fsRecPtr = NULL, *tmpFsRecPtr = NULL;
1.556 +
1.557 + /* Trash the cwd copy */
1.558 + if (tsdPtr->cwdPathPtr != NULL) {
1.559 + Tcl_DecrRefCount(tsdPtr->cwdPathPtr);
1.560 + tsdPtr->cwdPathPtr = NULL;
1.561 + }
1.562 + /* Trash the filesystems cache */
1.563 + fsRecPtr = tsdPtr->filesystemList;
1.564 + while (fsRecPtr != NULL) {
1.565 + tmpFsRecPtr = fsRecPtr->nextPtr;
1.566 + if (--fsRecPtr->fileRefCount <= 0) {
1.567 + ckfree((char *)fsRecPtr);
1.568 + }
1.569 + fsRecPtr = tmpFsRecPtr;
1.570 + }
1.571 + tsdPtr->initialized = 0;
1.572 +}
1.573 +
1.574 +int
1.575 +TclFSCwdPointerEquals(objPtr)
1.576 + Tcl_Obj* objPtr;
1.577 +{
1.578 + ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);
1.579 +
1.580 + Tcl_MutexLock(&cwdMutex);
1.581 +#if !defined(__SYMBIAN32__) || !defined(__WINSCW__)
1.582 + if (tsdPtr->cwdPathPtr == NULL) {
1.583 + if (cwdPathPtr == NULL) {
1.584 + tsdPtr->cwdPathPtr = NULL;
1.585 + } else {
1.586 + tsdPtr->cwdPathPtr = Tcl_DuplicateObj(cwdPathPtr);
1.587 + Tcl_IncrRefCount(tsdPtr->cwdPathPtr);
1.588 + }
1.589 + tsdPtr->cwdPathEpoch = cwdPathEpoch;
1.590 + } else if (tsdPtr->cwdPathEpoch != cwdPathEpoch) {
1.591 + Tcl_DecrRefCount(tsdPtr->cwdPathPtr);
1.592 + if (cwdPathPtr == NULL) {
1.593 + tsdPtr->cwdPathPtr = NULL;
1.594 + } else {
1.595 + tsdPtr->cwdPathPtr = Tcl_DuplicateObj(cwdPathPtr);
1.596 + Tcl_IncrRefCount(tsdPtr->cwdPathPtr);
1.597 + }
1.598 + }
1.599 +#else
1.600 + if (tsdPtr->cwdPathPtr == NULL) {
1.601 + if (glcwdPathPtr == NULL) {
1.602 + tsdPtr->cwdPathPtr = NULL;
1.603 + } else {
1.604 + tsdPtr->cwdPathPtr = Tcl_DuplicateObj(glcwdPathPtr);
1.605 + Tcl_IncrRefCount(tsdPtr->cwdPathPtr);
1.606 + }
1.607 + tsdPtr->cwdPathEpoch = glcwdPathEpoch;
1.608 + } else if (tsdPtr->cwdPathEpoch != glcwdPathEpoch) {
1.609 + Tcl_DecrRefCount(tsdPtr->cwdPathPtr);
1.610 + if (glcwdPathPtr == NULL) {
1.611 + tsdPtr->cwdPathPtr = NULL;
1.612 + } else {
1.613 + tsdPtr->cwdPathPtr = Tcl_DuplicateObj(glcwdPathPtr);
1.614 + Tcl_IncrRefCount(tsdPtr->cwdPathPtr);
1.615 + }
1.616 + }
1.617 +#endif
1.618 + Tcl_MutexUnlock(&cwdMutex);
1.619 +
1.620 + if (tsdPtr->initialized == 0) {
1.621 + Tcl_CreateThreadExitHandler(FsThrExitProc, (ClientData)tsdPtr);
1.622 + tsdPtr->initialized = 1;
1.623 + }
1.624 + return (tsdPtr->cwdPathPtr == objPtr);
1.625 +}
1.626 +#ifdef TCL_THREADS
1.627 +
1.628 +static void
1.629 +FsRecacheFilesystemList(void)
1.630 +{
1.631 + ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);
1.632 + FilesystemRecord *fsRecPtr, *tmpFsRecPtr = NULL;
1.633 +
1.634 + /* Trash the current cache */
1.635 + fsRecPtr = tsdPtr->filesystemList;
1.636 + while (fsRecPtr != NULL) {
1.637 + tmpFsRecPtr = fsRecPtr->nextPtr;
1.638 + if (--fsRecPtr->fileRefCount <= 0) {
1.639 + ckfree((char *)fsRecPtr);
1.640 + }
1.641 + fsRecPtr = tmpFsRecPtr;
1.642 + }
1.643 + tsdPtr->filesystemList = NULL;
1.644 +
1.645 + /*
1.646 + * Code below operates on shared data. We
1.647 + * are already called under mutex lock so
1.648 + * we can safely proceed.
1.649 + */
1.650 +
1.651 + /* Locate tail of the global filesystem list */
1.652 + fsRecPtr = filesystemList;
1.653 + while (fsRecPtr != NULL) {
1.654 + tmpFsRecPtr = fsRecPtr;
1.655 + fsRecPtr = fsRecPtr->nextPtr;
1.656 + }
1.657 +
1.658 + /* Refill the cache honouring the order */
1.659 + fsRecPtr = tmpFsRecPtr;
1.660 + while (fsRecPtr != NULL) {
1.661 + tmpFsRecPtr = (FilesystemRecord *)ckalloc(sizeof(FilesystemRecord));
1.662 + *tmpFsRecPtr = *fsRecPtr;
1.663 + tmpFsRecPtr->nextPtr = tsdPtr->filesystemList;
1.664 + tmpFsRecPtr->prevPtr = NULL;
1.665 + if (tsdPtr->filesystemList) {
1.666 + tsdPtr->filesystemList->prevPtr = tmpFsRecPtr;
1.667 + }
1.668 + tsdPtr->filesystemList = tmpFsRecPtr;
1.669 + fsRecPtr = fsRecPtr->prevPtr;
1.670 + }
1.671 +
1.672 + /* Make sure the above gets released on thread exit */
1.673 + if (tsdPtr->initialized == 0) {
1.674 + Tcl_CreateThreadExitHandler(FsThrExitProc, (ClientData)tsdPtr);
1.675 + tsdPtr->initialized = 1;
1.676 + }
1.677 +}
1.678 +#endif
1.679 +
1.680 +static FilesystemRecord *
1.681 +FsGetFirstFilesystem(void) {
1.682 + ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);
1.683 + FilesystemRecord *fsRecPtr;
1.684 +#ifndef TCL_THREADS
1.685 + tsdPtr->filesystemEpoch = theFilesystemEpoch;
1.686 + fsRecPtr = filesystemList;
1.687 +#else
1.688 + Tcl_MutexLock(&filesystemMutex);
1.689 + if (tsdPtr->filesystemList == NULL
1.690 + || (tsdPtr->filesystemEpoch != theFilesystemEpoch)) {
1.691 + FsRecacheFilesystemList();
1.692 + tsdPtr->filesystemEpoch = theFilesystemEpoch;
1.693 + }
1.694 + Tcl_MutexUnlock(&filesystemMutex);
1.695 + fsRecPtr = tsdPtr->filesystemList;
1.696 +#endif
1.697 + return fsRecPtr;
1.698 +}
1.699 +
1.700 +static void
1.701 +FsUpdateCwd(cwdObj)
1.702 + Tcl_Obj *cwdObj;
1.703 +{
1.704 + int len;
1.705 + char *str = NULL;
1.706 + ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);
1.707 +
1.708 + if (cwdObj != NULL) {
1.709 + str = Tcl_GetStringFromObj(cwdObj, &len);
1.710 + }
1.711 +
1.712 + Tcl_MutexLock(&cwdMutex);
1.713 +#if !defined(__SYMBIAN32__) || !defined(__WINSCW__)
1.714 + if (cwdPathPtr != NULL) {
1.715 + Tcl_DecrRefCount(cwdPathPtr);
1.716 + }
1.717 + if (cwdObj == NULL) {
1.718 + cwdPathPtr = NULL;
1.719 + } else {
1.720 + /* This MUST be stored as string object! */
1.721 + cwdPathPtr = Tcl_NewStringObj(str, len);
1.722 + Tcl_IncrRefCount(cwdPathPtr);
1.723 + }
1.724 + cwdPathEpoch++;
1.725 + tsdPtr->cwdPathEpoch = cwdPathEpoch;
1.726 +#else
1.727 + if (glcwdPathPtr != NULL) {
1.728 + Tcl_DecrRefCount(glcwdPathPtr);
1.729 + }
1.730 + if (cwdObj == NULL) {
1.731 + glcwdPathPtr = NULL;
1.732 + } else {
1.733 + /* This MUST be stored as string object! */
1.734 + glcwdPathPtr = Tcl_NewStringObj(str, len);
1.735 + Tcl_IncrRefCount(glcwdPathPtr);
1.736 + }
1.737 + glcwdPathEpoch++;
1.738 + tsdPtr->cwdPathEpoch = glcwdPathEpoch;
1.739 +#endif
1.740 + Tcl_MutexUnlock(&cwdMutex);
1.741 +
1.742 + if (tsdPtr->cwdPathPtr) {
1.743 + Tcl_DecrRefCount(tsdPtr->cwdPathPtr);
1.744 + }
1.745 + if (cwdObj == NULL) {
1.746 + tsdPtr->cwdPathPtr = NULL;
1.747 + } else {
1.748 + tsdPtr->cwdPathPtr = Tcl_NewStringObj(str, len);
1.749 + Tcl_IncrRefCount(tsdPtr->cwdPathPtr);
1.750 + }
1.751 +}
1.752 +
1.753 +/*
1.754 + *----------------------------------------------------------------------
1.755 + *
1.756 + * TclFinalizeFilesystem --
1.757 + *
1.758 + * Clean up the filesystem. After this, calls to all Tcl_FS...
1.759 + * functions will fail.
1.760 + *
1.761 + * We will later call TclResetFilesystem to restore the FS
1.762 + * to a pristine state.
1.763 + *
1.764 + * Results:
1.765 + * None.
1.766 + *
1.767 + * Side effects:
1.768 + * Frees any memory allocated by the filesystem.
1.769 + *
1.770 + *----------------------------------------------------------------------
1.771 + */
1.772 +
1.773 +void
1.774 +TclFinalizeFilesystem()
1.775 +{
1.776 + FilesystemRecord *fsRecPtr;
1.777 +
1.778 + /*
1.779 + * Assumption that only one thread is active now. Otherwise
1.780 + * we would need to put various mutexes around this code.
1.781 + */
1.782 +#if !defined(__SYMBIAN32__) || !defined(__WINSCW__)
1.783 + if (cwdPathPtr != NULL) {
1.784 + Tcl_DecrRefCount(cwdPathPtr);
1.785 + cwdPathPtr = NULL;
1.786 + cwdPathEpoch = 0;
1.787 +#else
1.788 + if (glcwdPathPtr != NULL) {
1.789 + Tcl_DecrRefCount(glcwdPathPtr);
1.790 + glcwdPathPtr = NULL;
1.791 + glcwdPathEpoch = 0;
1.792 +#endif
1.793 + }
1.794 +
1.795 + /*
1.796 + * Remove all filesystems, freeing any allocated memory
1.797 + * that is no longer needed
1.798 + */
1.799 +
1.800 + fsRecPtr = filesystemList;
1.801 + while (fsRecPtr != NULL) {
1.802 + FilesystemRecord *tmpFsRecPtr = fsRecPtr->nextPtr;
1.803 + if (fsRecPtr->fileRefCount <= 0) {
1.804 + /* The native filesystem is static, so we don't free it */
1.805 + if (fsRecPtr->fsPtr != &tclNativeFilesystem) {
1.806 + ckfree((char *)fsRecPtr);
1.807 + }
1.808 + }
1.809 + fsRecPtr = tmpFsRecPtr;
1.810 + }
1.811 + filesystemList = NULL;
1.812 +
1.813 + /*
1.814 + * Now filesystemList is NULL. This means that any attempt
1.815 + * to use the filesystem is likely to fail.
1.816 + */
1.817 +
1.818 + statProcList = NULL;
1.819 + accessProcList = NULL;
1.820 + openFileChannelProcList = NULL;
1.821 +#ifdef __WIN32__
1.822 + TclWinEncodingsCleanup();
1.823 +#endif
1.824 +}
1.825 +
1.826 +/*
1.827 + *----------------------------------------------------------------------
1.828 + *
1.829 + * TclResetFilesystem --
1.830 + *
1.831 + * Restore the filesystem to a pristine state.
1.832 + *
1.833 + * Results:
1.834 + * None.
1.835 + *
1.836 + * Side effects:
1.837 + * None.
1.838 + *
1.839 + *----------------------------------------------------------------------
1.840 + */
1.841 +
1.842 +void
1.843 +TclResetFilesystem()
1.844 +{
1.845 + filesystemList = &nativeFilesystemRecord;
1.846 +
1.847 + /*
1.848 + * Note, at this point, I believe nativeFilesystemRecord ->
1.849 + * fileRefCount should equal 1 and if not, we should try to track
1.850 + * down the cause.
1.851 + */
1.852 +
1.853 +#ifdef __WIN32__
1.854 + /*
1.855 + * Cleans up the win32 API filesystem proc lookup table. This must
1.856 + * happen very late in finalization so that deleting of copied
1.857 + * dlls can occur.
1.858 + */
1.859 + TclWinResetInterfaces();
1.860 +#endif
1.861 +}
1.862 +
1.863 +/*
1.864 + *----------------------------------------------------------------------
1.865 + *
1.866 + * Tcl_FSRegister --
1.867 + *
1.868 + * Insert the filesystem function table at the head of the list of
1.869 + * functions which are used during calls to all file-system
1.870 + * operations. The filesystem will be added even if it is
1.871 + * already in the list. (You can use Tcl_FSData to
1.872 + * check if it is in the list, provided the ClientData used was
1.873 + * not NULL).
1.874 + *
1.875 + * Note that the filesystem handling is head-to-tail of the list.
1.876 + * Each filesystem is asked in turn whether it can handle a
1.877 + * particular request, _until_ one of them says 'yes'. At that
1.878 + * point no further filesystems are asked.
1.879 + *
1.880 + * In particular this means if you want to add a diagnostic
1.881 + * filesystem (which simply reports all fs activity), it must be
1.882 + * at the head of the list: i.e. it must be the last registered.
1.883 + *
1.884 + * Results:
1.885 + * Normally TCL_OK; TCL_ERROR if memory for a new node in the list
1.886 + * could not be allocated.
1.887 + *
1.888 + * Side effects:
1.889 + * Memory allocated and modifies the link list for filesystems.
1.890 + *
1.891 + *----------------------------------------------------------------------
1.892 + */
1.893 +
1.894 +EXPORT_C int
1.895 +Tcl_FSRegister(clientData, fsPtr)
1.896 + ClientData clientData; /* Client specific data for this fs */
1.897 + Tcl_Filesystem *fsPtr; /* The filesystem record for the new fs. */
1.898 +{
1.899 + FilesystemRecord *newFilesystemPtr;
1.900 +
1.901 + if (fsPtr == NULL) {
1.902 + return TCL_ERROR;
1.903 + }
1.904 +
1.905 + newFilesystemPtr = (FilesystemRecord *) ckalloc(sizeof(FilesystemRecord));
1.906 +
1.907 + newFilesystemPtr->clientData = clientData;
1.908 + newFilesystemPtr->fsPtr = fsPtr;
1.909 + /*
1.910 + * We start with a refCount of 1. If this drops to zero, then
1.911 + * anyone is welcome to ckfree us.
1.912 + */
1.913 + newFilesystemPtr->fileRefCount = 1;
1.914 +
1.915 + /*
1.916 + * Is this lock and wait strictly speaking necessary? Since any
1.917 + * iterators out there will have grabbed a copy of the head of
1.918 + * the list and be iterating away from that, if we add a new
1.919 + * element to the head of the list, it can't possibly have any
1.920 + * effect on any of their loops. In fact it could be better not
1.921 + * to wait, since we are adjusting the filesystem epoch, any
1.922 + * cached representations calculated by existing iterators are
1.923 + * going to have to be thrown away anyway.
1.924 + *
1.925 + * However, since registering and unregistering filesystems is
1.926 + * a very rare action, this is not a very important point.
1.927 + */
1.928 + Tcl_MutexLock(&filesystemMutex);
1.929 +
1.930 + newFilesystemPtr->nextPtr = filesystemList;
1.931 + newFilesystemPtr->prevPtr = NULL;
1.932 + if (filesystemList) {
1.933 + filesystemList->prevPtr = newFilesystemPtr;
1.934 + }
1.935 + filesystemList = newFilesystemPtr;
1.936 +
1.937 + /*
1.938 + * Increment the filesystem epoch counter, since existing paths
1.939 + * might conceivably now belong to different filesystems.
1.940 + */
1.941 + theFilesystemEpoch++;
1.942 + Tcl_MutexUnlock(&filesystemMutex);
1.943 +
1.944 + return TCL_OK;
1.945 +}
1.946 +
1.947 +/*
1.948 + *----------------------------------------------------------------------
1.949 + *
1.950 + * Tcl_FSUnregister --
1.951 + *
1.952 + * Remove the passed filesystem from the list of filesystem
1.953 + * function tables. It also ensures that the built-in
1.954 + * (native) filesystem is not removable, although we may wish
1.955 + * to change that decision in the future to allow a smaller
1.956 + * Tcl core, in which the native filesystem is not used at
1.957 + * all (we could, say, initialise Tcl completely over a network
1.958 + * connection).
1.959 + *
1.960 + * Results:
1.961 + * TCL_OK if the procedure pointer was successfully removed,
1.962 + * TCL_ERROR otherwise.
1.963 + *
1.964 + * Side effects:
1.965 + * Memory may be deallocated (or will be later, once no "path"
1.966 + * objects refer to this filesystem), but the list of registered
1.967 + * filesystems is updated immediately.
1.968 + *
1.969 + *----------------------------------------------------------------------
1.970 + */
1.971 +
1.972 +EXPORT_C int
1.973 +Tcl_FSUnregister(fsPtr)
1.974 + Tcl_Filesystem *fsPtr; /* The filesystem record to remove. */
1.975 +{
1.976 + int retVal = TCL_ERROR;
1.977 + FilesystemRecord *fsRecPtr;
1.978 +
1.979 + Tcl_MutexLock(&filesystemMutex);
1.980 +
1.981 + /*
1.982 + * Traverse the 'filesystemList' looking for the particular node
1.983 + * whose 'fsPtr' member matches 'fsPtr' and remove that one from
1.984 + * the list. Ensure that the "default" node cannot be removed.
1.985 + */
1.986 +
1.987 + fsRecPtr = filesystemList;
1.988 + while ((retVal == TCL_ERROR) && (fsRecPtr->fsPtr != &tclNativeFilesystem)) {
1.989 + if (fsRecPtr->fsPtr == fsPtr) {
1.990 + if (fsRecPtr->prevPtr) {
1.991 + fsRecPtr->prevPtr->nextPtr = fsRecPtr->nextPtr;
1.992 + } else {
1.993 + filesystemList = fsRecPtr->nextPtr;
1.994 + }
1.995 + if (fsRecPtr->nextPtr) {
1.996 + fsRecPtr->nextPtr->prevPtr = fsRecPtr->prevPtr;
1.997 + }
1.998 + /*
1.999 + * Increment the filesystem epoch counter, since existing
1.1000 + * paths might conceivably now belong to different
1.1001 + * filesystems. This should also ensure that paths which
1.1002 + * have cached the filesystem which is about to be deleted
1.1003 + * do not reference that filesystem (which would of course
1.1004 + * lead to memory exceptions).
1.1005 + */
1.1006 + theFilesystemEpoch++;
1.1007 +
1.1008 + fsRecPtr->fileRefCount--;
1.1009 + if (fsRecPtr->fileRefCount <= 0) {
1.1010 + ckfree((char *)fsRecPtr);
1.1011 + }
1.1012 +
1.1013 + retVal = TCL_OK;
1.1014 + } else {
1.1015 + fsRecPtr = fsRecPtr->nextPtr;
1.1016 + }
1.1017 + }
1.1018 +
1.1019 + Tcl_MutexUnlock(&filesystemMutex);
1.1020 + return (retVal);
1.1021 +}
1.1022 +
1.1023 +/*
1.1024 + *----------------------------------------------------------------------
1.1025 + *
1.1026 + * Tcl_FSMatchInDirectory --
1.1027 + *
1.1028 + * This routine is used by the globbing code to search a directory
1.1029 + * for all files which match a given pattern. The appropriate
1.1030 + * function for the filesystem to which pathPtr belongs will be
1.1031 + * called. If pathPtr does not belong to any filesystem and if it
1.1032 + * is NULL or the empty string, then we assume the pattern is to be
1.1033 + * matched in the current working directory. To avoid each
1.1034 + * filesystem's Tcl_FSMatchInDirectoryProc having to deal with this
1.1035 + * issue, we create a pathPtr on the fly (equal to the cwd), and
1.1036 + * then remove it from the results returned. This makes filesystems
1.1037 + * easy to write, since they can assume the pathPtr passed to them
1.1038 + * is an ordinary path. In fact this means we could remove such
1.1039 + * special case handling from Tcl's native filesystems.
1.1040 + *
1.1041 + * If 'pattern' is NULL, then pathPtr is assumed to be a fully
1.1042 + * specified path of a single file/directory which must be
1.1043 + * checked for existence and correct type.
1.1044 + *
1.1045 + * Results:
1.1046 + *
1.1047 + * The return value is a standard Tcl result indicating whether an
1.1048 + * error occurred in globbing. Error messages are placed in
1.1049 + * interp, but good results are placed in the resultPtr given.
1.1050 + *
1.1051 + * Recursive searches, e.g.
1.1052 + *
1.1053 + * glob -dir $dir -join * pkgIndex.tcl
1.1054 + *
1.1055 + * which must recurse through each directory matching '*' are
1.1056 + * handled internally by Tcl, by passing specific flags in a
1.1057 + * modified 'types' parameter. This means the actual filesystem
1.1058 + * only ever sees patterns which match in a single directory.
1.1059 + *
1.1060 + * Side effects:
1.1061 + * The interpreter may have an error message inserted into it.
1.1062 + *
1.1063 + *----------------------------------------------------------------------
1.1064 + */
1.1065 +
1.1066 +EXPORT_C int
1.1067 +Tcl_FSMatchInDirectory(interp, result, pathPtr, pattern, types)
1.1068 + Tcl_Interp *interp; /* Interpreter to receive error messages. */
1.1069 + Tcl_Obj *result; /* List object to receive results. */
1.1070 + Tcl_Obj *pathPtr; /* Contains path to directory to search. */
1.1071 + CONST char *pattern; /* Pattern to match against. */
1.1072 + Tcl_GlobTypeData *types; /* Object containing list of acceptable types.
1.1073 + * May be NULL. In particular the directory
1.1074 + * flag is very important. */
1.1075 +{
1.1076 + Tcl_Filesystem *fsPtr = Tcl_FSGetFileSystemForPath(pathPtr);
1.1077 + if (fsPtr != NULL) {
1.1078 + Tcl_FSMatchInDirectoryProc *proc = fsPtr->matchInDirectoryProc;
1.1079 + if (proc != NULL) {
1.1080 + int ret = (*proc)(interp, result, pathPtr, pattern, types);
1.1081 + if (ret == TCL_OK && pattern != NULL) {
1.1082 + result = FsAddMountsToGlobResult(result, pathPtr,
1.1083 + pattern, types);
1.1084 + }
1.1085 + return ret;
1.1086 + }
1.1087 + } else {
1.1088 + Tcl_Obj* cwd;
1.1089 + int ret = -1;
1.1090 + if (pathPtr != NULL) {
1.1091 + int len;
1.1092 + Tcl_GetStringFromObj(pathPtr,&len);
1.1093 + if (len != 0) {
1.1094 + /*
1.1095 + * We have no idea how to match files in a directory
1.1096 + * which belongs to no known filesystem
1.1097 + */
1.1098 + Tcl_SetErrno(ENOENT);
1.1099 + return -1;
1.1100 + }
1.1101 + }
1.1102 + /*
1.1103 + * We have an empty or NULL path. This is defined to mean we
1.1104 + * must search for files within the current 'cwd'. We
1.1105 + * therefore use that, but then since the proc we call will
1.1106 + * return results which include the cwd we must then trim it
1.1107 + * off the front of each path in the result. We choose to deal
1.1108 + * with this here (in the generic code), since if we don't,
1.1109 + * every single filesystem's implementation of
1.1110 + * Tcl_FSMatchInDirectory will have to deal with it for us.
1.1111 + */
1.1112 + cwd = Tcl_FSGetCwd(NULL);
1.1113 + if (cwd == NULL) {
1.1114 + if (interp != NULL) {
1.1115 + Tcl_SetResult(interp, "glob couldn't determine "
1.1116 + "the current working directory", TCL_STATIC);
1.1117 + }
1.1118 + return TCL_ERROR;
1.1119 + }
1.1120 + fsPtr = Tcl_FSGetFileSystemForPath(cwd);
1.1121 + if (fsPtr != NULL) {
1.1122 + Tcl_FSMatchInDirectoryProc *proc = fsPtr->matchInDirectoryProc;
1.1123 + if (proc != NULL) {
1.1124 + Tcl_Obj* tmpResultPtr = Tcl_NewListObj(0, NULL);
1.1125 + Tcl_IncrRefCount(tmpResultPtr);
1.1126 + ret = (*proc)(interp, tmpResultPtr, cwd, pattern, types);
1.1127 + if (ret == TCL_OK) {
1.1128 + int resLength;
1.1129 +
1.1130 + tmpResultPtr = FsAddMountsToGlobResult(tmpResultPtr, cwd,
1.1131 + pattern, types);
1.1132 +
1.1133 + ret = Tcl_ListObjLength(interp, tmpResultPtr, &resLength);
1.1134 + if (ret == TCL_OK) {
1.1135 + int i;
1.1136 +
1.1137 + for (i = 0; i < resLength; i++) {
1.1138 + Tcl_Obj *elt;
1.1139 +
1.1140 + Tcl_ListObjIndex(interp, tmpResultPtr, i, &elt);
1.1141 + Tcl_ListObjAppendElement(interp, result,
1.1142 + TclFSMakePathRelative(interp, elt, cwd));
1.1143 + }
1.1144 + }
1.1145 + }
1.1146 + Tcl_DecrRefCount(tmpResultPtr);
1.1147 + }
1.1148 + }
1.1149 + Tcl_DecrRefCount(cwd);
1.1150 + return ret;
1.1151 + }
1.1152 + Tcl_SetErrno(ENOENT);
1.1153 + return -1;
1.1154 +}
1.1155 +
1.1156 +/*
1.1157 + *----------------------------------------------------------------------
1.1158 + *
1.1159 + * FsAddMountsToGlobResult --
1.1160 + *
1.1161 + * This routine is used by the globbing code to take the results
1.1162 + * of a directory listing and add any mounted paths to that
1.1163 + * listing. This is required so that simple things like
1.1164 + * 'glob *' merge mounts and listings correctly.
1.1165 + *
1.1166 + * Results:
1.1167 + *
1.1168 + * The passed in 'result' may be modified (in place, if
1.1169 + * necessary), and the correct list is returned.
1.1170 + *
1.1171 + * Side effects:
1.1172 + * None.
1.1173 + *
1.1174 + *----------------------------------------------------------------------
1.1175 + */
1.1176 +static Tcl_Obj*
1.1177 +FsAddMountsToGlobResult(result, pathPtr, pattern, types)
1.1178 + Tcl_Obj *result; /* The current list of matching paths */
1.1179 + Tcl_Obj *pathPtr; /* The directory in question */
1.1180 + CONST char *pattern;
1.1181 + Tcl_GlobTypeData *types;
1.1182 +{
1.1183 + int mLength, gLength, i;
1.1184 + int dir = (types == NULL || (types->type & TCL_GLOB_TYPE_DIR));
1.1185 + Tcl_Obj *mounts = FsListMounts(pathPtr, pattern);
1.1186 +
1.1187 + if (mounts == NULL) return result;
1.1188 +
1.1189 + if (Tcl_ListObjLength(NULL, mounts, &mLength) != TCL_OK || mLength == 0) {
1.1190 + goto endOfMounts;
1.1191 + }
1.1192 + if (Tcl_ListObjLength(NULL, result, &gLength) != TCL_OK) {
1.1193 + goto endOfMounts;
1.1194 + }
1.1195 + for (i = 0; i < mLength; i++) {
1.1196 + Tcl_Obj *mElt;
1.1197 + int j;
1.1198 + int found = 0;
1.1199 +
1.1200 + Tcl_ListObjIndex(NULL, mounts, i, &mElt);
1.1201 +
1.1202 + for (j = 0; j < gLength; j++) {
1.1203 + Tcl_Obj *gElt;
1.1204 + Tcl_ListObjIndex(NULL, result, j, &gElt);
1.1205 + if (Tcl_FSEqualPaths(mElt, gElt)) {
1.1206 + found = 1;
1.1207 + if (!dir) {
1.1208 + /* We don't want to list this */
1.1209 + if (Tcl_IsShared(result)) {
1.1210 + Tcl_Obj *newList;
1.1211 + newList = Tcl_DuplicateObj(result);
1.1212 + Tcl_DecrRefCount(result);
1.1213 + result = newList;
1.1214 + }
1.1215 + Tcl_ListObjReplace(NULL, result, j, 1, 0, NULL);
1.1216 + gLength--;
1.1217 + }
1.1218 + /* Break out of for loop */
1.1219 + break;
1.1220 + }
1.1221 + }
1.1222 + if (!found && dir) {
1.1223 + if (Tcl_IsShared(result)) {
1.1224 + Tcl_Obj *newList;
1.1225 + newList = Tcl_DuplicateObj(result);
1.1226 + Tcl_DecrRefCount(result);
1.1227 + result = newList;
1.1228 + }
1.1229 + Tcl_ListObjAppendElement(NULL, result, mElt);
1.1230 + /*
1.1231 + * No need to increment gLength, since we
1.1232 + * don't want to compare mounts against
1.1233 + * mounts.
1.1234 + */
1.1235 + }
1.1236 + }
1.1237 + endOfMounts:
1.1238 + Tcl_DecrRefCount(mounts);
1.1239 + return result;
1.1240 +}
1.1241 +
1.1242 +/*
1.1243 + *----------------------------------------------------------------------
1.1244 + *
1.1245 + * Tcl_FSMountsChanged --
1.1246 + *
1.1247 + * Notify the filesystem that the available mounted filesystems
1.1248 + * (or within any one filesystem type, the number or location of
1.1249 + * mount points) have changed.
1.1250 + *
1.1251 + * Results:
1.1252 + * None.
1.1253 + *
1.1254 + * Side effects:
1.1255 + * The global filesystem variable 'theFilesystemEpoch' is
1.1256 + * incremented. The effect of this is to make all cached
1.1257 + * path representations invalid. Clearly it should only therefore
1.1258 + * be called when it is really required! There are a few
1.1259 + * circumstances when it should be called:
1.1260 + *
1.1261 + * (1) when a new filesystem is registered or unregistered.
1.1262 + * Strictly speaking this is only necessary if the new filesystem
1.1263 + * accepts file paths as is (normally the filesystem itself is
1.1264 + * really a shell which hasn't yet had any mount points established
1.1265 + * and so its 'pathInFilesystem' proc will always fail). However,
1.1266 + * for safety, Tcl always calls this for you in these circumstances.
1.1267 + *
1.1268 + * (2) when additional mount points are established inside any
1.1269 + * existing filesystem (except the native fs)
1.1270 + *
1.1271 + * (3) when any filesystem (except the native fs) changes the list
1.1272 + * of available volumes.
1.1273 + *
1.1274 + * (4) when the mapping from a string representation of a file to
1.1275 + * a full, normalized path changes. For example, if 'env(HOME)'
1.1276 + * is modified, then any path containing '~' will map to a different
1.1277 + * filesystem location. Therefore all such paths need to have
1.1278 + * their internal representation invalidated.
1.1279 + *
1.1280 + * Tcl has no control over (2) and (3), so any registered filesystem
1.1281 + * must make sure it calls this function when those situations
1.1282 + * occur.
1.1283 + *
1.1284 + * (Note: the reason for the exception in 2,3 for the native
1.1285 + * filesystem is that the native filesystem by default claims all
1.1286 + * unknown files even if it really doesn't understand them or if
1.1287 + * they don't exist).
1.1288 + *
1.1289 + *----------------------------------------------------------------------
1.1290 + */
1.1291 +
1.1292 +EXPORT_C void
1.1293 +Tcl_FSMountsChanged(fsPtr)
1.1294 + Tcl_Filesystem *fsPtr;
1.1295 +{
1.1296 + /*
1.1297 + * We currently don't do anything with this parameter. We
1.1298 + * could in the future only invalidate files for this filesystem
1.1299 + * or otherwise take more advanced action.
1.1300 + */
1.1301 + (void)fsPtr;
1.1302 + /*
1.1303 + * Increment the filesystem epoch counter, since existing paths
1.1304 + * might now belong to different filesystems.
1.1305 + */
1.1306 + Tcl_MutexLock(&filesystemMutex);
1.1307 + theFilesystemEpoch++;
1.1308 + Tcl_MutexUnlock(&filesystemMutex);
1.1309 +}
1.1310 +
1.1311 +/*
1.1312 + *----------------------------------------------------------------------
1.1313 + *
1.1314 + * Tcl_FSData --
1.1315 + *
1.1316 + * Retrieve the clientData field for the filesystem given,
1.1317 + * or NULL if that filesystem is not registered.
1.1318 + *
1.1319 + * Results:
1.1320 + * A clientData value, or NULL. Note that if the filesystem
1.1321 + * was registered with a NULL clientData field, this function
1.1322 + * will return that NULL value.
1.1323 + *
1.1324 + * Side effects:
1.1325 + * None.
1.1326 + *
1.1327 + *----------------------------------------------------------------------
1.1328 + */
1.1329 +
1.1330 +EXPORT_C ClientData
1.1331 +Tcl_FSData(fsPtr)
1.1332 + Tcl_Filesystem *fsPtr; /* The filesystem record to query. */
1.1333 +{
1.1334 + ClientData retVal = NULL;
1.1335 + FilesystemRecord *fsRecPtr = FsGetFirstFilesystem();
1.1336 +
1.1337 + /*
1.1338 + * Traverse the 'filesystemList' looking for the particular node
1.1339 + * whose 'fsPtr' member matches 'fsPtr' and remove that one from
1.1340 + * the list. Ensure that the "default" node cannot be removed.
1.1341 + */
1.1342 +
1.1343 + while ((retVal == NULL) && (fsRecPtr != NULL)) {
1.1344 + if (fsRecPtr->fsPtr == fsPtr) {
1.1345 + retVal = fsRecPtr->clientData;
1.1346 + }
1.1347 + fsRecPtr = fsRecPtr->nextPtr;
1.1348 + }
1.1349 +
1.1350 + return retVal;
1.1351 +}
1.1352 +
1.1353 +/*
1.1354 + *---------------------------------------------------------------------------
1.1355 + *
1.1356 + * TclFSNormalizeAbsolutePath --
1.1357 + *
1.1358 + * Description:
1.1359 + * Takes an absolute path specification and computes a 'normalized'
1.1360 + * path from it.
1.1361 + *
1.1362 + * A normalized path is one which has all '../', './' removed.
1.1363 + * Also it is one which is in the 'standard' format for the native
1.1364 + * platform. On MacOS, Unix, this means the path must be free of
1.1365 + * symbolic links/aliases, and on Windows it means we want the
1.1366 + * long form, with that long form's case-dependence (which gives
1.1367 + * us a unique, case-dependent path).
1.1368 + *
1.1369 + * The behaviour of this function if passed a non-absolute path
1.1370 + * is NOT defined.
1.1371 + *
1.1372 + * Results:
1.1373 + * The result is returned in a Tcl_Obj with a refCount of 1,
1.1374 + * which is therefore owned by the caller. It must be
1.1375 + * freed (with Tcl_DecrRefCount) by the caller when no longer needed.
1.1376 + *
1.1377 + * Side effects:
1.1378 + * None (beyond the memory allocation for the result).
1.1379 + *
1.1380 + * Special note:
1.1381 + * This code is based on code from Matt Newman and Jean-Claude
1.1382 + * Wippler, with additions from Vince Darley and is copyright
1.1383 + * those respective authors.
1.1384 + *
1.1385 + *---------------------------------------------------------------------------
1.1386 + */
1.1387 +static Tcl_Obj *
1.1388 +TclFSNormalizeAbsolutePath(interp, pathPtr, clientDataPtr)
1.1389 + Tcl_Interp* interp; /* Interpreter to use */
1.1390 + Tcl_Obj *pathPtr; /* Absolute path to normalize */
1.1391 + ClientData *clientDataPtr;
1.1392 +{
1.1393 + int splen = 0, nplen, eltLen, i;
1.1394 + char *eltName;
1.1395 + Tcl_Obj *retVal;
1.1396 + Tcl_Obj *split;
1.1397 + Tcl_Obj *elt;
1.1398 +
1.1399 + /* Split has refCount zero */
1.1400 + split = Tcl_FSSplitPath(pathPtr, &splen);
1.1401 +
1.1402 + /*
1.1403 + * Modify the list of entries in place, by removing '.', and
1.1404 + * removing '..' and the entry before -- unless that entry before
1.1405 + * is the top-level entry, i.e. the name of a volume.
1.1406 + */
1.1407 + nplen = 0;
1.1408 + for (i = 0; i < splen; i++) {
1.1409 + Tcl_ListObjIndex(NULL, split, nplen, &elt);
1.1410 + eltName = Tcl_GetStringFromObj(elt, &eltLen);
1.1411 +
1.1412 + if ((eltLen == 1) && (eltName[0] == '.')) {
1.1413 + Tcl_ListObjReplace(NULL, split, nplen, 1, 0, NULL);
1.1414 + } else if ((eltLen == 2)
1.1415 + && (eltName[0] == '.') && (eltName[1] == '.')) {
1.1416 + if (nplen > 1) {
1.1417 + nplen--;
1.1418 + Tcl_ListObjReplace(NULL, split, nplen, 2, 0, NULL);
1.1419 + } else {
1.1420 + Tcl_ListObjReplace(NULL, split, nplen, 1, 0, NULL);
1.1421 + }
1.1422 + } else {
1.1423 + nplen++;
1.1424 + }
1.1425 + }
1.1426 + if (nplen > 0) {
1.1427 + ClientData clientData = NULL;
1.1428 +
1.1429 + retVal = Tcl_FSJoinPath(split, nplen);
1.1430 + /*
1.1431 + * Now we have an absolute path, with no '..', '.' sequences,
1.1432 + * but it still may not be in 'unique' form, depending on the
1.1433 + * platform. For instance, Unix is case-sensitive, so the
1.1434 + * path is ok. Windows is case-insensitive, and also has the
1.1435 + * weird 'longname/shortname' thing (e.g. C:/Program Files/ and
1.1436 + * C:/Progra~1/ are equivalent). MacOS is case-insensitive.
1.1437 + *
1.1438 + * Virtual file systems which may be registered may have
1.1439 + * other criteria for normalizing a path.
1.1440 + */
1.1441 + Tcl_IncrRefCount(retVal);
1.1442 + TclFSNormalizeToUniquePath(interp, retVal, 0, &clientData);
1.1443 + /*
1.1444 + * Since we know it is a normalized path, we can
1.1445 + * actually convert this object into an "path" object for
1.1446 + * greater efficiency
1.1447 + */
1.1448 + TclFSMakePathFromNormalized(interp, retVal, clientData);
1.1449 + if (clientDataPtr != NULL) {
1.1450 + *clientDataPtr = clientData;
1.1451 + }
1.1452 + } else {
1.1453 + /* Init to an empty string */
1.1454 + retVal = Tcl_NewStringObj("",0);
1.1455 + Tcl_IncrRefCount(retVal);
1.1456 + }
1.1457 + /*
1.1458 + * We increment and then decrement the refCount of split to free
1.1459 + * it. We do this right at the end, in case there are
1.1460 + * optimisations in Tcl_FSJoinPath(split, nplen) above which would
1.1461 + * let it make use of split more effectively if it has a refCount
1.1462 + * of zero. Also we can't just decrement the ref count, in case
1.1463 + * 'split' was actually returned by the join call above, in a
1.1464 + * single-element optimisation when nplen == 1.
1.1465 + */
1.1466 + Tcl_IncrRefCount(split);
1.1467 + Tcl_DecrRefCount(split);
1.1468 +
1.1469 + /* This has a refCount of 1 for the caller */
1.1470 + return retVal;
1.1471 +}
1.1472 +
1.1473 +/*
1.1474 + *---------------------------------------------------------------------------
1.1475 + *
1.1476 + * TclFSNormalizeToUniquePath --
1.1477 + *
1.1478 + * Description:
1.1479 + * Takes a path specification containing no ../, ./ sequences,
1.1480 + * and converts it into a unique path for the given platform.
1.1481 + * On MacOS, Unix, this means the path must be free of
1.1482 + * symbolic links/aliases, and on Windows it means we want the
1.1483 + * long form, with that long form's case-dependence (which gives
1.1484 + * us a unique, case-dependent path).
1.1485 + *
1.1486 + * Results:
1.1487 + * The pathPtr is modified in place. The return value is
1.1488 + * the last byte offset which was recognised in the path
1.1489 + * string.
1.1490 + *
1.1491 + * Side effects:
1.1492 + * None (beyond the memory allocation for the result).
1.1493 + *
1.1494 + * Special notes:
1.1495 + * If the filesystem-specific normalizePathProcs can re-introduce
1.1496 + * ../, ./ sequences into the path, then this function will
1.1497 + * not return the correct result. This may be possible with
1.1498 + * symbolic links on unix/macos.
1.1499 + *
1.1500 + * Important assumption: if startAt is non-zero, it must point
1.1501 + * to a directory separator that we know exists and is already
1.1502 + * normalized (so it is important not to point to the char just
1.1503 + * after the separator).
1.1504 + *---------------------------------------------------------------------------
1.1505 + */
1.1506 +int
1.1507 +TclFSNormalizeToUniquePath(interp, pathPtr, startAt, clientDataPtr)
1.1508 + Tcl_Interp *interp;
1.1509 + Tcl_Obj *pathPtr;
1.1510 + int startAt;
1.1511 + ClientData *clientDataPtr;
1.1512 +{
1.1513 + FilesystemRecord *fsRecPtr, *firstFsRecPtr;
1.1514 + /* Ignore this variable */
1.1515 + (void)clientDataPtr;
1.1516 +
1.1517 + /*
1.1518 + * Call each of the "normalise path" functions in succession. This is
1.1519 + * a special case, in which if we have a native filesystem handler,
1.1520 + * we call it first. This is because the root of Tcl's filesystem
1.1521 + * is always a native filesystem (i.e. '/' on unix is native).
1.1522 + */
1.1523 +
1.1524 + firstFsRecPtr = FsGetFirstFilesystem();
1.1525 +
1.1526 + fsRecPtr = firstFsRecPtr;
1.1527 + while (fsRecPtr != NULL) {
1.1528 + if (fsRecPtr->fsPtr == &tclNativeFilesystem) {
1.1529 + Tcl_FSNormalizePathProc *proc = fsRecPtr->fsPtr->normalizePathProc;
1.1530 + if (proc != NULL) {
1.1531 + startAt = (*proc)(interp, pathPtr, startAt);
1.1532 + }
1.1533 + break;
1.1534 + }
1.1535 + fsRecPtr = fsRecPtr->nextPtr;
1.1536 + }
1.1537 +
1.1538 + fsRecPtr = firstFsRecPtr;
1.1539 + while (fsRecPtr != NULL) {
1.1540 + /* Skip the native system next time through */
1.1541 + if (fsRecPtr->fsPtr != &tclNativeFilesystem) {
1.1542 + Tcl_FSNormalizePathProc *proc = fsRecPtr->fsPtr->normalizePathProc;
1.1543 + if (proc != NULL) {
1.1544 + startAt = (*proc)(interp, pathPtr, startAt);
1.1545 + }
1.1546 + /*
1.1547 + * We could add an efficiency check like this:
1.1548 + *
1.1549 + * if (retVal == length-of(pathPtr)) {break;}
1.1550 + *
1.1551 + * but there's not much benefit.
1.1552 + */
1.1553 + }
1.1554 + fsRecPtr = fsRecPtr->nextPtr;
1.1555 + }
1.1556 +
1.1557 + return startAt;
1.1558 +}
1.1559 +
1.1560 +/*
1.1561 + *---------------------------------------------------------------------------
1.1562 + *
1.1563 + * TclGetOpenMode --
1.1564 + *
1.1565 + * Description:
1.1566 + * Computes a POSIX mode mask for opening a file, from a given string,
1.1567 + * and also sets a flag to indicate whether the caller should seek to
1.1568 + * EOF after opening the file.
1.1569 + *
1.1570 + * Results:
1.1571 + * On success, returns mode to pass to "open". If an error occurs, the
1.1572 + * return value is -1 and if interp is not NULL, sets interp's result
1.1573 + * object to an error message.
1.1574 + *
1.1575 + * Side effects:
1.1576 + * Sets the integer referenced by seekFlagPtr to 1 to tell the caller
1.1577 + * to seek to EOF after opening the file.
1.1578 + *
1.1579 + * Special note:
1.1580 + * This code is based on a prototype implementation contributed
1.1581 + * by Mark Diekhans.
1.1582 + *
1.1583 + *---------------------------------------------------------------------------
1.1584 + */
1.1585 +
1.1586 +int
1.1587 +TclGetOpenMode(interp, string, seekFlagPtr)
1.1588 + Tcl_Interp *interp; /* Interpreter to use for error
1.1589 + * reporting - may be NULL. */
1.1590 + CONST char *string; /* Mode string, e.g. "r+" or
1.1591 + * "RDONLY CREAT". */
1.1592 + int *seekFlagPtr; /* Set this to 1 if the caller
1.1593 + * should seek to EOF during the
1.1594 + * opening of the file. */
1.1595 +{
1.1596 + int mode, modeArgc, c, i, gotRW;
1.1597 + CONST char **modeArgv, *flag;
1.1598 +#define RW_MODES (O_RDONLY|O_WRONLY|O_RDWR)
1.1599 +
1.1600 + /*
1.1601 + * Check for the simpler fopen-like access modes (e.g. "r"). They
1.1602 + * are distinguished from the POSIX access modes by the presence
1.1603 + * of a lower-case first letter.
1.1604 + */
1.1605 +
1.1606 + *seekFlagPtr = 0;
1.1607 + mode = 0;
1.1608 +
1.1609 + /*
1.1610 + * Guard against international characters before using byte oriented
1.1611 + * routines.
1.1612 + */
1.1613 +
1.1614 + if (!(string[0] & 0x80)
1.1615 + && islower(UCHAR(string[0]))) { /* INTL: ISO only. */
1.1616 + switch (string[0]) {
1.1617 + case 'r':
1.1618 + mode = O_RDONLY;
1.1619 + break;
1.1620 + case 'w':
1.1621 + mode = O_WRONLY|O_CREAT|O_TRUNC;
1.1622 + break;
1.1623 + case 'a':
1.1624 + /* [Bug 680143].
1.1625 + * Added O_APPEND for proper automatic
1.1626 + * seek-to-end-on-write by the OS.
1.1627 + */
1.1628 + mode = O_WRONLY|O_CREAT|O_APPEND;
1.1629 + *seekFlagPtr = 1;
1.1630 + break;
1.1631 + default:
1.1632 + error:
1.1633 + if (interp != (Tcl_Interp *) NULL) {
1.1634 + Tcl_AppendResult(interp,
1.1635 + "illegal access mode \"", string, "\"",
1.1636 + (char *) NULL);
1.1637 + }
1.1638 + return -1;
1.1639 + }
1.1640 + if (string[1] == '+') {
1.1641 + mode &= ~(O_RDONLY|O_WRONLY);
1.1642 + mode |= O_RDWR;
1.1643 + if (string[2] != 0) {
1.1644 + goto error;
1.1645 + }
1.1646 + } else if (string[1] != 0) {
1.1647 + goto error;
1.1648 + }
1.1649 + return mode;
1.1650 + }
1.1651 +
1.1652 + /*
1.1653 + * The access modes are specified using a list of POSIX modes
1.1654 + * such as O_CREAT.
1.1655 + *
1.1656 + * IMPORTANT NOTE: We rely on Tcl_SplitList working correctly when
1.1657 + * a NULL interpreter is passed in.
1.1658 + */
1.1659 +
1.1660 + if (Tcl_SplitList(interp, string, &modeArgc, &modeArgv) != TCL_OK) {
1.1661 + if (interp != (Tcl_Interp *) NULL) {
1.1662 + Tcl_AddErrorInfo(interp,
1.1663 + "\n while processing open access modes \"");
1.1664 + Tcl_AddErrorInfo(interp, string);
1.1665 + Tcl_AddErrorInfo(interp, "\"");
1.1666 + }
1.1667 + return -1;
1.1668 + }
1.1669 +
1.1670 + gotRW = 0;
1.1671 + for (i = 0; i < modeArgc; i++) {
1.1672 + flag = modeArgv[i];
1.1673 + c = flag[0];
1.1674 + if ((c == 'R') && (strcmp(flag, "RDONLY") == 0)) {
1.1675 + mode = (mode & ~RW_MODES) | O_RDONLY;
1.1676 + gotRW = 1;
1.1677 + } else if ((c == 'W') && (strcmp(flag, "WRONLY") == 0)) {
1.1678 + mode = (mode & ~RW_MODES) | O_WRONLY;
1.1679 + gotRW = 1;
1.1680 + } else if ((c == 'R') && (strcmp(flag, "RDWR") == 0)) {
1.1681 + mode = (mode & ~RW_MODES) | O_RDWR;
1.1682 + gotRW = 1;
1.1683 + } else if ((c == 'A') && (strcmp(flag, "APPEND") == 0)) {
1.1684 + mode |= O_APPEND;
1.1685 + *seekFlagPtr = 1;
1.1686 + } else if ((c == 'C') && (strcmp(flag, "CREAT") == 0)) {
1.1687 + mode |= O_CREAT;
1.1688 + } else if ((c == 'E') && (strcmp(flag, "EXCL") == 0)) {
1.1689 + mode |= O_EXCL;
1.1690 + } else if ((c == 'N') && (strcmp(flag, "NOCTTY") == 0)) {
1.1691 +#ifdef O_NOCTTY
1.1692 + mode |= O_NOCTTY;
1.1693 +#else
1.1694 + if (interp != (Tcl_Interp *) NULL) {
1.1695 + Tcl_AppendResult(interp, "access mode \"", flag,
1.1696 + "\" not supported by this system", (char *) NULL);
1.1697 + }
1.1698 + ckfree((char *) modeArgv);
1.1699 + return -1;
1.1700 +#endif
1.1701 + } else if ((c == 'N') && (strcmp(flag, "NONBLOCK") == 0)) {
1.1702 +#if defined(O_NDELAY) || defined(O_NONBLOCK)
1.1703 +# ifdef O_NONBLOCK
1.1704 + mode |= O_NONBLOCK;
1.1705 +# else
1.1706 + mode |= O_NDELAY;
1.1707 +# endif
1.1708 +#else
1.1709 + if (interp != (Tcl_Interp *) NULL) {
1.1710 + Tcl_AppendResult(interp, "access mode \"", flag,
1.1711 + "\" not supported by this system", (char *) NULL);
1.1712 + }
1.1713 + ckfree((char *) modeArgv);
1.1714 + return -1;
1.1715 +#endif
1.1716 + } else if ((c == 'T') && (strcmp(flag, "TRUNC") == 0)) {
1.1717 + mode |= O_TRUNC;
1.1718 + } else {
1.1719 + if (interp != (Tcl_Interp *) NULL) {
1.1720 + Tcl_AppendResult(interp, "invalid access mode \"", flag,
1.1721 + "\": must be RDONLY, WRONLY, RDWR, APPEND, CREAT",
1.1722 + " EXCL, NOCTTY, NONBLOCK, or TRUNC", (char *) NULL);
1.1723 + }
1.1724 + ckfree((char *) modeArgv);
1.1725 + return -1;
1.1726 + }
1.1727 + }
1.1728 + ckfree((char *) modeArgv);
1.1729 + if (!gotRW) {
1.1730 + if (interp != (Tcl_Interp *) NULL) {
1.1731 + Tcl_AppendResult(interp, "access mode must include either",
1.1732 + " RDONLY, WRONLY, or RDWR", (char *) NULL);
1.1733 + }
1.1734 + return -1;
1.1735 + }
1.1736 + return mode;
1.1737 +}
1.1738 +
1.1739 +/*
1.1740 + *----------------------------------------------------------------------
1.1741 + *
1.1742 + * Tcl_FSEvalFile --
1.1743 + *
1.1744 + * Read in a file and process the entire file as one gigantic
1.1745 + * Tcl command.
1.1746 + *
1.1747 + * Results:
1.1748 + * A standard Tcl result, which is either the result of executing
1.1749 + * the file or an error indicating why the file couldn't be read.
1.1750 + *
1.1751 + * Side effects:
1.1752 + * Depends on the commands in the file. During the evaluation
1.1753 + * of the contents of the file, iPtr->scriptFile is made to
1.1754 + * point to pathPtr (the old value is cached and replaced when
1.1755 + * this function returns).
1.1756 + *
1.1757 + *----------------------------------------------------------------------
1.1758 + */
1.1759 +
1.1760 +EXPORT_C int
1.1761 +Tcl_FSEvalFile(interp, pathPtr)
1.1762 + Tcl_Interp *interp; /* Interpreter in which to process file. */
1.1763 + Tcl_Obj *pathPtr; /* Path of file to process. Tilde-substitution
1.1764 + * will be performed on this name. */
1.1765 +{
1.1766 + int result, length;
1.1767 + Tcl_StatBuf statBuf;
1.1768 + Tcl_Obj *oldScriptFile;
1.1769 + Interp *iPtr;
1.1770 + char *string;
1.1771 + Tcl_Channel chan;
1.1772 + Tcl_Obj *objPtr;
1.1773 +
1.1774 + if (Tcl_FSGetNormalizedPath(interp, pathPtr) == NULL) {
1.1775 + return TCL_ERROR;
1.1776 + }
1.1777 +
1.1778 + result = TCL_ERROR;
1.1779 + objPtr = Tcl_NewObj();
1.1780 + Tcl_IncrRefCount(objPtr);
1.1781 +
1.1782 + if (Tcl_FSStat(pathPtr, &statBuf) == -1) {
1.1783 + Tcl_SetErrno(errno);
1.1784 + Tcl_AppendResult(interp, "couldn't read file \"",
1.1785 + Tcl_GetString(pathPtr),
1.1786 + "\": ", Tcl_PosixError(interp), (char *) NULL);
1.1787 + goto end;
1.1788 + }
1.1789 + chan = Tcl_FSOpenFileChannel(interp, pathPtr, "r", 0644);
1.1790 + if (chan == (Tcl_Channel) NULL) {
1.1791 + Tcl_ResetResult(interp);
1.1792 + Tcl_AppendResult(interp, "couldn't read file \"",
1.1793 + Tcl_GetString(pathPtr),
1.1794 + "\": ", Tcl_PosixError(interp), (char *) NULL);
1.1795 + goto end;
1.1796 + }
1.1797 + /*
1.1798 + * The eofchar is \32 (^Z). This is the usual on Windows, but we
1.1799 + * effect this cross-platform to allow for scripted documents.
1.1800 + * [Bug: 2040]
1.1801 + */
1.1802 + Tcl_SetChannelOption(interp, chan, "-eofchar", "\32");
1.1803 + if (Tcl_ReadChars(chan, objPtr, -1, 0) < 0) {
1.1804 + Tcl_Close(interp, chan);
1.1805 + Tcl_AppendResult(interp, "couldn't read file \"",
1.1806 + Tcl_GetString(pathPtr),
1.1807 + "\": ", Tcl_PosixError(interp), (char *) NULL);
1.1808 + goto end;
1.1809 + }
1.1810 + if (Tcl_Close(interp, chan) != TCL_OK) {
1.1811 + goto end;
1.1812 + }
1.1813 +
1.1814 + iPtr = (Interp *) interp;
1.1815 + oldScriptFile = iPtr->scriptFile;
1.1816 + iPtr->scriptFile = pathPtr;
1.1817 + Tcl_IncrRefCount(iPtr->scriptFile);
1.1818 + string = Tcl_GetStringFromObj(objPtr, &length);
1.1819 +
1.1820 +#ifdef TCL_TIP280
1.1821 + /* TIP #280 Force the evaluator to open a frame for a sourced
1.1822 + * file. */
1.1823 + iPtr->evalFlags |= TCL_EVAL_FILE;
1.1824 +#endif
1.1825 + result = Tcl_EvalEx(interp, string, length, 0);
1.1826 + /*
1.1827 + * Now we have to be careful; the script may have changed the
1.1828 + * iPtr->scriptFile value, so we must reset it without
1.1829 + * assuming it still points to 'pathPtr'.
1.1830 + */
1.1831 + if (iPtr->scriptFile != NULL) {
1.1832 + Tcl_DecrRefCount(iPtr->scriptFile);
1.1833 + }
1.1834 + iPtr->scriptFile = oldScriptFile;
1.1835 +
1.1836 + if (result == TCL_RETURN) {
1.1837 + result = TclUpdateReturnInfo(iPtr);
1.1838 + } else if (result == TCL_ERROR) {
1.1839 + char msg[200 + TCL_INTEGER_SPACE];
1.1840 +
1.1841 + /*
1.1842 + * Record information telling where the error occurred.
1.1843 + */
1.1844 +
1.1845 + sprintf(msg, "\n (file \"%.150s\" line %d)", Tcl_GetString(pathPtr),
1.1846 + interp->errorLine);
1.1847 + Tcl_AddErrorInfo(interp, msg);
1.1848 + }
1.1849 +
1.1850 + end:
1.1851 + Tcl_DecrRefCount(objPtr);
1.1852 + return result;
1.1853 +}
1.1854 +
1.1855 +/*
1.1856 + *----------------------------------------------------------------------
1.1857 + *
1.1858 + * Tcl_GetErrno --
1.1859 + *
1.1860 + * Gets the current value of the Tcl error code variable. This is
1.1861 + * currently the global variable "errno" but could in the future
1.1862 + * change to something else.
1.1863 + *
1.1864 + * Results:
1.1865 + * The value of the Tcl error code variable.
1.1866 + *
1.1867 + * Side effects:
1.1868 + * None. Note that the value of the Tcl error code variable is
1.1869 + * UNDEFINED if a call to Tcl_SetErrno did not precede this call.
1.1870 + *
1.1871 + *----------------------------------------------------------------------
1.1872 + */
1.1873 +
1.1874 +EXPORT_C int
1.1875 +Tcl_GetErrno()
1.1876 +{
1.1877 + return errno;
1.1878 +}
1.1879 +
1.1880 +/*
1.1881 + *----------------------------------------------------------------------
1.1882 + *
1.1883 + * Tcl_SetErrno --
1.1884 + *
1.1885 + * Sets the Tcl error code variable to the supplied value.
1.1886 + *
1.1887 + * Results:
1.1888 + * None.
1.1889 + *
1.1890 + * Side effects:
1.1891 + * Modifies the value of the Tcl error code variable.
1.1892 + *
1.1893 + *----------------------------------------------------------------------
1.1894 + */
1.1895 +
1.1896 +EXPORT_C void
1.1897 +Tcl_SetErrno(err)
1.1898 + int err; /* The new value. */
1.1899 +{
1.1900 + errno = err;
1.1901 +}
1.1902 +
1.1903 +/*
1.1904 + *----------------------------------------------------------------------
1.1905 + *
1.1906 + * Tcl_PosixError --
1.1907 + *
1.1908 + * This procedure is typically called after UNIX kernel calls
1.1909 + * return errors. It stores machine-readable information about
1.1910 + * the error in $errorCode returns an information string for
1.1911 + * the caller's use.
1.1912 + *
1.1913 + * Results:
1.1914 + * The return value is a human-readable string describing the
1.1915 + * error.
1.1916 + *
1.1917 + * Side effects:
1.1918 + * The global variable $errorCode is reset.
1.1919 + *
1.1920 + *----------------------------------------------------------------------
1.1921 + */
1.1922 +
1.1923 +EXPORT_C CONST char *
1.1924 +Tcl_PosixError(interp)
1.1925 + Tcl_Interp *interp; /* Interpreter whose $errorCode variable
1.1926 + * is to be changed. */
1.1927 +{
1.1928 + CONST char *id, *msg;
1.1929 +
1.1930 + msg = Tcl_ErrnoMsg(errno);
1.1931 + id = Tcl_ErrnoId();
1.1932 + if (interp) {
1.1933 + Tcl_SetErrorCode(interp, "POSIX", id, msg, (char *) NULL);
1.1934 + }
1.1935 + return msg;
1.1936 +}
1.1937 +
1.1938 +/*
1.1939 + *----------------------------------------------------------------------
1.1940 + *
1.1941 + * Tcl_FSStat --
1.1942 + *
1.1943 + * This procedure replaces the library version of stat and lsat.
1.1944 + *
1.1945 + * The appropriate function for the filesystem to which pathPtr
1.1946 + * belongs will be called.
1.1947 + *
1.1948 + * Results:
1.1949 + * See stat documentation.
1.1950 + *
1.1951 + * Side effects:
1.1952 + * See stat documentation.
1.1953 + *
1.1954 + *----------------------------------------------------------------------
1.1955 + */
1.1956 +
1.1957 +EXPORT_C int
1.1958 +Tcl_FSStat(pathPtr, buf)
1.1959 + Tcl_Obj *pathPtr; /* Path of file to stat (in current CP). */
1.1960 + Tcl_StatBuf *buf; /* Filled with results of stat call. */
1.1961 +{
1.1962 + Tcl_Filesystem *fsPtr;
1.1963 +#ifdef USE_OBSOLETE_FS_HOOKS
1.1964 + struct stat oldStyleStatBuffer;
1.1965 + int retVal = -1;
1.1966 +
1.1967 + /*
1.1968 + * Call each of the "stat" function in succession. A non-return
1.1969 + * value of -1 indicates the particular function has succeeded.
1.1970 + */
1.1971 +
1.1972 + Tcl_MutexLock(&obsoleteFsHookMutex);
1.1973 +
1.1974 + if (statProcList != NULL) {
1.1975 + StatProc *statProcPtr;
1.1976 + char *path;
1.1977 + Tcl_Obj *transPtr = Tcl_FSGetTranslatedPath(NULL, pathPtr);
1.1978 + if (transPtr == NULL) {
1.1979 + path = NULL;
1.1980 + } else {
1.1981 + path = Tcl_GetString(transPtr);
1.1982 + }
1.1983 +
1.1984 + statProcPtr = statProcList;
1.1985 + while ((retVal == -1) && (statProcPtr != NULL)) {
1.1986 + retVal = (*statProcPtr->proc)(path, &oldStyleStatBuffer);
1.1987 + statProcPtr = statProcPtr->nextPtr;
1.1988 + }
1.1989 + if (transPtr != NULL) {
1.1990 + Tcl_DecrRefCount(transPtr);
1.1991 + }
1.1992 + }
1.1993 +
1.1994 + Tcl_MutexUnlock(&obsoleteFsHookMutex);
1.1995 + if (retVal != -1) {
1.1996 + /*
1.1997 + * Note that EOVERFLOW is not a problem here, and these
1.1998 + * assignments should all be widening (if not identity.)
1.1999 + */
1.2000 + buf->st_mode = oldStyleStatBuffer.st_mode;
1.2001 + buf->st_ino = oldStyleStatBuffer.st_ino;
1.2002 + buf->st_dev = oldStyleStatBuffer.st_dev;
1.2003 + buf->st_rdev = oldStyleStatBuffer.st_rdev;
1.2004 + buf->st_nlink = oldStyleStatBuffer.st_nlink;
1.2005 + buf->st_uid = oldStyleStatBuffer.st_uid;
1.2006 + buf->st_gid = oldStyleStatBuffer.st_gid;
1.2007 + buf->st_size = Tcl_LongAsWide(oldStyleStatBuffer.st_size);
1.2008 + buf->st_atime = oldStyleStatBuffer.st_atime;
1.2009 + buf->st_mtime = oldStyleStatBuffer.st_mtime;
1.2010 + buf->st_ctime = oldStyleStatBuffer.st_ctime;
1.2011 +#ifdef HAVE_ST_BLOCKS
1.2012 + buf->st_blksize = oldStyleStatBuffer.st_blksize;
1.2013 + buf->st_blocks = Tcl_LongAsWide(oldStyleStatBuffer.st_blocks);
1.2014 +#endif
1.2015 + return retVal;
1.2016 + }
1.2017 +#endif /* USE_OBSOLETE_FS_HOOKS */
1.2018 + fsPtr = Tcl_FSGetFileSystemForPath(pathPtr);
1.2019 + if (fsPtr != NULL) {
1.2020 + Tcl_FSStatProc *proc = fsPtr->statProc;
1.2021 + if (proc != NULL) {
1.2022 + return (*proc)(pathPtr, buf);
1.2023 + }
1.2024 + }
1.2025 + Tcl_SetErrno(ENOENT);
1.2026 + return -1;
1.2027 +}
1.2028 +
1.2029 +/*
1.2030 + *----------------------------------------------------------------------
1.2031 + *
1.2032 + * Tcl_FSLstat --
1.2033 + *
1.2034 + * This procedure replaces the library version of lstat.
1.2035 + * The appropriate function for the filesystem to which pathPtr
1.2036 + * belongs will be called. If no 'lstat' function is listed,
1.2037 + * but a 'stat' function is, then Tcl will fall back on the
1.2038 + * stat function.
1.2039 + *
1.2040 + * Results:
1.2041 + * See lstat documentation.
1.2042 + *
1.2043 + * Side effects:
1.2044 + * See lstat documentation.
1.2045 + *
1.2046 + *----------------------------------------------------------------------
1.2047 + */
1.2048 +
1.2049 +EXPORT_C int
1.2050 +Tcl_FSLstat(pathPtr, buf)
1.2051 + Tcl_Obj *pathPtr; /* Path of file to stat (in current CP). */
1.2052 + Tcl_StatBuf *buf; /* Filled with results of stat call. */
1.2053 +{
1.2054 + Tcl_Filesystem *fsPtr = Tcl_FSGetFileSystemForPath(pathPtr);
1.2055 + if (fsPtr != NULL) {
1.2056 + Tcl_FSLstatProc *proc = fsPtr->lstatProc;
1.2057 + if (proc != NULL) {
1.2058 + return (*proc)(pathPtr, buf);
1.2059 + } else {
1.2060 + Tcl_FSStatProc *sproc = fsPtr->statProc;
1.2061 + if (sproc != NULL) {
1.2062 + return (*sproc)(pathPtr, buf);
1.2063 + }
1.2064 + }
1.2065 + }
1.2066 + Tcl_SetErrno(ENOENT);
1.2067 + return -1;
1.2068 +}
1.2069 +
1.2070 +/*
1.2071 + *----------------------------------------------------------------------
1.2072 + *
1.2073 + * Tcl_FSAccess --
1.2074 + *
1.2075 + * This procedure replaces the library version of access.
1.2076 + * The appropriate function for the filesystem to which pathPtr
1.2077 + * belongs will be called.
1.2078 + *
1.2079 + * Results:
1.2080 + * See access documentation.
1.2081 + *
1.2082 + * Side effects:
1.2083 + * See access documentation.
1.2084 + *
1.2085 + *----------------------------------------------------------------------
1.2086 + */
1.2087 +
1.2088 +EXPORT_C int
1.2089 +Tcl_FSAccess(pathPtr, mode)
1.2090 + Tcl_Obj *pathPtr; /* Path of file to access (in current CP). */
1.2091 + int mode; /* Permission setting. */
1.2092 +{
1.2093 + Tcl_Filesystem *fsPtr;
1.2094 +#ifdef USE_OBSOLETE_FS_HOOKS
1.2095 + int retVal = -1;
1.2096 +
1.2097 + /*
1.2098 + * Call each of the "access" function in succession. A non-return
1.2099 + * value of -1 indicates the particular function has succeeded.
1.2100 + */
1.2101 +
1.2102 + Tcl_MutexLock(&obsoleteFsHookMutex);
1.2103 +
1.2104 + if (accessProcList != NULL) {
1.2105 + AccessProc *accessProcPtr;
1.2106 + char *path;
1.2107 + Tcl_Obj *transPtr = Tcl_FSGetTranslatedPath(NULL, pathPtr);
1.2108 + if (transPtr == NULL) {
1.2109 + path = NULL;
1.2110 + } else {
1.2111 + path = Tcl_GetString(transPtr);
1.2112 + }
1.2113 +
1.2114 + accessProcPtr = accessProcList;
1.2115 + while ((retVal == -1) && (accessProcPtr != NULL)) {
1.2116 + retVal = (*accessProcPtr->proc)(path, mode);
1.2117 + accessProcPtr = accessProcPtr->nextPtr;
1.2118 + }
1.2119 + if (transPtr != NULL) {
1.2120 + Tcl_DecrRefCount(transPtr);
1.2121 + }
1.2122 + }
1.2123 +
1.2124 + Tcl_MutexUnlock(&obsoleteFsHookMutex);
1.2125 + if (retVal != -1) {
1.2126 + return retVal;
1.2127 + }
1.2128 +#endif /* USE_OBSOLETE_FS_HOOKS */
1.2129 + fsPtr = Tcl_FSGetFileSystemForPath(pathPtr);
1.2130 + if (fsPtr != NULL) {
1.2131 + Tcl_FSAccessProc *proc = fsPtr->accessProc;
1.2132 + if (proc != NULL) {
1.2133 + return (*proc)(pathPtr, mode);
1.2134 + }
1.2135 + }
1.2136 +
1.2137 + Tcl_SetErrno(ENOENT);
1.2138 + return -1;
1.2139 +}
1.2140 +
1.2141 +/*
1.2142 + *----------------------------------------------------------------------
1.2143 + *
1.2144 + * Tcl_FSOpenFileChannel --
1.2145 + *
1.2146 + * The appropriate function for the filesystem to which pathPtr
1.2147 + * belongs will be called.
1.2148 + *
1.2149 + * Results:
1.2150 + * The new channel or NULL, if the named file could not be opened.
1.2151 + *
1.2152 + * Side effects:
1.2153 + * May open the channel and may cause creation of a file on the
1.2154 + * file system.
1.2155 + *
1.2156 + *----------------------------------------------------------------------
1.2157 + */
1.2158 +
1.2159 +EXPORT_C Tcl_Channel
1.2160 +Tcl_FSOpenFileChannel(interp, pathPtr, modeString, permissions)
1.2161 + Tcl_Interp *interp; /* Interpreter for error reporting;
1.2162 + * can be NULL. */
1.2163 + Tcl_Obj *pathPtr; /* Name of file to open. */
1.2164 + CONST char *modeString; /* A list of POSIX open modes or
1.2165 + * a string such as "rw". */
1.2166 + int permissions; /* If the open involves creating a
1.2167 + * file, with what modes to create
1.2168 + * it? */
1.2169 +{
1.2170 + Tcl_Filesystem *fsPtr;
1.2171 +#ifdef USE_OBSOLETE_FS_HOOKS
1.2172 + Tcl_Channel retVal = NULL;
1.2173 +
1.2174 + /*
1.2175 + * Call each of the "Tcl_OpenFileChannel" functions in succession.
1.2176 + * A non-NULL return value indicates the particular function has
1.2177 + * succeeded.
1.2178 + */
1.2179 +
1.2180 + Tcl_MutexLock(&obsoleteFsHookMutex);
1.2181 + if (openFileChannelProcList != NULL) {
1.2182 + OpenFileChannelProc *openFileChannelProcPtr;
1.2183 + char *path;
1.2184 + Tcl_Obj *transPtr = Tcl_FSGetTranslatedPath(interp, pathPtr);
1.2185 +
1.2186 + if (transPtr == NULL) {
1.2187 + path = NULL;
1.2188 + } else {
1.2189 + path = Tcl_GetString(transPtr);
1.2190 + }
1.2191 +
1.2192 + openFileChannelProcPtr = openFileChannelProcList;
1.2193 +
1.2194 + while ((retVal == NULL) && (openFileChannelProcPtr != NULL)) {
1.2195 + retVal = (*openFileChannelProcPtr->proc)(interp, path,
1.2196 + modeString, permissions);
1.2197 + openFileChannelProcPtr = openFileChannelProcPtr->nextPtr;
1.2198 + }
1.2199 + if (transPtr != NULL) {
1.2200 + Tcl_DecrRefCount(transPtr);
1.2201 + }
1.2202 + }
1.2203 + Tcl_MutexUnlock(&obsoleteFsHookMutex);
1.2204 + if (retVal != NULL) {
1.2205 + return retVal;
1.2206 + }
1.2207 +#endif /* USE_OBSOLETE_FS_HOOKS */
1.2208 +
1.2209 + /*
1.2210 + * We need this just to ensure we return the correct error messages
1.2211 + * under some circumstances.
1.2212 + */
1.2213 + if (Tcl_FSGetNormalizedPath(interp, pathPtr) == NULL) {
1.2214 + return NULL;
1.2215 + }
1.2216 +
1.2217 + fsPtr = Tcl_FSGetFileSystemForPath(pathPtr);
1.2218 + if (fsPtr != NULL) {
1.2219 + Tcl_FSOpenFileChannelProc *proc = fsPtr->openFileChannelProc;
1.2220 + if (proc != NULL) {
1.2221 + int mode, seekFlag;
1.2222 + mode = TclGetOpenMode(interp, modeString, &seekFlag);
1.2223 + if (mode == -1) {
1.2224 + return NULL;
1.2225 + }
1.2226 + retVal = (*proc)(interp, pathPtr, mode, permissions);
1.2227 + if (retVal != NULL) {
1.2228 + if (seekFlag) {
1.2229 + if (Tcl_Seek(retVal, (Tcl_WideInt)0,
1.2230 + SEEK_END) < (Tcl_WideInt)0) {
1.2231 + if (interp != (Tcl_Interp *) NULL) {
1.2232 + Tcl_AppendResult(interp,
1.2233 + "could not seek to end of file while opening \"",
1.2234 + Tcl_GetString(pathPtr), "\": ",
1.2235 + Tcl_PosixError(interp), (char *) NULL);
1.2236 + }
1.2237 + Tcl_Close(NULL, retVal);
1.2238 + return NULL;
1.2239 + }
1.2240 + }
1.2241 + }
1.2242 + return retVal;
1.2243 + }
1.2244 + }
1.2245 + /* File doesn't belong to any filesystem that can open it */
1.2246 + Tcl_SetErrno(ENOENT);
1.2247 + if (interp != NULL) {
1.2248 + Tcl_AppendResult(interp, "couldn't open \"",
1.2249 + Tcl_GetString(pathPtr), "\": ",
1.2250 + Tcl_PosixError(interp), (char *) NULL);
1.2251 + }
1.2252 + return NULL;
1.2253 +}
1.2254 +
1.2255 +/*
1.2256 + *----------------------------------------------------------------------
1.2257 + *
1.2258 + * Tcl_FSUtime --
1.2259 + *
1.2260 + * This procedure replaces the library version of utime.
1.2261 + * The appropriate function for the filesystem to which pathPtr
1.2262 + * belongs will be called.
1.2263 + *
1.2264 + * Results:
1.2265 + * See utime documentation.
1.2266 + *
1.2267 + * Side effects:
1.2268 + * See utime documentation.
1.2269 + *
1.2270 + *----------------------------------------------------------------------
1.2271 + */
1.2272 +
1.2273 +EXPORT_C int
1.2274 +Tcl_FSUtime (pathPtr, tval)
1.2275 + Tcl_Obj *pathPtr; /* File to change access/modification times */
1.2276 + struct utimbuf *tval; /* Structure containing access/modification
1.2277 + * times to use. Should not be modified. */
1.2278 +{
1.2279 + Tcl_Filesystem *fsPtr = Tcl_FSGetFileSystemForPath(pathPtr);
1.2280 + if (fsPtr != NULL) {
1.2281 + Tcl_FSUtimeProc *proc = fsPtr->utimeProc;
1.2282 + if (proc != NULL) {
1.2283 + return (*proc)(pathPtr, tval);
1.2284 + }
1.2285 + }
1.2286 + return -1;
1.2287 +}
1.2288 +
1.2289 +/*
1.2290 + *----------------------------------------------------------------------
1.2291 + *
1.2292 + * NativeFileAttrStrings --
1.2293 + *
1.2294 + * This procedure implements the platform dependent 'file
1.2295 + * attributes' subcommand, for the native filesystem, for listing
1.2296 + * the set of possible attribute strings. This function is part
1.2297 + * of Tcl's native filesystem support, and is placed here because
1.2298 + * it is shared by Unix, MacOS and Windows code.
1.2299 + *
1.2300 + * Results:
1.2301 + * An array of strings
1.2302 + *
1.2303 + * Side effects:
1.2304 + * None.
1.2305 + *
1.2306 + *----------------------------------------------------------------------
1.2307 + */
1.2308 +
1.2309 +static CONST char**
1.2310 +NativeFileAttrStrings(pathPtr, objPtrRef)
1.2311 + Tcl_Obj *pathPtr;
1.2312 + Tcl_Obj** objPtrRef;
1.2313 +{
1.2314 + return tclpFileAttrStrings;
1.2315 +}
1.2316 +
1.2317 +/*
1.2318 + *----------------------------------------------------------------------
1.2319 + *
1.2320 + * NativeFileAttrsGet --
1.2321 + *
1.2322 + * This procedure implements the platform dependent
1.2323 + * 'file attributes' subcommand, for the native
1.2324 + * filesystem, for 'get' operations. This function is part
1.2325 + * of Tcl's native filesystem support, and is placed here
1.2326 + * because it is shared by Unix, MacOS and Windows code.
1.2327 + *
1.2328 + * Results:
1.2329 + * Standard Tcl return code. The object placed in objPtrRef
1.2330 + * (if TCL_OK was returned) is likely to have a refCount of zero.
1.2331 + * Either way we must either store it somewhere (e.g. the Tcl
1.2332 + * result), or Incr/Decr its refCount to ensure it is properly
1.2333 + * freed.
1.2334 + *
1.2335 + * Side effects:
1.2336 + * None.
1.2337 + *
1.2338 + *----------------------------------------------------------------------
1.2339 + */
1.2340 +
1.2341 +static int
1.2342 +NativeFileAttrsGet(interp, index, pathPtr, objPtrRef)
1.2343 + Tcl_Interp *interp; /* The interpreter for error reporting. */
1.2344 + int index; /* index of the attribute command. */
1.2345 + Tcl_Obj *pathPtr; /* path of file we are operating on. */
1.2346 + Tcl_Obj **objPtrRef; /* for output. */
1.2347 +{
1.2348 + return (*tclpFileAttrProcs[index].getProc)(interp, index,
1.2349 + pathPtr, objPtrRef);
1.2350 +}
1.2351 +
1.2352 +/*
1.2353 + *----------------------------------------------------------------------
1.2354 + *
1.2355 + * NativeFileAttrsSet --
1.2356 + *
1.2357 + * This procedure implements the platform dependent
1.2358 + * 'file attributes' subcommand, for the native
1.2359 + * filesystem, for 'set' operations. This function is part
1.2360 + * of Tcl's native filesystem support, and is placed here
1.2361 + * because it is shared by Unix, MacOS and Windows code.
1.2362 + *
1.2363 + * Results:
1.2364 + * Standard Tcl return code.
1.2365 + *
1.2366 + * Side effects:
1.2367 + * None.
1.2368 + *
1.2369 + *----------------------------------------------------------------------
1.2370 + */
1.2371 +
1.2372 +static int
1.2373 +NativeFileAttrsSet(interp, index, pathPtr, objPtr)
1.2374 + Tcl_Interp *interp; /* The interpreter for error reporting. */
1.2375 + int index; /* index of the attribute command. */
1.2376 + Tcl_Obj *pathPtr; /* path of file we are operating on. */
1.2377 + Tcl_Obj *objPtr; /* set to this value. */
1.2378 +{
1.2379 + return (*tclpFileAttrProcs[index].setProc)(interp, index,
1.2380 + pathPtr, objPtr);
1.2381 +}
1.2382 +
1.2383 +/*
1.2384 + *----------------------------------------------------------------------
1.2385 + *
1.2386 + * Tcl_FSFileAttrStrings --
1.2387 + *
1.2388 + * This procedure implements part of the hookable 'file
1.2389 + * attributes' subcommand. The appropriate function for the
1.2390 + * filesystem to which pathPtr belongs will be called.
1.2391 + *
1.2392 + * Results:
1.2393 + * The called procedure may either return an array of strings,
1.2394 + * or may instead return NULL and place a Tcl list into the
1.2395 + * given objPtrRef. Tcl will take that list and first increment
1.2396 + * its refCount before using it. On completion of that use, Tcl
1.2397 + * will decrement its refCount. Hence if the list should be
1.2398 + * disposed of by Tcl when done, it should have a refCount of zero,
1.2399 + * and if the list should not be disposed of, the filesystem
1.2400 + * should ensure it retains a refCount on the object.
1.2401 + *
1.2402 + * Side effects:
1.2403 + * None.
1.2404 + *
1.2405 + *----------------------------------------------------------------------
1.2406 + */
1.2407 +
1.2408 +EXPORT_C CONST char **
1.2409 +Tcl_FSFileAttrStrings(pathPtr, objPtrRef)
1.2410 + Tcl_Obj* pathPtr;
1.2411 + Tcl_Obj** objPtrRef;
1.2412 +{
1.2413 + Tcl_Filesystem *fsPtr = Tcl_FSGetFileSystemForPath(pathPtr);
1.2414 + if (fsPtr != NULL) {
1.2415 + Tcl_FSFileAttrStringsProc *proc = fsPtr->fileAttrStringsProc;
1.2416 + if (proc != NULL) {
1.2417 + return (*proc)(pathPtr, objPtrRef);
1.2418 + }
1.2419 + }
1.2420 + Tcl_SetErrno(ENOENT);
1.2421 + return NULL;
1.2422 +}
1.2423 +
1.2424 +/*
1.2425 + *----------------------------------------------------------------------
1.2426 + *
1.2427 + * Tcl_FSFileAttrsGet --
1.2428 + *
1.2429 + * This procedure implements read access for the hookable 'file
1.2430 + * attributes' subcommand. The appropriate function for the
1.2431 + * filesystem to which pathPtr belongs will be called.
1.2432 + *
1.2433 + * Results:
1.2434 + * Standard Tcl return code. The object placed in objPtrRef
1.2435 + * (if TCL_OK was returned) is likely to have a refCount of zero.
1.2436 + * Either way we must either store it somewhere (e.g. the Tcl
1.2437 + * result), or Incr/Decr its refCount to ensure it is properly
1.2438 + * freed.
1.2439 +
1.2440 + *
1.2441 + * Side effects:
1.2442 + * None.
1.2443 + *
1.2444 + *----------------------------------------------------------------------
1.2445 + */
1.2446 +
1.2447 +EXPORT_C int
1.2448 +Tcl_FSFileAttrsGet(interp, index, pathPtr, objPtrRef)
1.2449 + Tcl_Interp *interp; /* The interpreter for error reporting. */
1.2450 + int index; /* index of the attribute command. */
1.2451 + Tcl_Obj *pathPtr; /* filename we are operating on. */
1.2452 + Tcl_Obj **objPtrRef; /* for output. */
1.2453 +{
1.2454 + Tcl_Filesystem *fsPtr = Tcl_FSGetFileSystemForPath(pathPtr);
1.2455 + if (fsPtr != NULL) {
1.2456 + Tcl_FSFileAttrsGetProc *proc = fsPtr->fileAttrsGetProc;
1.2457 + if (proc != NULL) {
1.2458 + return (*proc)(interp, index, pathPtr, objPtrRef);
1.2459 + }
1.2460 + }
1.2461 + Tcl_SetErrno(ENOENT);
1.2462 + return -1;
1.2463 +}
1.2464 +
1.2465 +/*
1.2466 + *----------------------------------------------------------------------
1.2467 + *
1.2468 + * Tcl_FSFileAttrsSet --
1.2469 + *
1.2470 + * This procedure implements write access for the hookable 'file
1.2471 + * attributes' subcommand. The appropriate function for the
1.2472 + * filesystem to which pathPtr belongs will be called.
1.2473 + *
1.2474 + * Results:
1.2475 + * Standard Tcl return code.
1.2476 + *
1.2477 + * Side effects:
1.2478 + * None.
1.2479 + *
1.2480 + *----------------------------------------------------------------------
1.2481 + */
1.2482 +
1.2483 +EXPORT_C int
1.2484 +Tcl_FSFileAttrsSet(interp, index, pathPtr, objPtr)
1.2485 + Tcl_Interp *interp; /* The interpreter for error reporting. */
1.2486 + int index; /* index of the attribute command. */
1.2487 + Tcl_Obj *pathPtr; /* filename we are operating on. */
1.2488 + Tcl_Obj *objPtr; /* Input value. */
1.2489 +{
1.2490 + Tcl_Filesystem *fsPtr = Tcl_FSGetFileSystemForPath(pathPtr);
1.2491 + if (fsPtr != NULL) {
1.2492 + Tcl_FSFileAttrsSetProc *proc = fsPtr->fileAttrsSetProc;
1.2493 + if (proc != NULL) {
1.2494 + return (*proc)(interp, index, pathPtr, objPtr);
1.2495 + }
1.2496 + }
1.2497 + Tcl_SetErrno(ENOENT);
1.2498 + return -1;
1.2499 +}
1.2500 +
1.2501 +/*
1.2502 + *----------------------------------------------------------------------
1.2503 + *
1.2504 + * Tcl_FSGetCwd --
1.2505 + *
1.2506 + * This function replaces the library version of getcwd().
1.2507 + *
1.2508 + * Most VFS's will *not* implement a 'cwdProc'. Tcl now maintains
1.2509 + * its own record (in a Tcl_Obj) of the cwd, and an attempt
1.2510 + * is made to synchronise this with the cwd's containing filesystem,
1.2511 + * if that filesystem provides a cwdProc (e.g. the native filesystem).
1.2512 + *
1.2513 + * Note that if Tcl's cwd is not in the native filesystem, then of
1.2514 + * course Tcl's cwd and the native cwd are different: extensions
1.2515 + * should therefore ensure they only access the cwd through this
1.2516 + * function to avoid confusion.
1.2517 + *
1.2518 + * If a global cwdPathPtr already exists, it is cached in the thread's
1.2519 + * private data structures and reference to the cached copy is returned,
1.2520 + * subject to a synchronisation attempt in that cwdPathPtr's fs.
1.2521 + *
1.2522 + * Otherwise, the chain of functions that have been "inserted"
1.2523 + * into the filesystem will be called in succession until either a
1.2524 + * value other than NULL is returned, or the entire list is
1.2525 + * visited.
1.2526 + *
1.2527 + * Results:
1.2528 + * The result is a pointer to a Tcl_Obj specifying the current
1.2529 + * directory, or NULL if the current directory could not be
1.2530 + * determined. If NULL is returned, an error message is left in the
1.2531 + * interp's result.
1.2532 + *
1.2533 + * The result already has its refCount incremented for the caller.
1.2534 + * When it is no longer needed, that refCount should be decremented.
1.2535 + *
1.2536 + * Side effects:
1.2537 + * Various objects may be freed and allocated.
1.2538 + *
1.2539 + *----------------------------------------------------------------------
1.2540 + */
1.2541 +
1.2542 +EXPORT_C Tcl_Obj*
1.2543 +Tcl_FSGetCwd(interp)
1.2544 + Tcl_Interp *interp;
1.2545 +{
1.2546 + ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);
1.2547 +
1.2548 + if (TclFSCwdPointerEquals(NULL)) {
1.2549 + FilesystemRecord *fsRecPtr;
1.2550 + Tcl_Obj *retVal = NULL;
1.2551 +
1.2552 + /*
1.2553 + * We've never been called before, try to find a cwd. Call
1.2554 + * each of the "Tcl_GetCwd" function in succession. A non-NULL
1.2555 + * return value indicates the particular function has
1.2556 + * succeeded.
1.2557 + */
1.2558 +
1.2559 + fsRecPtr = FsGetFirstFilesystem();
1.2560 + while ((retVal == NULL) && (fsRecPtr != NULL)) {
1.2561 + Tcl_FSGetCwdProc *proc = fsRecPtr->fsPtr->getCwdProc;
1.2562 + if (proc != NULL) {
1.2563 + retVal = (*proc)(interp);
1.2564 + }
1.2565 + fsRecPtr = fsRecPtr->nextPtr;
1.2566 + }
1.2567 + /*
1.2568 + * Now the 'cwd' may NOT be normalized, at least on some
1.2569 + * platforms. For the sake of efficiency, we want a completely
1.2570 + * normalized cwd at all times.
1.2571 + *
1.2572 + * Finally, if retVal is NULL, we do not have a cwd, which
1.2573 + * could be problematic.
1.2574 + */
1.2575 + if (retVal != NULL) {
1.2576 + Tcl_Obj *norm = TclFSNormalizeAbsolutePath(interp, retVal, NULL);
1.2577 + if (norm != NULL) {
1.2578 + /*
1.2579 + * We found a cwd, which is now in our global storage.
1.2580 + * We must make a copy. Norm already has a refCount of 1.
1.2581 + *
1.2582 + * Threading issue: note that multiple threads at system
1.2583 + * startup could in principle call this procedure
1.2584 + * simultaneously. They will therefore each set the
1.2585 + * cwdPathPtr independently. That behaviour is a bit
1.2586 + * peculiar, but should be fine. Once we have a cwd,
1.2587 + * we'll always be in the 'else' branch below which
1.2588 + * is simpler.
1.2589 + */
1.2590 + FsUpdateCwd(norm);
1.2591 + Tcl_DecrRefCount(norm);
1.2592 + }
1.2593 + Tcl_DecrRefCount(retVal);
1.2594 + }
1.2595 + } else {
1.2596 + /*
1.2597 + * We already have a cwd cached, but we want to give the
1.2598 + * filesystem it is in a chance to check whether that cwd
1.2599 + * has changed, or is perhaps no longer accessible. This
1.2600 + * allows an error to be thrown if, say, the permissions on
1.2601 + * that directory have changed.
1.2602 + */
1.2603 + Tcl_Filesystem *fsPtr = Tcl_FSGetFileSystemForPath(tsdPtr->cwdPathPtr);
1.2604 + /*
1.2605 + * If the filesystem couldn't be found, or if no cwd function
1.2606 + * exists for this filesystem, then we simply assume the cached
1.2607 + * cwd is ok. If we do call a cwd, we must watch for errors
1.2608 + * (if the cwd returns NULL). This ensures that, say, on Unix
1.2609 + * if the permissions of the cwd change, 'pwd' does actually
1.2610 + * throw the correct error in Tcl. (This is tested for in the
1.2611 + * test suite on unix).
1.2612 + */
1.2613 + if (fsPtr != NULL) {
1.2614 + Tcl_FSGetCwdProc *proc = fsPtr->getCwdProc;
1.2615 + if (proc != NULL) {
1.2616 + Tcl_Obj *retVal = (*proc)(interp);
1.2617 + if (retVal != NULL) {
1.2618 + Tcl_Obj *norm = TclFSNormalizeAbsolutePath(interp, retVal, NULL);
1.2619 + /*
1.2620 + * Check whether cwd has changed from the value
1.2621 + * previously stored in cwdPathPtr. Really 'norm'
1.2622 + * shouldn't be null, but we are careful.
1.2623 + */
1.2624 + if (norm == NULL) {
1.2625 + /* Do nothing */
1.2626 + } else if (Tcl_FSEqualPaths(tsdPtr->cwdPathPtr, norm)) {
1.2627 + /*
1.2628 + * If the paths were equal, we can be more
1.2629 + * efficient and retain the old path object
1.2630 + * which will probably already be shared. In
1.2631 + * this case we can simply free the normalized
1.2632 + * path we just calculated.
1.2633 + */
1.2634 + Tcl_DecrRefCount(norm);
1.2635 + } else {
1.2636 + FsUpdateCwd(norm);
1.2637 + Tcl_DecrRefCount(norm);
1.2638 + }
1.2639 + Tcl_DecrRefCount(retVal);
1.2640 + } else {
1.2641 + /* The 'cwd' function returned an error; reset the cwd */
1.2642 + FsUpdateCwd(NULL);
1.2643 + }
1.2644 + }
1.2645 + }
1.2646 + }
1.2647 +
1.2648 + if (tsdPtr->cwdPathPtr != NULL) {
1.2649 + Tcl_IncrRefCount(tsdPtr->cwdPathPtr);
1.2650 + }
1.2651 +
1.2652 + return tsdPtr->cwdPathPtr;
1.2653 +}
1.2654 +
1.2655 +/*
1.2656 + *----------------------------------------------------------------------
1.2657 + *
1.2658 + * Tcl_FSChdir --
1.2659 + *
1.2660 + * This function replaces the library version of chdir().
1.2661 + *
1.2662 + * The path is normalized and then passed to the filesystem
1.2663 + * which claims it.
1.2664 + *
1.2665 + * Results:
1.2666 + * See chdir() documentation. If successful, we keep a
1.2667 + * record of the successful path in cwdPathPtr for subsequent
1.2668 + * calls to getcwd.
1.2669 + *
1.2670 + * Side effects:
1.2671 + * See chdir() documentation. The global cwdPathPtr may
1.2672 + * change value.
1.2673 + *
1.2674 + *----------------------------------------------------------------------
1.2675 + */
1.2676 +EXPORT_C int
1.2677 +Tcl_FSChdir(pathPtr)
1.2678 + Tcl_Obj *pathPtr;
1.2679 +{
1.2680 + Tcl_Filesystem *fsPtr;
1.2681 + int retVal = -1;
1.2682 +
1.2683 +#ifdef WIN32
1.2684 + /*
1.2685 + * This complete hack addresses the bug tested in winFCmd-16.12,
1.2686 + * where having your HOME as "C:" (IOW, a seemingly path relative
1.2687 + * dir) would cause a crash when you cd'd to it and requested 'pwd'.
1.2688 + * The work-around is to force such a dir into an absolute path by
1.2689 + * tacking on '/'.
1.2690 + *
1.2691 + * We check for '~' specifically because that's what Tcl_CdObjCmd
1.2692 + * passes in that triggers the bug. A direct 'cd C:' call will not
1.2693 + * because that gets the volumerelative pwd.
1.2694 + *
1.2695 + * This is not an issue for 8.5 as that has a more elaborate change
1.2696 + * that requires the use of TCL_FILESYSTEM_VERSION_2.
1.2697 + */
1.2698 + Tcl_Obj *objPtr = NULL;
1.2699 + if (pathPtr->bytes && pathPtr->length == 1 && pathPtr->bytes[0] == '~') {
1.2700 + int len;
1.2701 + char *str;
1.2702 +
1.2703 + objPtr = Tcl_FSGetTranslatedPath(NULL, pathPtr);
1.2704 + if (objPtr == NULL) {
1.2705 + Tcl_SetErrno(ENOENT);
1.2706 + return -1;
1.2707 + }
1.2708 + Tcl_IncrRefCount(objPtr);
1.2709 + str = Tcl_GetStringFromObj(objPtr, &len);
1.2710 + if (len == 2 && str[1] == ':') {
1.2711 + pathPtr = Tcl_NewStringObj(str, len);
1.2712 + Tcl_AppendToObj(pathPtr, "/", 1);
1.2713 + Tcl_IncrRefCount(pathPtr);
1.2714 + Tcl_DecrRefCount(objPtr);
1.2715 + objPtr = pathPtr;
1.2716 + } else {
1.2717 + Tcl_DecrRefCount(objPtr);
1.2718 + objPtr = NULL;
1.2719 + }
1.2720 + }
1.2721 +#endif
1.2722 + if (Tcl_FSGetNormalizedPath(NULL, pathPtr) == NULL) {
1.2723 +#ifdef WIN32
1.2724 + if (objPtr) { Tcl_DecrRefCount(objPtr); }
1.2725 +#endif
1.2726 + Tcl_SetErrno(ENOENT);
1.2727 + return -1;
1.2728 + }
1.2729 +
1.2730 + fsPtr = Tcl_FSGetFileSystemForPath(pathPtr);
1.2731 + if (fsPtr != NULL) {
1.2732 + Tcl_FSChdirProc *proc = fsPtr->chdirProc;
1.2733 + if (proc != NULL) {
1.2734 + retVal = (*proc)(pathPtr);
1.2735 + } else {
1.2736 + /* Fallback on stat-based implementation */
1.2737 + Tcl_StatBuf buf;
1.2738 + /* If the file can be stat'ed and is a directory and
1.2739 + * is readable, then we can chdir. */
1.2740 + if ((Tcl_FSStat(pathPtr, &buf) == 0)
1.2741 + && (S_ISDIR(buf.st_mode))
1.2742 + && (Tcl_FSAccess(pathPtr, R_OK) == 0)) {
1.2743 + /* We allow the chdir */
1.2744 + retVal = 0;
1.2745 + }
1.2746 + }
1.2747 + }
1.2748 +
1.2749 + if (retVal != -1) {
1.2750 + /*
1.2751 + * The cwd changed, or an error was thrown. If an error was
1.2752 + * thrown, we can just continue (and that will report the error
1.2753 + * to the user). If there was no error we must assume that the
1.2754 + * cwd was actually changed to the normalized value we
1.2755 + * calculated above, and we must therefore cache that
1.2756 + * information.
1.2757 + */
1.2758 + if (retVal == 0) {
1.2759 + /*
1.2760 + * Note that this normalized path may be different to what
1.2761 + * we found above (or at least a different object), if the
1.2762 + * filesystem epoch changed recently. This can actually
1.2763 + * happen with scripted documents very easily. Therefore
1.2764 + * we ask for the normalized path again (the correct value
1.2765 + * will have been cached as a result of the
1.2766 + * Tcl_FSGetFileSystemForPath call above anyway).
1.2767 + */
1.2768 + Tcl_Obj *normDirName = Tcl_FSGetNormalizedPath(NULL, pathPtr);
1.2769 + if (normDirName == NULL) {
1.2770 +#ifdef WIN32
1.2771 + if (objPtr) { Tcl_DecrRefCount(objPtr); }
1.2772 +#endif
1.2773 + Tcl_SetErrno(ENOENT);
1.2774 + return -1;
1.2775 + }
1.2776 + FsUpdateCwd(normDirName);
1.2777 + }
1.2778 + } else {
1.2779 + Tcl_SetErrno(ENOENT);
1.2780 + }
1.2781 +
1.2782 +#ifdef WIN32
1.2783 + if (objPtr) { Tcl_DecrRefCount(objPtr); }
1.2784 +#endif
1.2785 + return (retVal);
1.2786 +}
1.2787 +
1.2788 +/*
1.2789 + *----------------------------------------------------------------------
1.2790 + *
1.2791 + * Tcl_FSLoadFile --
1.2792 + *
1.2793 + * Dynamically loads a binary code file into memory and returns
1.2794 + * the addresses of two procedures within that file, if they are
1.2795 + * defined. The appropriate function for the filesystem to which
1.2796 + * pathPtr belongs will be called.
1.2797 + *
1.2798 + * Note that the native filesystem doesn't actually assume
1.2799 + * 'pathPtr' is a path. Rather it assumes filename is either
1.2800 + * a path or just the name of a file which can be found somewhere
1.2801 + * in the environment's loadable path. This behaviour is not
1.2802 + * very compatible with virtual filesystems (and has other problems
1.2803 + * documented in the load man-page), so it is advised that full
1.2804 + * paths are always used.
1.2805 + *
1.2806 + * Results:
1.2807 + * A standard Tcl completion code. If an error occurs, an error
1.2808 + * message is left in the interp's result.
1.2809 + *
1.2810 + * Side effects:
1.2811 + * New code suddenly appears in memory. This may later be
1.2812 + * unloaded by passing the clientData to the unloadProc.
1.2813 + *
1.2814 + *----------------------------------------------------------------------
1.2815 + */
1.2816 +
1.2817 +EXPORT_C int
1.2818 +Tcl_FSLoadFile(interp, pathPtr, sym1, sym2, proc1Ptr, proc2Ptr,
1.2819 + handlePtr, unloadProcPtr)
1.2820 + Tcl_Interp *interp; /* Used for error reporting. */
1.2821 + Tcl_Obj *pathPtr; /* Name of the file containing the desired
1.2822 + * code. */
1.2823 + CONST char *sym1, *sym2; /* Names of two procedures to look up in
1.2824 + * the file's symbol table. */
1.2825 + Tcl_PackageInitProc **proc1Ptr, **proc2Ptr;
1.2826 + /* Where to return the addresses corresponding
1.2827 + * to sym1 and sym2. */
1.2828 + Tcl_LoadHandle *handlePtr; /* Filled with token for dynamically loaded
1.2829 + * file which will be passed back to
1.2830 + * (*unloadProcPtr)() to unload the file. */
1.2831 + Tcl_FSUnloadFileProc **unloadProcPtr;
1.2832 + /* Filled with address of Tcl_FSUnloadFileProc
1.2833 + * function which should be used for
1.2834 + * this file. */
1.2835 +{
1.2836 + Tcl_Filesystem *fsPtr = Tcl_FSGetFileSystemForPath(pathPtr);
1.2837 + if (fsPtr != NULL) {
1.2838 + Tcl_FSLoadFileProc *proc = fsPtr->loadFileProc;
1.2839 + if (proc != NULL) {
1.2840 + int retVal = (*proc)(interp, pathPtr, handlePtr, unloadProcPtr);
1.2841 + if (retVal != TCL_OK) {
1.2842 + return retVal;
1.2843 + }
1.2844 + if (*handlePtr == NULL) {
1.2845 + return TCL_ERROR;
1.2846 + }
1.2847 + if (sym1 != NULL) {
1.2848 + *proc1Ptr = TclpFindSymbol(interp, *handlePtr, sym1);
1.2849 + }
1.2850 + if (sym2 != NULL) {
1.2851 + *proc2Ptr = TclpFindSymbol(interp, *handlePtr, sym2);
1.2852 + }
1.2853 + return retVal;
1.2854 + } else {
1.2855 + Tcl_Filesystem *copyFsPtr;
1.2856 + Tcl_Obj *copyToPtr;
1.2857 +
1.2858 + /* First check if it is readable -- and exists! */
1.2859 + if (Tcl_FSAccess(pathPtr, R_OK) != 0) {
1.2860 + Tcl_AppendResult(interp, "couldn't load library \"",
1.2861 + Tcl_GetString(pathPtr), "\": ",
1.2862 + Tcl_PosixError(interp), (char *) NULL);
1.2863 + return TCL_ERROR;
1.2864 + }
1.2865 +
1.2866 +#ifdef TCL_LOAD_FROM_MEMORY
1.2867 + /*
1.2868 + * The platform supports loading code from memory, so ask for a
1.2869 + * buffer of the appropriate size, read the file into it and
1.2870 + * load the code from the buffer:
1.2871 + */
1.2872 + do {
1.2873 + int ret, size;
1.2874 + void *buffer;
1.2875 + Tcl_StatBuf statBuf;
1.2876 + Tcl_Channel data;
1.2877 +
1.2878 + ret = Tcl_FSStat(pathPtr, &statBuf);
1.2879 + if (ret < 0) {
1.2880 + break;
1.2881 + }
1.2882 + size = (int) statBuf.st_size;
1.2883 + /* Tcl_Read takes an int: check that file size isn't wide */
1.2884 + if (size != (Tcl_WideInt)statBuf.st_size) {
1.2885 + break;
1.2886 + }
1.2887 + data = Tcl_FSOpenFileChannel(interp, pathPtr, "r", 0666);
1.2888 + if (!data) {
1.2889 + break;
1.2890 + }
1.2891 + buffer = TclpLoadMemoryGetBuffer(interp, size);
1.2892 + if (!buffer) {
1.2893 + Tcl_Close(interp, data);
1.2894 + break;
1.2895 + }
1.2896 + Tcl_SetChannelOption(interp, data, "-translation", "binary");
1.2897 + ret = Tcl_Read(data, buffer, size);
1.2898 + Tcl_Close(interp, data);
1.2899 + ret = TclpLoadMemory(interp, buffer, size, ret, handlePtr, unloadProcPtr);
1.2900 + if (ret == TCL_OK) {
1.2901 + if (*handlePtr == NULL) {
1.2902 + break;
1.2903 + }
1.2904 + if (sym1 != NULL) {
1.2905 + *proc1Ptr = TclpFindSymbol(interp, *handlePtr, sym1);
1.2906 + }
1.2907 + if (sym2 != NULL) {
1.2908 + *proc2Ptr = TclpFindSymbol(interp, *handlePtr, sym2);
1.2909 + }
1.2910 + return TCL_OK;
1.2911 + }
1.2912 + } while (0);
1.2913 + Tcl_ResetResult(interp);
1.2914 +#endif
1.2915 +
1.2916 + /*
1.2917 + * Get a temporary filename to use, first to
1.2918 + * copy the file into, and then to load.
1.2919 + */
1.2920 + copyToPtr = TclpTempFileName();
1.2921 + if (copyToPtr == NULL) {
1.2922 + return -1;
1.2923 + }
1.2924 + Tcl_IncrRefCount(copyToPtr);
1.2925 +
1.2926 + copyFsPtr = Tcl_FSGetFileSystemForPath(copyToPtr);
1.2927 + if ((copyFsPtr == NULL) || (copyFsPtr == fsPtr)) {
1.2928 + /*
1.2929 + * We already know we can't use Tcl_FSLoadFile from
1.2930 + * this filesystem, and we must avoid a possible
1.2931 + * infinite loop. Try to delete the file we
1.2932 + * probably created, and then exit.
1.2933 + */
1.2934 + Tcl_FSDeleteFile(copyToPtr);
1.2935 + Tcl_DecrRefCount(copyToPtr);
1.2936 + return -1;
1.2937 + }
1.2938 +
1.2939 + if (TclCrossFilesystemCopy(interp, pathPtr,
1.2940 + copyToPtr) == TCL_OK) {
1.2941 + Tcl_LoadHandle newLoadHandle = NULL;
1.2942 + Tcl_FSUnloadFileProc *newUnloadProcPtr = NULL;
1.2943 + FsDivertLoad *tvdlPtr;
1.2944 + int retVal;
1.2945 +
1.2946 +#if !defined(__WIN32__) && !defined(MAC_TCL)
1.2947 + /*
1.2948 + * Do we need to set appropriate permissions
1.2949 + * on the file? This may be required on some
1.2950 + * systems. On Unix we could loop over
1.2951 + * the file attributes, and set any that are
1.2952 + * called "-permissions" to 0700. However,
1.2953 + * we just do this directly, like this:
1.2954 + */
1.2955 +
1.2956 + Tcl_Obj* perm = Tcl_NewStringObj("0700",-1);
1.2957 + Tcl_IncrRefCount(perm);
1.2958 + Tcl_FSFileAttrsSet(NULL, 2, copyToPtr, perm);
1.2959 + Tcl_DecrRefCount(perm);
1.2960 +#endif
1.2961 +
1.2962 + /*
1.2963 + * We need to reset the result now, because the cross-
1.2964 + * filesystem copy may have stored the number of bytes
1.2965 + * in the result
1.2966 + */
1.2967 + Tcl_ResetResult(interp);
1.2968 +
1.2969 + retVal = Tcl_FSLoadFile(interp, copyToPtr, sym1, sym2,
1.2970 + proc1Ptr, proc2Ptr,
1.2971 + &newLoadHandle,
1.2972 + &newUnloadProcPtr);
1.2973 + if (retVal != TCL_OK) {
1.2974 + /* The file didn't load successfully */
1.2975 + Tcl_FSDeleteFile(copyToPtr);
1.2976 + Tcl_DecrRefCount(copyToPtr);
1.2977 + return retVal;
1.2978 + }
1.2979 + /*
1.2980 + * Try to delete the file immediately -- this is
1.2981 + * possible in some OSes, and avoids any worries
1.2982 + * about leaving the copy laying around on exit.
1.2983 + */
1.2984 + if (Tcl_FSDeleteFile(copyToPtr) == TCL_OK) {
1.2985 + Tcl_DecrRefCount(copyToPtr);
1.2986 + /*
1.2987 + * We tell our caller about the real shared
1.2988 + * library which was loaded. Note that this
1.2989 + * does mean that the package list maintained
1.2990 + * by 'load' will store the original (vfs)
1.2991 + * path alongside the temporary load handle
1.2992 + * and unload proc ptr.
1.2993 + */
1.2994 + (*handlePtr) = newLoadHandle;
1.2995 + (*unloadProcPtr) = newUnloadProcPtr;
1.2996 + return TCL_OK;
1.2997 + }
1.2998 + /*
1.2999 + * When we unload this file, we need to divert the
1.3000 + * unloading so we can unload and cleanup the
1.3001 + * temporary file correctly.
1.3002 + */
1.3003 + tvdlPtr = (FsDivertLoad*) ckalloc(sizeof(FsDivertLoad));
1.3004 +
1.3005 + /*
1.3006 + * Remember three pieces of information. This allows
1.3007 + * us to cleanup the diverted load completely, on
1.3008 + * platforms which allow proper unloading of code.
1.3009 + */
1.3010 + tvdlPtr->loadHandle = newLoadHandle;
1.3011 + tvdlPtr->unloadProcPtr = newUnloadProcPtr;
1.3012 +
1.3013 + if (copyFsPtr != &tclNativeFilesystem) {
1.3014 + /* copyToPtr is already incremented for this reference */
1.3015 + tvdlPtr->divertedFile = copyToPtr;
1.3016 +
1.3017 + /*
1.3018 + * This is the filesystem we loaded it into. Since
1.3019 + * we have a reference to 'copyToPtr', we already
1.3020 + * have a refCount on this filesystem, so we don't
1.3021 + * need to worry about it disappearing on us.
1.3022 + */
1.3023 + tvdlPtr->divertedFilesystem = copyFsPtr;
1.3024 + tvdlPtr->divertedFileNativeRep = NULL;
1.3025 + } else {
1.3026 + /* We need the native rep */
1.3027 + tvdlPtr->divertedFileNativeRep =
1.3028 + TclNativeDupInternalRep(Tcl_FSGetInternalRep(copyToPtr,
1.3029 + copyFsPtr));
1.3030 + /*
1.3031 + * We don't need or want references to the copied
1.3032 + * Tcl_Obj or the filesystem if it is the native
1.3033 + * one.
1.3034 + */
1.3035 + tvdlPtr->divertedFile = NULL;
1.3036 + tvdlPtr->divertedFilesystem = NULL;
1.3037 + Tcl_DecrRefCount(copyToPtr);
1.3038 + }
1.3039 +
1.3040 + copyToPtr = NULL;
1.3041 + (*handlePtr) = (Tcl_LoadHandle) tvdlPtr;
1.3042 + (*unloadProcPtr) = &FSUnloadTempFile;
1.3043 + return retVal;
1.3044 + } else {
1.3045 + /* Cross-platform copy failed */
1.3046 + Tcl_FSDeleteFile(copyToPtr);
1.3047 + Tcl_DecrRefCount(copyToPtr);
1.3048 + return TCL_ERROR;
1.3049 + }
1.3050 + }
1.3051 + }
1.3052 + Tcl_SetErrno(ENOENT);
1.3053 + return -1;
1.3054 +}
1.3055 +/*
1.3056 + * This function used to be in the platform specific directories, but it
1.3057 + * has now been made to work cross-platform
1.3058 + */
1.3059 +int
1.3060 +TclpLoadFile(interp, pathPtr, sym1, sym2, proc1Ptr, proc2Ptr,
1.3061 + clientDataPtr, unloadProcPtr)
1.3062 + Tcl_Interp *interp; /* Used for error reporting. */
1.3063 + Tcl_Obj *pathPtr; /* Name of the file containing the desired
1.3064 + * code (UTF-8). */
1.3065 + CONST char *sym1, *sym2; /* Names of two procedures to look up in
1.3066 + * the file's symbol table. */
1.3067 + Tcl_PackageInitProc **proc1Ptr, **proc2Ptr;
1.3068 + /* Where to return the addresses corresponding
1.3069 + * to sym1 and sym2. */
1.3070 + ClientData *clientDataPtr; /* Filled with token for dynamically loaded
1.3071 + * file which will be passed back to
1.3072 + * (*unloadProcPtr)() to unload the file. */
1.3073 + Tcl_FSUnloadFileProc **unloadProcPtr;
1.3074 + /* Filled with address of Tcl_FSUnloadFileProc
1.3075 + * function which should be used for
1.3076 + * this file. */
1.3077 +{
1.3078 + Tcl_LoadHandle handle = NULL;
1.3079 + int res;
1.3080 +
1.3081 + res = TclpDlopen(interp, pathPtr, &handle, unloadProcPtr);
1.3082 +
1.3083 + if (res != TCL_OK) {
1.3084 + return res;
1.3085 + }
1.3086 +
1.3087 + if (handle == NULL) {
1.3088 + return TCL_ERROR;
1.3089 + }
1.3090 +
1.3091 + *clientDataPtr = (ClientData)handle;
1.3092 +
1.3093 + *proc1Ptr = TclpFindSymbol(interp, handle, sym1);
1.3094 + *proc2Ptr = TclpFindSymbol(interp, handle, sym2);
1.3095 + return TCL_OK;
1.3096 +}
1.3097 +
1.3098 +/*
1.3099 + *---------------------------------------------------------------------------
1.3100 + *
1.3101 + * FSUnloadTempFile --
1.3102 + *
1.3103 + * This function is called when we loaded a library of code via
1.3104 + * an intermediate temporary file. This function ensures
1.3105 + * the library is correctly unloaded and the temporary file
1.3106 + * is correctly deleted.
1.3107 + *
1.3108 + * Results:
1.3109 + * None.
1.3110 + *
1.3111 + * Side effects:
1.3112 + * The effects of the 'unload' function called, and of course
1.3113 + * the temporary file will be deleted.
1.3114 + *
1.3115 + *---------------------------------------------------------------------------
1.3116 + */
1.3117 +static void
1.3118 +FSUnloadTempFile(loadHandle)
1.3119 + Tcl_LoadHandle loadHandle; /* loadHandle returned by a previous call
1.3120 + * to Tcl_FSLoadFile(). The loadHandle is
1.3121 + * a token that represents the loaded
1.3122 + * file. */
1.3123 +{
1.3124 + FsDivertLoad *tvdlPtr = (FsDivertLoad*)loadHandle;
1.3125 + /*
1.3126 + * This test should never trigger, since we give
1.3127 + * the client data in the function above.
1.3128 + */
1.3129 + if (tvdlPtr == NULL) { return; }
1.3130 +
1.3131 + /*
1.3132 + * Call the real 'unloadfile' proc we actually used. It is very
1.3133 + * important that we call this first, so that the shared library
1.3134 + * is actually unloaded by the OS. Otherwise, the following
1.3135 + * 'delete' may well fail because the shared library is still in
1.3136 + * use.
1.3137 + */
1.3138 + if (tvdlPtr->unloadProcPtr != NULL) {
1.3139 + (*tvdlPtr->unloadProcPtr)(tvdlPtr->loadHandle);
1.3140 + }
1.3141 +
1.3142 + if (tvdlPtr->divertedFilesystem == NULL) {
1.3143 + /*
1.3144 + * It was the native filesystem, and we have a special
1.3145 + * function available just for this purpose, which we
1.3146 + * know works even at this late stage.
1.3147 + */
1.3148 + TclpDeleteFile(tvdlPtr->divertedFileNativeRep);
1.3149 + NativeFreeInternalRep(tvdlPtr->divertedFileNativeRep);
1.3150 + } else {
1.3151 + /*
1.3152 + * Remove the temporary file we created. Note, we may crash
1.3153 + * here because encodings have been taken down already.
1.3154 + */
1.3155 + if (tvdlPtr->divertedFilesystem->deleteFileProc(tvdlPtr->divertedFile)
1.3156 + != TCL_OK) {
1.3157 + /*
1.3158 + * The above may have failed because the filesystem, or something
1.3159 + * it depends upon (e.g. encodings) have been taken down because
1.3160 + * Tcl is exiting.
1.3161 + *
1.3162 + * We may need to work out how to delete this file more
1.3163 + * robustly (or give the filesystem the information it needs
1.3164 + * to delete the file more robustly).
1.3165 + *
1.3166 + * In particular, one problem might be that the filesystem
1.3167 + * cannot extract the information it needs from the above
1.3168 + * path object because Tcl's entire filesystem apparatus
1.3169 + * (the code in this file) has been finalized, and it
1.3170 + * refuses to pass the internal representation to the
1.3171 + * filesystem.
1.3172 + */
1.3173 + }
1.3174 +
1.3175 + /*
1.3176 + * And free up the allocations. This will also of course remove
1.3177 + * a refCount from the Tcl_Filesystem to which this file belongs,
1.3178 + * which could then free up the filesystem if we are exiting.
1.3179 + */
1.3180 + Tcl_DecrRefCount(tvdlPtr->divertedFile);
1.3181 + }
1.3182 +
1.3183 + ckfree((char*)tvdlPtr);
1.3184 +}
1.3185 +
1.3186 +/*
1.3187 + *---------------------------------------------------------------------------
1.3188 + *
1.3189 + * Tcl_FSLink --
1.3190 + *
1.3191 + * This function replaces the library version of readlink() and
1.3192 + * can also be used to make links. The appropriate function for
1.3193 + * the filesystem to which pathPtr belongs will be called.
1.3194 + *
1.3195 + * Results:
1.3196 + * If toPtr is NULL, then the result is a Tcl_Obj specifying the
1.3197 + * contents of the symbolic link given by 'pathPtr', or NULL if
1.3198 + * the symbolic link could not be read. The result is owned by
1.3199 + * the caller, which should call Tcl_DecrRefCount when the result
1.3200 + * is no longer needed.
1.3201 + *
1.3202 + * If toPtr is non-NULL, then the result is toPtr if the link action
1.3203 + * was successful, or NULL if not. In this case the result has no
1.3204 + * additional reference count, and need not be freed. The actual
1.3205 + * action to perform is given by the 'linkAction' flags, which is
1.3206 + * an or'd combination of:
1.3207 + *
1.3208 + * TCL_CREATE_SYMBOLIC_LINK
1.3209 + * TCL_CREATE_HARD_LINK
1.3210 + *
1.3211 + * Note that most filesystems will not support linking across
1.3212 + * to different filesystems, so this function will usually
1.3213 + * fail unless toPtr is in the same FS as pathPtr.
1.3214 + *
1.3215 + * Side effects:
1.3216 + * See readlink() documentation. A new filesystem link
1.3217 + * object may appear
1.3218 + *
1.3219 + *---------------------------------------------------------------------------
1.3220 + */
1.3221 +
1.3222 +EXPORT_C Tcl_Obj *
1.3223 +Tcl_FSLink(pathPtr, toPtr, linkAction)
1.3224 + Tcl_Obj *pathPtr; /* Path of file to readlink or link */
1.3225 + Tcl_Obj *toPtr; /* NULL or path to be linked to */
1.3226 + int linkAction; /* Action to perform */
1.3227 +{
1.3228 + Tcl_Filesystem *fsPtr = Tcl_FSGetFileSystemForPath(pathPtr);
1.3229 + if (fsPtr != NULL) {
1.3230 + Tcl_FSLinkProc *proc = fsPtr->linkProc;
1.3231 + if (proc != NULL) {
1.3232 + return (*proc)(pathPtr, toPtr, linkAction);
1.3233 + }
1.3234 + }
1.3235 + /*
1.3236 + * If S_IFLNK isn't defined it means that the machine doesn't
1.3237 + * support symbolic links, so the file can't possibly be a
1.3238 + * symbolic link. Generate an EINVAL error, which is what
1.3239 + * happens on machines that do support symbolic links when
1.3240 + * you invoke readlink on a file that isn't a symbolic link.
1.3241 + */
1.3242 +#ifndef S_IFLNK
1.3243 + errno = EINVAL;
1.3244 +#else
1.3245 + Tcl_SetErrno(ENOENT);
1.3246 +#endif /* S_IFLNK */
1.3247 + return NULL;
1.3248 +}
1.3249 +
1.3250 +/*
1.3251 + *---------------------------------------------------------------------------
1.3252 + *
1.3253 + * Tcl_FSListVolumes --
1.3254 + *
1.3255 + * Lists the currently mounted volumes. The chain of functions
1.3256 + * that have been "inserted" into the filesystem will be called in
1.3257 + * succession; each may return a list of volumes, all of which are
1.3258 + * added to the result until all mounted file systems are listed.
1.3259 + *
1.3260 + * Notice that we assume the lists returned by each filesystem
1.3261 + * (if non NULL) have been given a refCount for us already.
1.3262 + * However, we are NOT allowed to hang on to the list itself
1.3263 + * (it belongs to the filesystem we called). Therefore we
1.3264 + * quite naturally add its contents to the result we are
1.3265 + * building, and then decrement the refCount.
1.3266 + *
1.3267 + * Results:
1.3268 + * The list of volumes, in an object which has refCount 0.
1.3269 + *
1.3270 + * Side effects:
1.3271 + * None
1.3272 + *
1.3273 + *---------------------------------------------------------------------------
1.3274 + */
1.3275 +
1.3276 +EXPORT_C Tcl_Obj*
1.3277 +Tcl_FSListVolumes(void)
1.3278 +{
1.3279 + FilesystemRecord *fsRecPtr;
1.3280 + Tcl_Obj *resultPtr = Tcl_NewObj();
1.3281 +
1.3282 + /*
1.3283 + * Call each of the "listVolumes" function in succession.
1.3284 + * A non-NULL return value indicates the particular function has
1.3285 + * succeeded. We call all the functions registered, since we want
1.3286 + * a list of all drives from all filesystems.
1.3287 + */
1.3288 +
1.3289 + fsRecPtr = FsGetFirstFilesystem();
1.3290 + while (fsRecPtr != NULL) {
1.3291 + Tcl_FSListVolumesProc *proc = fsRecPtr->fsPtr->listVolumesProc;
1.3292 + if (proc != NULL) {
1.3293 + Tcl_Obj *thisFsVolumes = (*proc)();
1.3294 + if (thisFsVolumes != NULL) {
1.3295 + Tcl_ListObjAppendList(NULL, resultPtr, thisFsVolumes);
1.3296 + Tcl_DecrRefCount(thisFsVolumes);
1.3297 + }
1.3298 + }
1.3299 + fsRecPtr = fsRecPtr->nextPtr;
1.3300 + }
1.3301 +
1.3302 + return resultPtr;
1.3303 +}
1.3304 +
1.3305 +/*
1.3306 + *---------------------------------------------------------------------------
1.3307 + *
1.3308 + * FsListMounts --
1.3309 + *
1.3310 + * List all mounts within the given directory, which match the
1.3311 + * given pattern.
1.3312 + *
1.3313 + * Results:
1.3314 + * The list of mounts, in a list object which has refCount 0, or
1.3315 + * NULL if we didn't even find any filesystems to try to list
1.3316 + * mounts.
1.3317 + *
1.3318 + * Side effects:
1.3319 + * None
1.3320 + *
1.3321 + *---------------------------------------------------------------------------
1.3322 + */
1.3323 +
1.3324 +static Tcl_Obj*
1.3325 +FsListMounts(pathPtr, pattern)
1.3326 + Tcl_Obj *pathPtr; /* Contains path to directory to search. */
1.3327 + CONST char *pattern; /* Pattern to match against. */
1.3328 +{
1.3329 + FilesystemRecord *fsRecPtr;
1.3330 + Tcl_GlobTypeData mountsOnly = { TCL_GLOB_TYPE_MOUNT, 0, NULL, NULL };
1.3331 + Tcl_Obj *resultPtr = NULL;
1.3332 +
1.3333 + /*
1.3334 + * Call each of the "listMounts" functions in succession.
1.3335 + * A non-NULL return value indicates the particular function has
1.3336 + * succeeded. We call all the functions registered, since we want
1.3337 + * a list from each filesystems.
1.3338 + */
1.3339 +
1.3340 + fsRecPtr = FsGetFirstFilesystem();
1.3341 + while (fsRecPtr != NULL) {
1.3342 + if (fsRecPtr->fsPtr != &tclNativeFilesystem) {
1.3343 + Tcl_FSMatchInDirectoryProc *proc =
1.3344 + fsRecPtr->fsPtr->matchInDirectoryProc;
1.3345 + if (proc != NULL) {
1.3346 + if (resultPtr == NULL) {
1.3347 + resultPtr = Tcl_NewObj();
1.3348 + }
1.3349 + (*proc)(NULL, resultPtr, pathPtr, pattern, &mountsOnly);
1.3350 + }
1.3351 + }
1.3352 + fsRecPtr = fsRecPtr->nextPtr;
1.3353 + }
1.3354 +
1.3355 + return resultPtr;
1.3356 +}
1.3357 +
1.3358 +/*
1.3359 + *---------------------------------------------------------------------------
1.3360 + *
1.3361 + * Tcl_FSSplitPath --
1.3362 + *
1.3363 + * This function takes the given Tcl_Obj, which should be a valid
1.3364 + * path, and returns a Tcl List object containing each segment of
1.3365 + * that path as an element.
1.3366 + *
1.3367 + * Results:
1.3368 + * Returns list object with refCount of zero. If the passed in
1.3369 + * lenPtr is non-NULL, we use it to return the number of elements
1.3370 + * in the returned list.
1.3371 + *
1.3372 + * Side effects:
1.3373 + * None.
1.3374 + *
1.3375 + *---------------------------------------------------------------------------
1.3376 + */
1.3377 +
1.3378 +EXPORT_C Tcl_Obj*
1.3379 +Tcl_FSSplitPath(pathPtr, lenPtr)
1.3380 + Tcl_Obj *pathPtr; /* Path to split. */
1.3381 + int *lenPtr; /* int to store number of path elements. */
1.3382 +{
1.3383 + Tcl_Obj *result = NULL; /* Needed only to prevent gcc warnings. */
1.3384 + Tcl_Filesystem *fsPtr;
1.3385 + char separator = '/';
1.3386 + int driveNameLength;
1.3387 + char *p;
1.3388 +
1.3389 + /*
1.3390 + * Perform platform specific splitting.
1.3391 + */
1.3392 +
1.3393 + if (FSGetPathType(pathPtr, &fsPtr, &driveNameLength)
1.3394 + == TCL_PATH_ABSOLUTE) {
1.3395 + if (fsPtr == &tclNativeFilesystem) {
1.3396 + return TclpNativeSplitPath(pathPtr, lenPtr);
1.3397 + }
1.3398 + } else {
1.3399 + return TclpNativeSplitPath(pathPtr, lenPtr);
1.3400 + }
1.3401 +
1.3402 + /* We assume separators are single characters */
1.3403 + if (fsPtr->filesystemSeparatorProc != NULL) {
1.3404 + Tcl_Obj *sep = (*fsPtr->filesystemSeparatorProc)(pathPtr);
1.3405 + if (sep != NULL) {
1.3406 + separator = Tcl_GetString(sep)[0];
1.3407 + }
1.3408 + }
1.3409 +
1.3410 + /*
1.3411 + * Place the drive name as first element of the
1.3412 + * result list. The drive name may contain strange
1.3413 + * characters, like colons and multiple forward slashes
1.3414 + * (for example 'ftp://' is a valid vfs drive name)
1.3415 + */
1.3416 + result = Tcl_NewObj();
1.3417 + p = Tcl_GetString(pathPtr);
1.3418 + Tcl_ListObjAppendElement(NULL, result,
1.3419 + Tcl_NewStringObj(p, driveNameLength));
1.3420 + p+= driveNameLength;
1.3421 +
1.3422 + /* Add the remaining path elements to the list */
1.3423 + for (;;) {
1.3424 + char *elementStart = p;
1.3425 + int length;
1.3426 + while ((*p != '\0') && (*p != separator)) {
1.3427 + p++;
1.3428 + }
1.3429 + length = p - elementStart;
1.3430 + if (length > 0) {
1.3431 + Tcl_Obj *nextElt;
1.3432 + if (elementStart[0] == '~') {
1.3433 + nextElt = Tcl_NewStringObj("./",2);
1.3434 + Tcl_AppendToObj(nextElt, elementStart, length);
1.3435 + } else {
1.3436 + nextElt = Tcl_NewStringObj(elementStart, length);
1.3437 + }
1.3438 + Tcl_ListObjAppendElement(NULL, result, nextElt);
1.3439 + }
1.3440 + if (*p++ == '\0') {
1.3441 + break;
1.3442 + }
1.3443 + }
1.3444 +
1.3445 + /*
1.3446 + * Compute the number of elements in the result.
1.3447 + */
1.3448 +
1.3449 + if (lenPtr != NULL) {
1.3450 + Tcl_ListObjLength(NULL, result, lenPtr);
1.3451 + }
1.3452 + return result;
1.3453 +}
1.3454 +
1.3455 +/* Simple helper function */
1.3456 +Tcl_Obj*
1.3457 +TclFSInternalToNormalized(fromFilesystem, clientData, fsRecPtrPtr)
1.3458 + Tcl_Filesystem *fromFilesystem;
1.3459 + ClientData clientData;
1.3460 + FilesystemRecord **fsRecPtrPtr;
1.3461 +{
1.3462 + FilesystemRecord *fsRecPtr = FsGetFirstFilesystem();
1.3463 +
1.3464 + while (fsRecPtr != NULL) {
1.3465 + if (fsRecPtr->fsPtr == fromFilesystem) {
1.3466 + *fsRecPtrPtr = fsRecPtr;
1.3467 + break;
1.3468 + }
1.3469 + fsRecPtr = fsRecPtr->nextPtr;
1.3470 + }
1.3471 +
1.3472 + if ((fsRecPtr != NULL)
1.3473 + && (fromFilesystem->internalToNormalizedProc != NULL)) {
1.3474 + return (*fromFilesystem->internalToNormalizedProc)(clientData);
1.3475 + } else {
1.3476 + return NULL;
1.3477 + }
1.3478 +}
1.3479 +
1.3480 +/*
1.3481 + *----------------------------------------------------------------------
1.3482 + *
1.3483 + * GetPathType --
1.3484 + *
1.3485 + * Helper function used by FSGetPathType.
1.3486 + *
1.3487 + * Results:
1.3488 + * Returns one of TCL_PATH_ABSOLUTE, TCL_PATH_RELATIVE, or
1.3489 + * TCL_PATH_VOLUME_RELATIVE. The filesystem reference will
1.3490 + * be set if and only if it is non-NULL and the function's
1.3491 + * return value is TCL_PATH_ABSOLUTE.
1.3492 + *
1.3493 + * Side effects:
1.3494 + * None.
1.3495 + *
1.3496 + *----------------------------------------------------------------------
1.3497 + */
1.3498 +
1.3499 +static Tcl_PathType
1.3500 +GetPathType(pathObjPtr, filesystemPtrPtr, driveNameLengthPtr, driveNameRef)
1.3501 + Tcl_Obj *pathObjPtr;
1.3502 + Tcl_Filesystem **filesystemPtrPtr;
1.3503 + int *driveNameLengthPtr;
1.3504 + Tcl_Obj **driveNameRef;
1.3505 +{
1.3506 + FilesystemRecord *fsRecPtr;
1.3507 + int pathLen;
1.3508 + char *path;
1.3509 + Tcl_PathType type = TCL_PATH_RELATIVE;
1.3510 +
1.3511 + path = Tcl_GetStringFromObj(pathObjPtr, &pathLen);
1.3512 +
1.3513 + /*
1.3514 + * Call each of the "listVolumes" function in succession, checking
1.3515 + * whether the given path is an absolute path on any of the volumes
1.3516 + * returned (this is done by checking whether the path's prefix
1.3517 + * matches).
1.3518 + */
1.3519 +
1.3520 + fsRecPtr = FsGetFirstFilesystem();
1.3521 + while (fsRecPtr != NULL) {
1.3522 + Tcl_FSListVolumesProc *proc = fsRecPtr->fsPtr->listVolumesProc;
1.3523 + /*
1.3524 + * We want to skip the native filesystem in this loop because
1.3525 + * otherwise we won't necessarily pass all the Tcl testsuite --
1.3526 + * this is because some of the tests artificially change the
1.3527 + * current platform (between mac, win, unix) but the list
1.3528 + * of volumes we get by calling (*proc) will reflect the current
1.3529 + * (real) platform only and this may cause some tests to fail.
1.3530 + * In particular, on unix '/' will match the beginning of
1.3531 + * certain absolute Windows paths starting '//' and those tests
1.3532 + * will go wrong.
1.3533 + *
1.3534 + * Besides these test-suite issues, there is one other reason
1.3535 + * to skip the native filesystem --- since the tclFilename.c
1.3536 + * code has nice fast 'absolute path' checkers, we don't want
1.3537 + * to waste time repeating that effort here, and this
1.3538 + * function is actually called quite often, so if we can
1.3539 + * save the overhead of the native filesystem returning us
1.3540 + * a list of volumes all the time, it is better.
1.3541 + */
1.3542 + if ((fsRecPtr->fsPtr != &tclNativeFilesystem) && (proc != NULL)) {
1.3543 + int numVolumes;
1.3544 + Tcl_Obj *thisFsVolumes = (*proc)();
1.3545 + if (thisFsVolumes != NULL) {
1.3546 + if (Tcl_ListObjLength(NULL, thisFsVolumes,
1.3547 + &numVolumes) != TCL_OK) {
1.3548 + /*
1.3549 + * This is VERY bad; the Tcl_FSListVolumesProc
1.3550 + * didn't return a valid list. Set numVolumes to
1.3551 + * -1 so that we skip the while loop below and just
1.3552 + * return with the current value of 'type'.
1.3553 + *
1.3554 + * It would be better if we could signal an error
1.3555 + * here (but panic seems a bit excessive).
1.3556 + */
1.3557 + numVolumes = -1;
1.3558 + }
1.3559 + while (numVolumes > 0) {
1.3560 + Tcl_Obj *vol;
1.3561 + int len;
1.3562 + char *strVol;
1.3563 +
1.3564 + numVolumes--;
1.3565 + Tcl_ListObjIndex(NULL, thisFsVolumes, numVolumes, &vol);
1.3566 + strVol = Tcl_GetStringFromObj(vol,&len);
1.3567 + if (pathLen < len) {
1.3568 + continue;
1.3569 + }
1.3570 + if (strncmp(strVol, path, (size_t) len) == 0) {
1.3571 + type = TCL_PATH_ABSOLUTE;
1.3572 + if (filesystemPtrPtr != NULL) {
1.3573 + *filesystemPtrPtr = fsRecPtr->fsPtr;
1.3574 + }
1.3575 + if (driveNameLengthPtr != NULL) {
1.3576 + *driveNameLengthPtr = len;
1.3577 + }
1.3578 + if (driveNameRef != NULL) {
1.3579 + *driveNameRef = vol;
1.3580 + Tcl_IncrRefCount(vol);
1.3581 + }
1.3582 + break;
1.3583 + }
1.3584 + }
1.3585 + Tcl_DecrRefCount(thisFsVolumes);
1.3586 + if (type == TCL_PATH_ABSOLUTE) {
1.3587 + /* We don't need to examine any more filesystems */
1.3588 + break;
1.3589 + }
1.3590 + }
1.3591 + }
1.3592 + fsRecPtr = fsRecPtr->nextPtr;
1.3593 + }
1.3594 +
1.3595 + if (type != TCL_PATH_ABSOLUTE) {
1.3596 + type = TclpGetNativePathType(pathObjPtr, driveNameLengthPtr,
1.3597 + driveNameRef);
1.3598 + if ((type == TCL_PATH_ABSOLUTE) && (filesystemPtrPtr != NULL)) {
1.3599 + *filesystemPtrPtr = &tclNativeFilesystem;
1.3600 + }
1.3601 + }
1.3602 + return type;
1.3603 +}
1.3604 +
1.3605 +/*
1.3606 + *---------------------------------------------------------------------------
1.3607 + *
1.3608 + * Tcl_FSRenameFile --
1.3609 + *
1.3610 + * If the two paths given belong to the same filesystem, we call
1.3611 + * that filesystems rename function. Otherwise we simply
1.3612 + * return the posix error 'EXDEV', and -1.
1.3613 + *
1.3614 + * Results:
1.3615 + * Standard Tcl error code if a function was called.
1.3616 + *
1.3617 + * Side effects:
1.3618 + * A file may be renamed.
1.3619 + *
1.3620 + *---------------------------------------------------------------------------
1.3621 + */
1.3622 +
1.3623 +EXPORT_C int
1.3624 +Tcl_FSRenameFile(srcPathPtr, destPathPtr)
1.3625 + Tcl_Obj* srcPathPtr; /* Pathname of file or dir to be renamed
1.3626 + * (UTF-8). */
1.3627 + Tcl_Obj *destPathPtr; /* New pathname of file or directory
1.3628 + * (UTF-8). */
1.3629 +{
1.3630 + int retVal = -1;
1.3631 + Tcl_Filesystem *fsPtr, *fsPtr2;
1.3632 + fsPtr = Tcl_FSGetFileSystemForPath(srcPathPtr);
1.3633 + fsPtr2 = Tcl_FSGetFileSystemForPath(destPathPtr);
1.3634 +
1.3635 + if (fsPtr == fsPtr2 && fsPtr != NULL) {
1.3636 + Tcl_FSRenameFileProc *proc = fsPtr->renameFileProc;
1.3637 + if (proc != NULL) {
1.3638 + retVal = (*proc)(srcPathPtr, destPathPtr);
1.3639 + }
1.3640 + }
1.3641 + if (retVal == -1) {
1.3642 + Tcl_SetErrno(EXDEV);
1.3643 + }
1.3644 + return retVal;
1.3645 +}
1.3646 +
1.3647 +/*
1.3648 + *---------------------------------------------------------------------------
1.3649 + *
1.3650 + * Tcl_FSCopyFile --
1.3651 + *
1.3652 + * If the two paths given belong to the same filesystem, we call
1.3653 + * that filesystem's copy function. Otherwise we simply
1.3654 + * return the posix error 'EXDEV', and -1.
1.3655 + *
1.3656 + * Note that in the native filesystems, 'copyFileProc' is defined
1.3657 + * to copy soft links (i.e. it copies the links themselves, not
1.3658 + * the things they point to).
1.3659 + *
1.3660 + * Results:
1.3661 + * Standard Tcl error code if a function was called.
1.3662 + *
1.3663 + * Side effects:
1.3664 + * A file may be copied.
1.3665 + *
1.3666 + *---------------------------------------------------------------------------
1.3667 + */
1.3668 +
1.3669 +EXPORT_C int
1.3670 +Tcl_FSCopyFile(srcPathPtr, destPathPtr)
1.3671 + Tcl_Obj* srcPathPtr; /* Pathname of file to be copied (UTF-8). */
1.3672 + Tcl_Obj *destPathPtr; /* Pathname of file to copy to (UTF-8). */
1.3673 +{
1.3674 + int retVal = -1;
1.3675 + Tcl_Filesystem *fsPtr, *fsPtr2;
1.3676 + fsPtr = Tcl_FSGetFileSystemForPath(srcPathPtr);
1.3677 + fsPtr2 = Tcl_FSGetFileSystemForPath(destPathPtr);
1.3678 +
1.3679 + if (fsPtr == fsPtr2 && fsPtr != NULL) {
1.3680 + Tcl_FSCopyFileProc *proc = fsPtr->copyFileProc;
1.3681 + if (proc != NULL) {
1.3682 + retVal = (*proc)(srcPathPtr, destPathPtr);
1.3683 + }
1.3684 + }
1.3685 + if (retVal == -1) {
1.3686 + Tcl_SetErrno(EXDEV);
1.3687 + }
1.3688 + return retVal;
1.3689 +}
1.3690 +
1.3691 +/*
1.3692 + *---------------------------------------------------------------------------
1.3693 + *
1.3694 + * TclCrossFilesystemCopy --
1.3695 + *
1.3696 + * Helper for above function, and for Tcl_FSLoadFile, to copy
1.3697 + * files from one filesystem to another. This function will
1.3698 + * overwrite the target file if it already exists.
1.3699 + *
1.3700 + * Results:
1.3701 + * Standard Tcl error code.
1.3702 + *
1.3703 + * Side effects:
1.3704 + * A file may be created.
1.3705 + *
1.3706 + *---------------------------------------------------------------------------
1.3707 + */
1.3708 +int
1.3709 +TclCrossFilesystemCopy(interp, source, target)
1.3710 + Tcl_Interp *interp; /* For error messages */
1.3711 + Tcl_Obj *source; /* Pathname of file to be copied (UTF-8). */
1.3712 + Tcl_Obj *target; /* Pathname of file to copy to (UTF-8). */
1.3713 +{
1.3714 + int result = TCL_ERROR;
1.3715 + int prot = 0666;
1.3716 +
1.3717 + Tcl_Channel out = Tcl_FSOpenFileChannel(interp, target, "w", prot);
1.3718 + if (out != NULL) {
1.3719 + /* It looks like we can copy it over */
1.3720 + Tcl_Channel in = Tcl_FSOpenFileChannel(interp, source,
1.3721 + "r", prot);
1.3722 + if (in == NULL) {
1.3723 + /* This is very strange, we checked this above */
1.3724 + Tcl_Close(interp, out);
1.3725 + } else {
1.3726 + Tcl_StatBuf sourceStatBuf;
1.3727 + struct utimbuf tval;
1.3728 + /*
1.3729 + * Copy it synchronously. We might wish to add an
1.3730 + * asynchronous option to support vfs's which are
1.3731 + * slow (e.g. network sockets).
1.3732 + */
1.3733 + Tcl_SetChannelOption(interp, in, "-translation", "binary");
1.3734 + Tcl_SetChannelOption(interp, out, "-translation", "binary");
1.3735 +
1.3736 + if (TclCopyChannel(interp, in, out, -1, NULL) == TCL_OK) {
1.3737 + result = TCL_OK;
1.3738 + }
1.3739 + /*
1.3740 + * If the copy failed, assume that copy channel left
1.3741 + * a good error message.
1.3742 + */
1.3743 + Tcl_Close(interp, in);
1.3744 + Tcl_Close(interp, out);
1.3745 +
1.3746 + /* Set modification date of copied file */
1.3747 + if (Tcl_FSLstat(source, &sourceStatBuf) == 0) {
1.3748 + tval.actime = sourceStatBuf.st_atime;
1.3749 + tval.modtime = sourceStatBuf.st_mtime;
1.3750 + Tcl_FSUtime(target, &tval);
1.3751 + }
1.3752 + }
1.3753 + }
1.3754 + return result;
1.3755 +}
1.3756 +
1.3757 +/*
1.3758 + *---------------------------------------------------------------------------
1.3759 + *
1.3760 + * Tcl_FSDeleteFile --
1.3761 + *
1.3762 + * The appropriate function for the filesystem to which pathPtr
1.3763 + * belongs will be called.
1.3764 + *
1.3765 + * Results:
1.3766 + * Standard Tcl error code.
1.3767 + *
1.3768 + * Side effects:
1.3769 + * A file may be deleted.
1.3770 + *
1.3771 + *---------------------------------------------------------------------------
1.3772 + */
1.3773 +
1.3774 +EXPORT_C int
1.3775 +Tcl_FSDeleteFile(pathPtr)
1.3776 + Tcl_Obj *pathPtr; /* Pathname of file to be removed (UTF-8). */
1.3777 +{
1.3778 + Tcl_Filesystem *fsPtr = Tcl_FSGetFileSystemForPath(pathPtr);
1.3779 + if (fsPtr != NULL) {
1.3780 + Tcl_FSDeleteFileProc *proc = fsPtr->deleteFileProc;
1.3781 + if (proc != NULL) {
1.3782 + return (*proc)(pathPtr);
1.3783 + }
1.3784 + }
1.3785 + Tcl_SetErrno(ENOENT);
1.3786 + return -1;
1.3787 +}
1.3788 +
1.3789 +/*
1.3790 + *---------------------------------------------------------------------------
1.3791 + *
1.3792 + * Tcl_FSCreateDirectory --
1.3793 + *
1.3794 + * The appropriate function for the filesystem to which pathPtr
1.3795 + * belongs will be called.
1.3796 + *
1.3797 + * Results:
1.3798 + * Standard Tcl error code.
1.3799 + *
1.3800 + * Side effects:
1.3801 + * A directory may be created.
1.3802 + *
1.3803 + *---------------------------------------------------------------------------
1.3804 + */
1.3805 +
1.3806 +EXPORT_C int
1.3807 +Tcl_FSCreateDirectory(pathPtr)
1.3808 + Tcl_Obj *pathPtr; /* Pathname of directory to create (UTF-8). */
1.3809 +{
1.3810 + Tcl_Filesystem *fsPtr = Tcl_FSGetFileSystemForPath(pathPtr);
1.3811 + if (fsPtr != NULL) {
1.3812 + Tcl_FSCreateDirectoryProc *proc = fsPtr->createDirectoryProc;
1.3813 + if (proc != NULL) {
1.3814 + return (*proc)(pathPtr);
1.3815 + }
1.3816 + }
1.3817 + Tcl_SetErrno(ENOENT);
1.3818 + return -1;
1.3819 +}
1.3820 +
1.3821 +/*
1.3822 + *---------------------------------------------------------------------------
1.3823 + *
1.3824 + * Tcl_FSCopyDirectory --
1.3825 + *
1.3826 + * If the two paths given belong to the same filesystem, we call
1.3827 + * that filesystems copy-directory function. Otherwise we simply
1.3828 + * return the posix error 'EXDEV', and -1.
1.3829 + *
1.3830 + * Results:
1.3831 + * Standard Tcl error code if a function was called.
1.3832 + *
1.3833 + * Side effects:
1.3834 + * A directory may be copied.
1.3835 + *
1.3836 + *---------------------------------------------------------------------------
1.3837 + */
1.3838 +
1.3839 +EXPORT_C int
1.3840 +Tcl_FSCopyDirectory(srcPathPtr, destPathPtr, errorPtr)
1.3841 + Tcl_Obj* srcPathPtr; /* Pathname of directory to be copied
1.3842 + * (UTF-8). */
1.3843 + Tcl_Obj *destPathPtr; /* Pathname of target directory (UTF-8). */
1.3844 + Tcl_Obj **errorPtr; /* If non-NULL, then will be set to a
1.3845 + * new object containing name of file
1.3846 + * causing error, with refCount 1. */
1.3847 +{
1.3848 + int retVal = -1;
1.3849 + Tcl_Filesystem *fsPtr, *fsPtr2;
1.3850 + fsPtr = Tcl_FSGetFileSystemForPath(srcPathPtr);
1.3851 + fsPtr2 = Tcl_FSGetFileSystemForPath(destPathPtr);
1.3852 +
1.3853 + if (fsPtr == fsPtr2 && fsPtr != NULL) {
1.3854 + Tcl_FSCopyDirectoryProc *proc = fsPtr->copyDirectoryProc;
1.3855 + if (proc != NULL) {
1.3856 + retVal = (*proc)(srcPathPtr, destPathPtr, errorPtr);
1.3857 + }
1.3858 + }
1.3859 + if (retVal == -1) {
1.3860 + Tcl_SetErrno(EXDEV);
1.3861 + }
1.3862 + return retVal;
1.3863 +}
1.3864 +
1.3865 +/*
1.3866 + *---------------------------------------------------------------------------
1.3867 + *
1.3868 + * Tcl_FSRemoveDirectory --
1.3869 + *
1.3870 + * The appropriate function for the filesystem to which pathPtr
1.3871 + * belongs will be called.
1.3872 + *
1.3873 + * Results:
1.3874 + * Standard Tcl error code.
1.3875 + *
1.3876 + * Side effects:
1.3877 + * A directory may be deleted.
1.3878 + *
1.3879 + *---------------------------------------------------------------------------
1.3880 + */
1.3881 +
1.3882 +EXPORT_C int
1.3883 +Tcl_FSRemoveDirectory(pathPtr, recursive, errorPtr)
1.3884 + Tcl_Obj *pathPtr; /* Pathname of directory to be removed
1.3885 + * (UTF-8). */
1.3886 + int recursive; /* If non-zero, removes directories that
1.3887 + * are nonempty. Otherwise, will only remove
1.3888 + * empty directories. */
1.3889 + Tcl_Obj **errorPtr; /* If non-NULL, then will be set to a
1.3890 + * new object containing name of file
1.3891 + * causing error, with refCount 1. */
1.3892 +{
1.3893 + Tcl_Filesystem *fsPtr = Tcl_FSGetFileSystemForPath(pathPtr);
1.3894 + if (fsPtr != NULL) {
1.3895 + Tcl_FSRemoveDirectoryProc *proc = fsPtr->removeDirectoryProc;
1.3896 + if (proc != NULL) {
1.3897 + if (recursive) {
1.3898 + /*
1.3899 + * We check whether the cwd lies inside this directory
1.3900 + * and move it if it does.
1.3901 + */
1.3902 + Tcl_Obj *cwdPtr = Tcl_FSGetCwd(NULL);
1.3903 + if (cwdPtr != NULL) {
1.3904 + char *cwdStr, *normPathStr;
1.3905 + int cwdLen, normLen;
1.3906 + Tcl_Obj *normPath = Tcl_FSGetNormalizedPath(NULL, pathPtr);
1.3907 + if (normPath != NULL) {
1.3908 + normPathStr = Tcl_GetStringFromObj(normPath, &normLen);
1.3909 + cwdStr = Tcl_GetStringFromObj(cwdPtr, &cwdLen);
1.3910 + if ((cwdLen >= normLen) && (strncmp(normPathStr,
1.3911 + cwdStr, (size_t) normLen) == 0)) {
1.3912 + /*
1.3913 + * the cwd is inside the directory, so we
1.3914 + * perform a 'cd [file dirname $path]'
1.3915 + */
1.3916 + Tcl_Obj *dirPtr = TclFileDirname(NULL, pathPtr);
1.3917 + Tcl_FSChdir(dirPtr);
1.3918 + Tcl_DecrRefCount(dirPtr);
1.3919 + }
1.3920 + }
1.3921 + Tcl_DecrRefCount(cwdPtr);
1.3922 + }
1.3923 + }
1.3924 + return (*proc)(pathPtr, recursive, errorPtr);
1.3925 + }
1.3926 + }
1.3927 + Tcl_SetErrno(ENOENT);
1.3928 + return -1;
1.3929 +}
1.3930 +
1.3931 +/*
1.3932 + *---------------------------------------------------------------------------
1.3933 + *
1.3934 + * Tcl_FSGetFileSystemForPath --
1.3935 + *
1.3936 + * This function determines which filesystem to use for a
1.3937 + * particular path object, and returns the filesystem which
1.3938 + * accepts this file. If no filesystem will accept this object
1.3939 + * as a valid file path, then NULL is returned.
1.3940 + *
1.3941 + * Results:
1.3942 +.* NULL or a filesystem which will accept this path.
1.3943 + *
1.3944 + * Side effects:
1.3945 + * The object may be converted to a path type.
1.3946 + *
1.3947 + *---------------------------------------------------------------------------
1.3948 + */
1.3949 +
1.3950 +EXPORT_C Tcl_Filesystem*
1.3951 +Tcl_FSGetFileSystemForPath(pathObjPtr)
1.3952 + Tcl_Obj* pathObjPtr;
1.3953 +{
1.3954 + FilesystemRecord *fsRecPtr;
1.3955 + Tcl_Filesystem* retVal = NULL;
1.3956 +
1.3957 + /*
1.3958 + * If the object has a refCount of zero, we reject it. This
1.3959 + * is to avoid possible segfaults or nondeterministic memory
1.3960 + * leaks (i.e. the user doesn't know if they should decrement
1.3961 + * the ref count on return or not).
1.3962 + */
1.3963 +
1.3964 + if (pathObjPtr->refCount == 0) {
1.3965 + panic("Tcl_FSGetFileSystemForPath called with object with refCount == 0");
1.3966 + return NULL;
1.3967 + }
1.3968 +
1.3969 + /*
1.3970 + * Check if the filesystem has changed in some way since
1.3971 + * this object's internal representation was calculated.
1.3972 + * Before doing that, assure we have the most up-to-date
1.3973 + * copy of the master filesystem. This is accomplished
1.3974 + * by the FsGetFirstFilesystem() call.
1.3975 + */
1.3976 +
1.3977 + fsRecPtr = FsGetFirstFilesystem();
1.3978 +
1.3979 + if (TclFSEnsureEpochOk(pathObjPtr, &retVal) != TCL_OK) {
1.3980 + return NULL;
1.3981 + }
1.3982 +
1.3983 + /*
1.3984 + * Call each of the "pathInFilesystem" functions in succession. A
1.3985 + * non-return value of -1 indicates the particular function has
1.3986 + * succeeded.
1.3987 + */
1.3988 +
1.3989 + while ((retVal == NULL) && (fsRecPtr != NULL)) {
1.3990 + Tcl_FSPathInFilesystemProc *proc = fsRecPtr->fsPtr->pathInFilesystemProc;
1.3991 + if (proc != NULL) {
1.3992 + ClientData clientData = NULL;
1.3993 + int ret = (*proc)(pathObjPtr, &clientData);
1.3994 + if (ret != -1) {
1.3995 + /*
1.3996 + * We assume the type of pathObjPtr hasn't been changed
1.3997 + * by the above call to the pathInFilesystemProc.
1.3998 + */
1.3999 + TclFSSetPathDetails(pathObjPtr, fsRecPtr, clientData);
1.4000 + retVal = fsRecPtr->fsPtr;
1.4001 + }
1.4002 + }
1.4003 + fsRecPtr = fsRecPtr->nextPtr;
1.4004 + }
1.4005 +
1.4006 + return retVal;
1.4007 +}
1.4008 +
1.4009 +/*
1.4010 + *---------------------------------------------------------------------------
1.4011 + *
1.4012 + * Tcl_FSGetNativePath --
1.4013 + *
1.4014 + * This function is for use by the Win/Unix/MacOS native filesystems,
1.4015 + * so that they can easily retrieve the native (char* or TCHAR*)
1.4016 + * representation of a path. Other filesystems will probably
1.4017 + * want to implement similar functions. They basically act as a
1.4018 + * safety net around Tcl_FSGetInternalRep. Normally your file-
1.4019 + * system procedures will always be called with path objects
1.4020 + * already converted to the correct filesystem, but if for
1.4021 + * some reason they are called directly (i.e. by procedures
1.4022 + * not in this file), then one cannot necessarily guarantee that
1.4023 + * the path object pointer is from the correct filesystem.
1.4024 + *
1.4025 + * Note: in the future it might be desireable to have separate
1.4026 + * versions of this function with different signatures, for
1.4027 + * example Tcl_FSGetNativeMacPath, Tcl_FSGetNativeUnixPath etc.
1.4028 + * Right now, since native paths are all string based, we use just
1.4029 + * one function. On MacOS we could possibly use an FSSpec or
1.4030 + * FSRef as the native representation.
1.4031 + *
1.4032 + * Results:
1.4033 + * NULL or a valid native path.
1.4034 + *
1.4035 + * Side effects:
1.4036 + * See Tcl_FSGetInternalRep.
1.4037 + *
1.4038 + *---------------------------------------------------------------------------
1.4039 + */
1.4040 +
1.4041 +EXPORT_C CONST char *
1.4042 +Tcl_FSGetNativePath(pathObjPtr)
1.4043 + Tcl_Obj *pathObjPtr;
1.4044 +{
1.4045 + return (CONST char *)Tcl_FSGetInternalRep(pathObjPtr, &tclNativeFilesystem);
1.4046 +}
1.4047 +
1.4048 +/*
1.4049 + *---------------------------------------------------------------------------
1.4050 + *
1.4051 + * NativeCreateNativeRep --
1.4052 + *
1.4053 + * Create a native representation for the given path.
1.4054 + *
1.4055 + * Results:
1.4056 + * None.
1.4057 + *
1.4058 + * Side effects:
1.4059 + * None.
1.4060 + *
1.4061 + *---------------------------------------------------------------------------
1.4062 + */
1.4063 +static ClientData
1.4064 +NativeCreateNativeRep(pathObjPtr)
1.4065 + Tcl_Obj* pathObjPtr;
1.4066 +{
1.4067 + char *nativePathPtr;
1.4068 + Tcl_DString ds;
1.4069 + Tcl_Obj* validPathObjPtr;
1.4070 + int len;
1.4071 + char *str;
1.4072 +
1.4073 + /* Make sure the normalized path is set */
1.4074 + validPathObjPtr = Tcl_FSGetNormalizedPath(NULL, pathObjPtr);
1.4075 + if (validPathObjPtr == NULL) {
1.4076 + return NULL;
1.4077 + }
1.4078 +
1.4079 + str = Tcl_GetStringFromObj(validPathObjPtr, &len);
1.4080 +#ifdef __WIN32__
1.4081 + Tcl_WinUtfToTChar(str, len, &ds);
1.4082 + if (tclWinProcs->useWide) {
1.4083 + len = Tcl_DStringLength(&ds) + sizeof(WCHAR);
1.4084 + } else {
1.4085 + len = Tcl_DStringLength(&ds) + sizeof(char);
1.4086 + }
1.4087 +#else
1.4088 + Tcl_UtfToExternalDString(NULL, str, len, &ds);
1.4089 + len = Tcl_DStringLength(&ds) + sizeof(char);
1.4090 +#endif
1.4091 + nativePathPtr = ckalloc((unsigned) len);
1.4092 + memcpy((VOID*)nativePathPtr, (VOID*)Tcl_DStringValue(&ds), (size_t) len);
1.4093 +
1.4094 + Tcl_DStringFree(&ds);
1.4095 + return (ClientData)nativePathPtr;
1.4096 +}
1.4097 +
1.4098 +/*
1.4099 + *---------------------------------------------------------------------------
1.4100 + *
1.4101 + * TclpNativeToNormalized --
1.4102 + *
1.4103 + * Convert native format to a normalized path object, with refCount
1.4104 + * of zero.
1.4105 + *
1.4106 + * Results:
1.4107 + * A valid normalized path.
1.4108 + *
1.4109 + * Side effects:
1.4110 + * None.
1.4111 + *
1.4112 + *---------------------------------------------------------------------------
1.4113 + */
1.4114 +Tcl_Obj*
1.4115 +TclpNativeToNormalized(clientData)
1.4116 + ClientData clientData;
1.4117 +{
1.4118 + Tcl_DString ds;
1.4119 + Tcl_Obj *objPtr;
1.4120 + CONST char *copy;
1.4121 + int len;
1.4122 +
1.4123 +#ifdef __WIN32__
1.4124 + Tcl_WinTCharToUtf((CONST char*)clientData, -1, &ds);
1.4125 +#else
1.4126 + Tcl_ExternalToUtfDString(NULL, (CONST char*)clientData, -1, &ds);
1.4127 +#endif
1.4128 +
1.4129 + copy = Tcl_DStringValue(&ds);
1.4130 + len = Tcl_DStringLength(&ds);
1.4131 +
1.4132 +#ifdef __WIN32__
1.4133 + /*
1.4134 + * Certain native path representations on Windows have this special
1.4135 + * prefix to indicate that they are to be treated specially. For
1.4136 + * example extremely long paths, or symlinks
1.4137 + */
1.4138 + if (*copy == '\\') {
1.4139 + if (0 == strncmp(copy,"\\??\\",4)) {
1.4140 + copy += 4;
1.4141 + len -= 4;
1.4142 + } else if (0 == strncmp(copy,"\\\\?\\",4)) {
1.4143 + copy += 4;
1.4144 + len -= 4;
1.4145 + }
1.4146 + }
1.4147 +#endif
1.4148 +
1.4149 + objPtr = Tcl_NewStringObj(copy,len);
1.4150 + Tcl_DStringFree(&ds);
1.4151 +
1.4152 + return objPtr;
1.4153 +}
1.4154 +
1.4155 +
1.4156 +/*
1.4157 + *---------------------------------------------------------------------------
1.4158 + *
1.4159 + * TclNativeDupInternalRep --
1.4160 + *
1.4161 + * Duplicate the native representation.
1.4162 + *
1.4163 + * Results:
1.4164 + * The copied native representation, or NULL if it is not possible
1.4165 + * to copy the representation.
1.4166 + *
1.4167 + * Side effects:
1.4168 + * None.
1.4169 + *
1.4170 + *---------------------------------------------------------------------------
1.4171 + */
1.4172 +ClientData
1.4173 +TclNativeDupInternalRep(clientData)
1.4174 + ClientData clientData;
1.4175 +{
1.4176 + ClientData copy;
1.4177 + size_t len;
1.4178 +
1.4179 + if (clientData == NULL) {
1.4180 + return NULL;
1.4181 + }
1.4182 +
1.4183 +#ifdef __WIN32__
1.4184 + if (tclWinProcs->useWide) {
1.4185 + /* unicode representation when running on NT/2K/XP */
1.4186 + len = sizeof(WCHAR) + (wcslen((CONST WCHAR*)clientData) * sizeof(WCHAR));
1.4187 + } else {
1.4188 + /* ansi representation when running on 95/98/ME */
1.4189 + len = sizeof(char) + (strlen((CONST char*)clientData) * sizeof(char));
1.4190 + }
1.4191 +#else
1.4192 + /* ansi representation when running on Unix/MacOS */
1.4193 + len = sizeof(char) + (strlen((CONST char*)clientData) * sizeof(char));
1.4194 +#endif
1.4195 +
1.4196 + copy = (ClientData) ckalloc(len);
1.4197 + memcpy((VOID*)copy, (VOID*)clientData, len);
1.4198 + return copy;
1.4199 +}
1.4200 +
1.4201 +/*
1.4202 + *---------------------------------------------------------------------------
1.4203 + *
1.4204 + * NativeFreeInternalRep --
1.4205 + *
1.4206 + * Free a native internal representation, which will be non-NULL.
1.4207 + *
1.4208 + * Results:
1.4209 + * None.
1.4210 + *
1.4211 + * Side effects:
1.4212 + * Memory is released.
1.4213 + *
1.4214 + *---------------------------------------------------------------------------
1.4215 + */
1.4216 +static void
1.4217 +NativeFreeInternalRep(clientData)
1.4218 + ClientData clientData;
1.4219 +{
1.4220 + ckfree((char*)clientData);
1.4221 +}
1.4222 +
1.4223 +/*
1.4224 + *---------------------------------------------------------------------------
1.4225 + *
1.4226 + * Tcl_FSFileSystemInfo --
1.4227 + *
1.4228 + * This function returns a list of two elements. The first
1.4229 + * element is the name of the filesystem (e.g. "native" or "vfs"),
1.4230 + * and the second is the particular type of the given path within
1.4231 + * that filesystem.
1.4232 + *
1.4233 + * Results:
1.4234 + * A list of two elements.
1.4235 + *
1.4236 + * Side effects:
1.4237 + * The object may be converted to a path type.
1.4238 + *
1.4239 + *---------------------------------------------------------------------------
1.4240 + */
1.4241 +EXPORT_C Tcl_Obj*
1.4242 +Tcl_FSFileSystemInfo(pathObjPtr)
1.4243 + Tcl_Obj* pathObjPtr;
1.4244 +{
1.4245 + Tcl_Obj *resPtr;
1.4246 + Tcl_FSFilesystemPathTypeProc *proc;
1.4247 + Tcl_Filesystem *fsPtr = Tcl_FSGetFileSystemForPath(pathObjPtr);
1.4248 +
1.4249 + if (fsPtr == NULL) {
1.4250 + return NULL;
1.4251 + }
1.4252 +
1.4253 + resPtr = Tcl_NewListObj(0,NULL);
1.4254 +
1.4255 + Tcl_ListObjAppendElement(NULL, resPtr,
1.4256 + Tcl_NewStringObj(fsPtr->typeName,-1));
1.4257 +
1.4258 + proc = fsPtr->filesystemPathTypeProc;
1.4259 + if (proc != NULL) {
1.4260 + Tcl_Obj *typePtr = (*proc)(pathObjPtr);
1.4261 + if (typePtr != NULL) {
1.4262 + Tcl_ListObjAppendElement(NULL, resPtr, typePtr);
1.4263 + }
1.4264 + }
1.4265 +
1.4266 + return resPtr;
1.4267 +}
1.4268 +
1.4269 +/*
1.4270 + *---------------------------------------------------------------------------
1.4271 + *
1.4272 + * Tcl_FSPathSeparator --
1.4273 + *
1.4274 + * This function returns the separator to be used for a given
1.4275 + * path. The object returned should have a refCount of zero
1.4276 + *
1.4277 + * Results:
1.4278 + * A Tcl object, with a refCount of zero. If the caller
1.4279 + * needs to retain a reference to the object, it should
1.4280 + * call Tcl_IncrRefCount.
1.4281 + *
1.4282 + * Side effects:
1.4283 + * The path object may be converted to a path type.
1.4284 + *
1.4285 + *---------------------------------------------------------------------------
1.4286 + */
1.4287 +EXPORT_C Tcl_Obj*
1.4288 +Tcl_FSPathSeparator(pathObjPtr)
1.4289 + Tcl_Obj* pathObjPtr;
1.4290 +{
1.4291 + Tcl_Filesystem *fsPtr = Tcl_FSGetFileSystemForPath(pathObjPtr);
1.4292 +
1.4293 + if (fsPtr == NULL) {
1.4294 + return NULL;
1.4295 + }
1.4296 + if (fsPtr->filesystemSeparatorProc != NULL) {
1.4297 + return (*fsPtr->filesystemSeparatorProc)(pathObjPtr);
1.4298 + }
1.4299 +
1.4300 + return NULL;
1.4301 +}
1.4302 +
1.4303 +/*
1.4304 + *---------------------------------------------------------------------------
1.4305 + *
1.4306 + * NativeFilesystemSeparator --
1.4307 + *
1.4308 + * This function is part of the native filesystem support, and
1.4309 + * returns the separator for the given path.
1.4310 + *
1.4311 + * Results:
1.4312 + * String object containing the separator character.
1.4313 + *
1.4314 + * Side effects:
1.4315 + * None.
1.4316 + *
1.4317 + *---------------------------------------------------------------------------
1.4318 + */
1.4319 +static Tcl_Obj*
1.4320 +NativeFilesystemSeparator(pathObjPtr)
1.4321 + Tcl_Obj* pathObjPtr;
1.4322 +{
1.4323 + char *separator = NULL; /* lint */
1.4324 + switch (tclPlatform) {
1.4325 + case TCL_PLATFORM_UNIX:
1.4326 + separator = "/";
1.4327 + break;
1.4328 + case TCL_PLATFORM_WINDOWS:
1.4329 + separator = "\\";
1.4330 + break;
1.4331 + case TCL_PLATFORM_MAC:
1.4332 + separator = ":";
1.4333 + break;
1.4334 + }
1.4335 + return Tcl_NewStringObj(separator,1);
1.4336 +}
1.4337 +
1.4338 +/* Everything from here on is contained in this obsolete ifdef */
1.4339 +#ifdef USE_OBSOLETE_FS_HOOKS
1.4340 +
1.4341 +/*
1.4342 + *----------------------------------------------------------------------
1.4343 + *
1.4344 + * TclStatInsertProc --
1.4345 + *
1.4346 + * Insert the passed procedure pointer at the head of the list of
1.4347 + * functions which are used during a call to 'TclStat(...)'. The
1.4348 + * passed function should behave exactly like 'TclStat' when called
1.4349 + * during that time (see 'TclStat(...)' for more information).
1.4350 + * The function will be added even if it already in the list.
1.4351 + *
1.4352 + * Results:
1.4353 + * Normally TCL_OK; TCL_ERROR if memory for a new node in the list
1.4354 + * could not be allocated.
1.4355 + *
1.4356 + * Side effects:
1.4357 + * Memory allocated and modifies the link list for 'TclStat'
1.4358 + * functions.
1.4359 + *
1.4360 + *----------------------------------------------------------------------
1.4361 + */
1.4362 +
1.4363 +int
1.4364 +TclStatInsertProc (proc)
1.4365 + TclStatProc_ *proc;
1.4366 +{
1.4367 + int retVal = TCL_ERROR;
1.4368 +
1.4369 + if (proc != NULL) {
1.4370 + StatProc *newStatProcPtr;
1.4371 +
1.4372 + newStatProcPtr = (StatProc *)ckalloc(sizeof(StatProc));
1.4373 +
1.4374 + if (newStatProcPtr != NULL) {
1.4375 + newStatProcPtr->proc = proc;
1.4376 + Tcl_MutexLock(&obsoleteFsHookMutex);
1.4377 + newStatProcPtr->nextPtr = statProcList;
1.4378 + statProcList = newStatProcPtr;
1.4379 + Tcl_MutexUnlock(&obsoleteFsHookMutex);
1.4380 +
1.4381 + retVal = TCL_OK;
1.4382 + }
1.4383 + }
1.4384 +
1.4385 + return retVal;
1.4386 +}
1.4387 +
1.4388 +/*
1.4389 + *----------------------------------------------------------------------
1.4390 + *
1.4391 + * TclStatDeleteProc --
1.4392 + *
1.4393 + * Removed the passed function pointer from the list of 'TclStat'
1.4394 + * functions. Ensures that the built-in stat function is not
1.4395 + * removvable.
1.4396 + *
1.4397 + * Results:
1.4398 + * TCL_OK if the procedure pointer was successfully removed,
1.4399 + * TCL_ERROR otherwise.
1.4400 + *
1.4401 + * Side effects:
1.4402 + * Memory is deallocated and the respective list updated.
1.4403 + *
1.4404 + *----------------------------------------------------------------------
1.4405 + */
1.4406 +
1.4407 +int
1.4408 +TclStatDeleteProc (proc)
1.4409 + TclStatProc_ *proc;
1.4410 +{
1.4411 + int retVal = TCL_ERROR;
1.4412 + StatProc *tmpStatProcPtr;
1.4413 + StatProc *prevStatProcPtr = NULL;
1.4414 +
1.4415 + Tcl_MutexLock(&obsoleteFsHookMutex);
1.4416 + tmpStatProcPtr = statProcList;
1.4417 + /*
1.4418 + * Traverse the 'statProcList' looking for the particular node
1.4419 + * whose 'proc' member matches 'proc' and remove that one from
1.4420 + * the list. Ensure that the "default" node cannot be removed.
1.4421 + */
1.4422 +
1.4423 + while ((retVal == TCL_ERROR) && (tmpStatProcPtr != NULL)) {
1.4424 + if (tmpStatProcPtr->proc == proc) {
1.4425 + if (prevStatProcPtr == NULL) {
1.4426 + statProcList = tmpStatProcPtr->nextPtr;
1.4427 + } else {
1.4428 + prevStatProcPtr->nextPtr = tmpStatProcPtr->nextPtr;
1.4429 + }
1.4430 +
1.4431 + ckfree((char *)tmpStatProcPtr);
1.4432 +
1.4433 + retVal = TCL_OK;
1.4434 + } else {
1.4435 + prevStatProcPtr = tmpStatProcPtr;
1.4436 + tmpStatProcPtr = tmpStatProcPtr->nextPtr;
1.4437 + }
1.4438 + }
1.4439 +
1.4440 + Tcl_MutexUnlock(&obsoleteFsHookMutex);
1.4441 +
1.4442 + return retVal;
1.4443 +}
1.4444 +
1.4445 +/*
1.4446 + *----------------------------------------------------------------------
1.4447 + *
1.4448 + * TclAccessInsertProc --
1.4449 + *
1.4450 + * Insert the passed procedure pointer at the head of the list of
1.4451 + * functions which are used during a call to 'TclAccess(...)'.
1.4452 + * The passed function should behave exactly like 'TclAccess' when
1.4453 + * called during that time (see 'TclAccess(...)' for more
1.4454 + * information). The function will be added even if it already in
1.4455 + * the list.
1.4456 + *
1.4457 + * Results:
1.4458 + * Normally TCL_OK; TCL_ERROR if memory for a new node in the list
1.4459 + * could not be allocated.
1.4460 + *
1.4461 + * Side effects:
1.4462 + * Memory allocated and modifies the link list for 'TclAccess'
1.4463 + * functions.
1.4464 + *
1.4465 + *----------------------------------------------------------------------
1.4466 + */
1.4467 +
1.4468 +int
1.4469 +TclAccessInsertProc(proc)
1.4470 + TclAccessProc_ *proc;
1.4471 +{
1.4472 + int retVal = TCL_ERROR;
1.4473 +
1.4474 + if (proc != NULL) {
1.4475 + AccessProc *newAccessProcPtr;
1.4476 +
1.4477 + newAccessProcPtr = (AccessProc *)ckalloc(sizeof(AccessProc));
1.4478 +
1.4479 + if (newAccessProcPtr != NULL) {
1.4480 + newAccessProcPtr->proc = proc;
1.4481 + Tcl_MutexLock(&obsoleteFsHookMutex);
1.4482 + newAccessProcPtr->nextPtr = accessProcList;
1.4483 + accessProcList = newAccessProcPtr;
1.4484 + Tcl_MutexUnlock(&obsoleteFsHookMutex);
1.4485 +
1.4486 + retVal = TCL_OK;
1.4487 + }
1.4488 + }
1.4489 +
1.4490 + return retVal;
1.4491 +}
1.4492 +
1.4493 +/*
1.4494 + *----------------------------------------------------------------------
1.4495 + *
1.4496 + * TclAccessDeleteProc --
1.4497 + *
1.4498 + * Removed the passed function pointer from the list of 'TclAccess'
1.4499 + * functions. Ensures that the built-in access function is not
1.4500 + * removvable.
1.4501 + *
1.4502 + * Results:
1.4503 + * TCL_OK if the procedure pointer was successfully removed,
1.4504 + * TCL_ERROR otherwise.
1.4505 + *
1.4506 + * Side effects:
1.4507 + * Memory is deallocated and the respective list updated.
1.4508 + *
1.4509 + *----------------------------------------------------------------------
1.4510 + */
1.4511 +
1.4512 +int
1.4513 +TclAccessDeleteProc(proc)
1.4514 + TclAccessProc_ *proc;
1.4515 +{
1.4516 + int retVal = TCL_ERROR;
1.4517 + AccessProc *tmpAccessProcPtr;
1.4518 + AccessProc *prevAccessProcPtr = NULL;
1.4519 +
1.4520 + /*
1.4521 + * Traverse the 'accessProcList' looking for the particular node
1.4522 + * whose 'proc' member matches 'proc' and remove that one from
1.4523 + * the list. Ensure that the "default" node cannot be removed.
1.4524 + */
1.4525 +
1.4526 + Tcl_MutexLock(&obsoleteFsHookMutex);
1.4527 + tmpAccessProcPtr = accessProcList;
1.4528 + while ((retVal == TCL_ERROR) && (tmpAccessProcPtr != NULL)) {
1.4529 + if (tmpAccessProcPtr->proc == proc) {
1.4530 + if (prevAccessProcPtr == NULL) {
1.4531 + accessProcList = tmpAccessProcPtr->nextPtr;
1.4532 + } else {
1.4533 + prevAccessProcPtr->nextPtr = tmpAccessProcPtr->nextPtr;
1.4534 + }
1.4535 +
1.4536 + ckfree((char *)tmpAccessProcPtr);
1.4537 +
1.4538 + retVal = TCL_OK;
1.4539 + } else {
1.4540 + prevAccessProcPtr = tmpAccessProcPtr;
1.4541 + tmpAccessProcPtr = tmpAccessProcPtr->nextPtr;
1.4542 + }
1.4543 + }
1.4544 + Tcl_MutexUnlock(&obsoleteFsHookMutex);
1.4545 +
1.4546 + return retVal;
1.4547 +}
1.4548 +
1.4549 +/*
1.4550 + *----------------------------------------------------------------------
1.4551 + *
1.4552 + * TclOpenFileChannelInsertProc --
1.4553 + *
1.4554 + * Insert the passed procedure pointer at the head of the list of
1.4555 + * functions which are used during a call to
1.4556 + * 'Tcl_OpenFileChannel(...)'. The passed function should behave
1.4557 + * exactly like 'Tcl_OpenFileChannel' when called during that time
1.4558 + * (see 'Tcl_OpenFileChannel(...)' for more information). The
1.4559 + * function will be added even if it already in the list.
1.4560 + *
1.4561 + * Results:
1.4562 + * Normally TCL_OK; TCL_ERROR if memory for a new node in the list
1.4563 + * could not be allocated.
1.4564 + *
1.4565 + * Side effects:
1.4566 + * Memory allocated and modifies the link list for
1.4567 + * 'Tcl_OpenFileChannel' functions.
1.4568 + *
1.4569 + *----------------------------------------------------------------------
1.4570 + */
1.4571 +
1.4572 +int
1.4573 +TclOpenFileChannelInsertProc(proc)
1.4574 + TclOpenFileChannelProc_ *proc;
1.4575 +{
1.4576 + int retVal = TCL_ERROR;
1.4577 +
1.4578 + if (proc != NULL) {
1.4579 + OpenFileChannelProc *newOpenFileChannelProcPtr;
1.4580 +
1.4581 + newOpenFileChannelProcPtr =
1.4582 + (OpenFileChannelProc *)ckalloc(sizeof(OpenFileChannelProc));
1.4583 +
1.4584 + if (newOpenFileChannelProcPtr != NULL) {
1.4585 + newOpenFileChannelProcPtr->proc = proc;
1.4586 + Tcl_MutexLock(&obsoleteFsHookMutex);
1.4587 + newOpenFileChannelProcPtr->nextPtr = openFileChannelProcList;
1.4588 + openFileChannelProcList = newOpenFileChannelProcPtr;
1.4589 + Tcl_MutexUnlock(&obsoleteFsHookMutex);
1.4590 +
1.4591 + retVal = TCL_OK;
1.4592 + }
1.4593 + }
1.4594 +
1.4595 + return retVal;
1.4596 +}
1.4597 +
1.4598 +/*
1.4599 + *----------------------------------------------------------------------
1.4600 + *
1.4601 + * TclOpenFileChannelDeleteProc --
1.4602 + *
1.4603 + * Removed the passed function pointer from the list of
1.4604 + * 'Tcl_OpenFileChannel' functions. Ensures that the built-in
1.4605 + * open file channel function is not removable.
1.4606 + *
1.4607 + * Results:
1.4608 + * TCL_OK if the procedure pointer was successfully removed,
1.4609 + * TCL_ERROR otherwise.
1.4610 + *
1.4611 + * Side effects:
1.4612 + * Memory is deallocated and the respective list updated.
1.4613 + *
1.4614 + *----------------------------------------------------------------------
1.4615 + */
1.4616 +
1.4617 +int
1.4618 +TclOpenFileChannelDeleteProc(proc)
1.4619 + TclOpenFileChannelProc_ *proc;
1.4620 +{
1.4621 + int retVal = TCL_ERROR;
1.4622 + OpenFileChannelProc *tmpOpenFileChannelProcPtr = openFileChannelProcList;
1.4623 + OpenFileChannelProc *prevOpenFileChannelProcPtr = NULL;
1.4624 +
1.4625 + /*
1.4626 + * Traverse the 'openFileChannelProcList' looking for the particular
1.4627 + * node whose 'proc' member matches 'proc' and remove that one from
1.4628 + * the list.
1.4629 + */
1.4630 +
1.4631 + Tcl_MutexLock(&obsoleteFsHookMutex);
1.4632 + tmpOpenFileChannelProcPtr = openFileChannelProcList;
1.4633 + while ((retVal == TCL_ERROR) &&
1.4634 + (tmpOpenFileChannelProcPtr != NULL)) {
1.4635 + if (tmpOpenFileChannelProcPtr->proc == proc) {
1.4636 + if (prevOpenFileChannelProcPtr == NULL) {
1.4637 + openFileChannelProcList = tmpOpenFileChannelProcPtr->nextPtr;
1.4638 + } else {
1.4639 + prevOpenFileChannelProcPtr->nextPtr =
1.4640 + tmpOpenFileChannelProcPtr->nextPtr;
1.4641 + }
1.4642 +
1.4643 + ckfree((char *)tmpOpenFileChannelProcPtr);
1.4644 +
1.4645 + retVal = TCL_OK;
1.4646 + } else {
1.4647 + prevOpenFileChannelProcPtr = tmpOpenFileChannelProcPtr;
1.4648 + tmpOpenFileChannelProcPtr = tmpOpenFileChannelProcPtr->nextPtr;
1.4649 + }
1.4650 + }
1.4651 + Tcl_MutexUnlock(&obsoleteFsHookMutex);
1.4652 +
1.4653 + return retVal;
1.4654 +}
1.4655 +#endif /* USE_OBSOLETE_FS_HOOKS */
1.4656 +
1.4657 +
1.4658 +/*
1.4659 + * Prototypes for procedures defined later in this file.
1.4660 + */
1.4661 +
1.4662 +static void DupFsPathInternalRep _ANSI_ARGS_((Tcl_Obj *srcPtr,
1.4663 + Tcl_Obj *copyPtr));
1.4664 +static void FreeFsPathInternalRep _ANSI_ARGS_((Tcl_Obj *listPtr));
1.4665 +static void UpdateStringOfFsPath _ANSI_ARGS_((Tcl_Obj *objPtr));
1.4666 +static int SetFsPathFromAny _ANSI_ARGS_((Tcl_Interp *interp,
1.4667 + Tcl_Obj *objPtr));
1.4668 +static int FindSplitPos _ANSI_ARGS_((char *path, char *separator));
1.4669 +
1.4670 +
1.4671 +
1.4672 +/*
1.4673 + * Define the 'path' object type, which Tcl uses to represent
1.4674 + * file paths internally.
1.4675 + */
1.4676 +static Tcl_ObjType tclFsPathType = {
1.4677 + "path", /* name */
1.4678 + FreeFsPathInternalRep, /* freeIntRepProc */
1.4679 + DupFsPathInternalRep, /* dupIntRepProc */
1.4680 + UpdateStringOfFsPath, /* updateStringProc */
1.4681 + SetFsPathFromAny /* setFromAnyProc */
1.4682 +};
1.4683 +
1.4684 +/*
1.4685 + * struct FsPath --
1.4686 + *
1.4687 + * Internal representation of a Tcl_Obj of "path" type. This
1.4688 + * can be used to represent relative or absolute paths, and has
1.4689 + * certain optimisations when used to represent paths which are
1.4690 + * already normalized and absolute.
1.4691 + *
1.4692 + * Note that 'normPathPtr' can be a circular reference to the
1.4693 + * container Tcl_Obj of this FsPath.
1.4694 + */
1.4695 +typedef struct FsPath {
1.4696 + Tcl_Obj *translatedPathPtr; /* Name without any ~user sequences.
1.4697 + * If this is NULL, then this is a
1.4698 + * pure normalized, absolute path
1.4699 + * object, in which the parent Tcl_Obj's
1.4700 + * string rep is already both translated
1.4701 + * and normalized. */
1.4702 + Tcl_Obj *normPathPtr; /* Normalized absolute path, without
1.4703 + * ., .. or ~user sequences. If the
1.4704 + * Tcl_Obj containing
1.4705 + * this FsPath is already normalized,
1.4706 + * this may be a circular reference back
1.4707 + * to the container. If that is NOT the
1.4708 + * case, we have a refCount on the object. */
1.4709 + Tcl_Obj *cwdPtr; /* If null, path is absolute, else
1.4710 + * this points to the cwd object used
1.4711 + * for this path. We have a refCount
1.4712 + * on the object. */
1.4713 + int flags; /* Flags to describe interpretation */
1.4714 + ClientData nativePathPtr; /* Native representation of this path,
1.4715 + * which is filesystem dependent. */
1.4716 + int filesystemEpoch; /* Used to ensure the path representation
1.4717 + * was generated during the correct
1.4718 + * filesystem epoch. The epoch changes
1.4719 + * when filesystem-mounts are changed. */
1.4720 + struct FilesystemRecord *fsRecPtr;
1.4721 + /* Pointer to the filesystem record
1.4722 + * entry to use for this path. */
1.4723 +} FsPath;
1.4724 +
1.4725 +/*
1.4726 + * Define some macros to give us convenient access to path-object
1.4727 + * specific fields.
1.4728 + */
1.4729 +#define PATHOBJ(objPtr) (objPtr->internalRep.otherValuePtr)
1.4730 +#define PATHFLAGS(objPtr) \
1.4731 + (((FsPath*)(objPtr->internalRep.otherValuePtr))->flags)
1.4732 +
1.4733 +#define TCLPATH_APPENDED 1
1.4734 +#define TCLPATH_RELATIVE 2
1.4735 +
1.4736 +/*
1.4737 + *----------------------------------------------------------------------
1.4738 + *
1.4739 + * Tcl_FSGetPathType --
1.4740 + *
1.4741 + * Determines whether a given path is relative to the current
1.4742 + * directory, relative to the current volume, or absolute.
1.4743 + *
1.4744 + * Results:
1.4745 + * Returns one of TCL_PATH_ABSOLUTE, TCL_PATH_RELATIVE, or
1.4746 + * TCL_PATH_VOLUME_RELATIVE.
1.4747 + *
1.4748 + * Side effects:
1.4749 + * None.
1.4750 + *
1.4751 + *----------------------------------------------------------------------
1.4752 + */
1.4753 +
1.4754 +EXPORT_C Tcl_PathType
1.4755 +Tcl_FSGetPathType(pathObjPtr)
1.4756 + Tcl_Obj *pathObjPtr;
1.4757 +{
1.4758 + return FSGetPathType(pathObjPtr, NULL, NULL);
1.4759 +}
1.4760 +
1.4761 +/*
1.4762 + *----------------------------------------------------------------------
1.4763 + *
1.4764 + * FSGetPathType --
1.4765 + *
1.4766 + * Determines whether a given path is relative to the current
1.4767 + * directory, relative to the current volume, or absolute. If the
1.4768 + * caller wishes to know which filesystem claimed the path (in the
1.4769 + * case for which the path is absolute), then a reference to a
1.4770 + * filesystem pointer can be passed in (but passing NULL is
1.4771 + * acceptable).
1.4772 + *
1.4773 + * Results:
1.4774 + * Returns one of TCL_PATH_ABSOLUTE, TCL_PATH_RELATIVE, or
1.4775 + * TCL_PATH_VOLUME_RELATIVE. The filesystem reference will
1.4776 + * be set if and only if it is non-NULL and the function's
1.4777 + * return value is TCL_PATH_ABSOLUTE.
1.4778 + *
1.4779 + * Side effects:
1.4780 + * None.
1.4781 + *
1.4782 + *----------------------------------------------------------------------
1.4783 + */
1.4784 +
1.4785 +static Tcl_PathType
1.4786 +FSGetPathType(pathObjPtr, filesystemPtrPtr, driveNameLengthPtr)
1.4787 + Tcl_Obj *pathObjPtr;
1.4788 + Tcl_Filesystem **filesystemPtrPtr;
1.4789 + int *driveNameLengthPtr;
1.4790 +{
1.4791 + if (Tcl_FSConvertToPathType(NULL, pathObjPtr) != TCL_OK) {
1.4792 + return GetPathType(pathObjPtr, filesystemPtrPtr,
1.4793 + driveNameLengthPtr, NULL);
1.4794 + } else {
1.4795 + FsPath *fsPathPtr = (FsPath*) PATHOBJ(pathObjPtr);
1.4796 + if (fsPathPtr->cwdPtr != NULL) {
1.4797 + if (PATHFLAGS(pathObjPtr) == 0) {
1.4798 + return TCL_PATH_RELATIVE;
1.4799 + }
1.4800 + return FSGetPathType(fsPathPtr->cwdPtr, filesystemPtrPtr,
1.4801 + driveNameLengthPtr);
1.4802 + } else {
1.4803 + return GetPathType(pathObjPtr, filesystemPtrPtr,
1.4804 + driveNameLengthPtr, NULL);
1.4805 + }
1.4806 + }
1.4807 +}
1.4808 +
1.4809 +/*
1.4810 + *---------------------------------------------------------------------------
1.4811 + *
1.4812 + * Tcl_FSJoinPath --
1.4813 + *
1.4814 + * This function takes the given Tcl_Obj, which should be a valid
1.4815 + * list, and returns the path object given by considering the
1.4816 + * first 'elements' elements as valid path segments. If elements < 0,
1.4817 + * we use the entire list.
1.4818 + *
1.4819 + * Results:
1.4820 + * Returns object with refCount of zero, (or if non-zero, it has
1.4821 + * references elsewhere in Tcl). Either way, the caller must
1.4822 + * increment its refCount before use.
1.4823 + *
1.4824 + * Side effects:
1.4825 + * None.
1.4826 + *
1.4827 + *---------------------------------------------------------------------------
1.4828 + */
1.4829 +EXPORT_C Tcl_Obj*
1.4830 +Tcl_FSJoinPath(listObj, elements)
1.4831 + Tcl_Obj *listObj;
1.4832 + int elements;
1.4833 +{
1.4834 + Tcl_Obj *res;
1.4835 + int i;
1.4836 + Tcl_Filesystem *fsPtr = NULL;
1.4837 +
1.4838 + if (elements < 0) {
1.4839 + if (Tcl_ListObjLength(NULL, listObj, &elements) != TCL_OK) {
1.4840 + return NULL;
1.4841 + }
1.4842 + } else {
1.4843 + /* Just make sure it is a valid list */
1.4844 + int listTest;
1.4845 + if (Tcl_ListObjLength(NULL, listObj, &listTest) != TCL_OK) {
1.4846 + return NULL;
1.4847 + }
1.4848 + /*
1.4849 + * Correct this if it is too large, otherwise we will
1.4850 + * waste our time joining null elements to the path
1.4851 + */
1.4852 + if (elements > listTest) {
1.4853 + elements = listTest;
1.4854 + }
1.4855 + }
1.4856 +
1.4857 + res = Tcl_NewObj();
1.4858 +
1.4859 + for (i = 0; i < elements; i++) {
1.4860 + Tcl_Obj *elt;
1.4861 + int driveNameLength;
1.4862 + Tcl_PathType type;
1.4863 + char *strElt;
1.4864 + int strEltLen;
1.4865 + int length;
1.4866 + char *ptr;
1.4867 + Tcl_Obj *driveName = NULL;
1.4868 +
1.4869 + Tcl_ListObjIndex(NULL, listObj, i, &elt);
1.4870 +
1.4871 + /*
1.4872 + * This is a special case where we can be much more
1.4873 + * efficient, where we are joining a single relative path
1.4874 + * onto an object that is already of path type. The
1.4875 + * 'TclNewFSPathObj' call below creates an object which
1.4876 + * can be normalized more efficiently. Currently we only
1.4877 + * use the special case when we have exactly two elements,
1.4878 + * but we could expand that in the future.
1.4879 + */
1.4880 + if ((i == (elements-2)) && (i == 0) && (elt->typePtr == &tclFsPathType)
1.4881 + && !(elt->bytes != NULL && (elt->bytes[0] == '\0'))) {
1.4882 + Tcl_Obj *tail;
1.4883 + Tcl_PathType type;
1.4884 + Tcl_ListObjIndex(NULL, listObj, i+1, &tail);
1.4885 + type = GetPathType(tail, NULL, NULL, NULL);
1.4886 + if (type == TCL_PATH_RELATIVE) {
1.4887 + CONST char *str;
1.4888 + int len;
1.4889 + str = Tcl_GetStringFromObj(tail,&len);
1.4890 + if (len == 0) {
1.4891 + /*
1.4892 + * This happens if we try to handle the root volume
1.4893 + * '/'. There's no need to return a special path
1.4894 + * object, when the base itself is just fine!
1.4895 + */
1.4896 + Tcl_DecrRefCount(res);
1.4897 + return elt;
1.4898 + }
1.4899 + /*
1.4900 + * If it doesn't begin with '.' and is a mac or unix
1.4901 + * path or it a windows path without backslashes, then we
1.4902 + * can be very efficient here. (In fact even a windows
1.4903 + * path with backslashes can be joined efficiently, but
1.4904 + * the path object would not have forward slashes only,
1.4905 + * and this would therefore contradict our 'file join'
1.4906 + * documentation).
1.4907 + */
1.4908 + if (str[0] != '.' && ((tclPlatform != TCL_PLATFORM_WINDOWS)
1.4909 + || (strchr(str, '\\') == NULL))) {
1.4910 + /*
1.4911 + * Finally, on Windows, 'file join' is defined to
1.4912 + * convert all backslashes to forward slashes,
1.4913 + * so the base part cannot have backslashes either.
1.4914 + */
1.4915 + if ((tclPlatform != TCL_PLATFORM_WINDOWS)
1.4916 + || (strchr(Tcl_GetString(elt), '\\') == NULL)) {
1.4917 + if (res != NULL) {
1.4918 + TclDecrRefCount(res);
1.4919 + }
1.4920 + return TclNewFSPathObj(elt, str, len);
1.4921 + }
1.4922 + }
1.4923 + /*
1.4924 + * Otherwise we don't have an easy join, and
1.4925 + * we must let the more general code below handle
1.4926 + * things
1.4927 + */
1.4928 + } else {
1.4929 + if (tclPlatform == TCL_PLATFORM_UNIX) {
1.4930 + Tcl_DecrRefCount(res);
1.4931 + return tail;
1.4932 + } else {
1.4933 + CONST char *str;
1.4934 + int len;
1.4935 + str = Tcl_GetStringFromObj(tail,&len);
1.4936 + if (tclPlatform == TCL_PLATFORM_WINDOWS) {
1.4937 + if (strchr(str, '\\') == NULL) {
1.4938 + Tcl_DecrRefCount(res);
1.4939 + return tail;
1.4940 + }
1.4941 + } else if (tclPlatform == TCL_PLATFORM_MAC) {
1.4942 + if (strchr(str, '/') == NULL) {
1.4943 + Tcl_DecrRefCount(res);
1.4944 + return tail;
1.4945 + }
1.4946 + }
1.4947 + }
1.4948 + }
1.4949 + }
1.4950 + strElt = Tcl_GetStringFromObj(elt, &strEltLen);
1.4951 + type = GetPathType(elt, &fsPtr, &driveNameLength, &driveName);
1.4952 + if (type != TCL_PATH_RELATIVE) {
1.4953 + /* Zero out the current result */
1.4954 + Tcl_DecrRefCount(res);
1.4955 + if (driveName != NULL) {
1.4956 + res = Tcl_DuplicateObj(driveName);
1.4957 + Tcl_DecrRefCount(driveName);
1.4958 + } else {
1.4959 + res = Tcl_NewStringObj(strElt, driveNameLength);
1.4960 + }
1.4961 + strElt += driveNameLength;
1.4962 + }
1.4963 +
1.4964 + ptr = Tcl_GetStringFromObj(res, &length);
1.4965 +
1.4966 + /*
1.4967 + * Strip off any './' before a tilde, unless this is the
1.4968 + * beginning of the path.
1.4969 + */
1.4970 + if (length > 0 && strEltLen > 0) {
1.4971 + if ((strElt[0] == '.') && (strElt[1] == '/')
1.4972 + && (strElt[2] == '~')) {
1.4973 + strElt += 2;
1.4974 + }
1.4975 + }
1.4976 +
1.4977 + /*
1.4978 + * A NULL value for fsPtr at this stage basically means
1.4979 + * we're trying to join a relative path onto something
1.4980 + * which is also relative (or empty). There's nothing
1.4981 + * particularly wrong with that.
1.4982 + */
1.4983 + if (*strElt == '\0') continue;
1.4984 +
1.4985 + if (fsPtr == &tclNativeFilesystem || fsPtr == NULL) {
1.4986 + TclpNativeJoinPath(res, strElt);
1.4987 + } else {
1.4988 + char separator = '/';
1.4989 + int needsSep = 0;
1.4990 +
1.4991 + if (fsPtr->filesystemSeparatorProc != NULL) {
1.4992 + Tcl_Obj *sep = (*fsPtr->filesystemSeparatorProc)(res);
1.4993 + if (sep != NULL) {
1.4994 + separator = Tcl_GetString(sep)[0];
1.4995 + }
1.4996 + }
1.4997 +
1.4998 + if (length > 0 && ptr[length -1] != '/') {
1.4999 + Tcl_AppendToObj(res, &separator, 1);
1.5000 + length++;
1.5001 + }
1.5002 + Tcl_SetObjLength(res, length + (int) strlen(strElt));
1.5003 +
1.5004 + ptr = Tcl_GetString(res) + length;
1.5005 + for (; *strElt != '\0'; strElt++) {
1.5006 + if (*strElt == separator) {
1.5007 + while (strElt[1] == separator) {
1.5008 + strElt++;
1.5009 + }
1.5010 + if (strElt[1] != '\0') {
1.5011 + if (needsSep) {
1.5012 + *ptr++ = separator;
1.5013 + }
1.5014 + }
1.5015 + } else {
1.5016 + *ptr++ = *strElt;
1.5017 + needsSep = 1;
1.5018 + }
1.5019 + }
1.5020 + length = ptr - Tcl_GetString(res);
1.5021 + Tcl_SetObjLength(res, length);
1.5022 + }
1.5023 + }
1.5024 + return res;
1.5025 +}
1.5026 +
1.5027 +/*
1.5028 + *---------------------------------------------------------------------------
1.5029 + *
1.5030 + * Tcl_FSConvertToPathType --
1.5031 + *
1.5032 + * This function tries to convert the given Tcl_Obj to a valid
1.5033 + * Tcl path type, taking account of the fact that the cwd may
1.5034 + * have changed even if this object is already supposedly of
1.5035 + * the correct type.
1.5036 + *
1.5037 + * The filename may begin with "~" (to indicate current user's
1.5038 + * home directory) or "~<user>" (to indicate any user's home
1.5039 + * directory).
1.5040 + *
1.5041 + * Results:
1.5042 + * Standard Tcl error code.
1.5043 + *
1.5044 + * Side effects:
1.5045 + * The old representation may be freed, and new memory allocated.
1.5046 + *
1.5047 + *---------------------------------------------------------------------------
1.5048 + */
1.5049 +EXPORT_C int
1.5050 +Tcl_FSConvertToPathType(interp, objPtr)
1.5051 + Tcl_Interp *interp; /* Interpreter in which to store error
1.5052 + * message (if necessary). */
1.5053 + Tcl_Obj *objPtr; /* Object to convert to a valid, current
1.5054 + * path type. */
1.5055 +{
1.5056 + ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);
1.5057 +
1.5058 + /*
1.5059 + * While it is bad practice to examine an object's type directly,
1.5060 + * this is actually the best thing to do here. The reason is that
1.5061 + * if we are converting this object to FsPath type for the first
1.5062 + * time, we don't need to worry whether the 'cwd' has changed.
1.5063 + * On the other hand, if this object is already of FsPath type,
1.5064 + * and is a relative path, we do have to worry about the cwd.
1.5065 + * If the cwd has changed, we must recompute the path.
1.5066 + */
1.5067 + if (objPtr->typePtr == &tclFsPathType) {
1.5068 + FsPath *fsPathPtr = (FsPath*) PATHOBJ(objPtr);
1.5069 + if (fsPathPtr->filesystemEpoch != tsdPtr->filesystemEpoch) {
1.5070 + if (objPtr->bytes == NULL) {
1.5071 + UpdateStringOfFsPath(objPtr);
1.5072 + }
1.5073 + FreeFsPathInternalRep(objPtr);
1.5074 + objPtr->typePtr = NULL;
1.5075 + return Tcl_ConvertToType(interp, objPtr, &tclFsPathType);
1.5076 + }
1.5077 + return TCL_OK;
1.5078 + } else {
1.5079 + return Tcl_ConvertToType(interp, objPtr, &tclFsPathType);
1.5080 + }
1.5081 +}
1.5082 +
1.5083 +/*
1.5084 + * Helper function for SetFsPathFromAny. Returns position of first
1.5085 + * directory delimiter in the path.
1.5086 + */
1.5087 +static int
1.5088 +FindSplitPos(path, separator)
1.5089 + char *path;
1.5090 + char *separator;
1.5091 +{
1.5092 + int count = 0;
1.5093 + switch (tclPlatform) {
1.5094 + case TCL_PLATFORM_UNIX:
1.5095 + case TCL_PLATFORM_MAC:
1.5096 + while (path[count] != 0) {
1.5097 + if (path[count] == *separator) {
1.5098 + return count;
1.5099 + }
1.5100 + count++;
1.5101 + }
1.5102 + break;
1.5103 +
1.5104 + case TCL_PLATFORM_WINDOWS:
1.5105 + while (path[count] != 0) {
1.5106 + if (path[count] == *separator || path[count] == '\\') {
1.5107 + return count;
1.5108 + }
1.5109 + count++;
1.5110 + }
1.5111 + break;
1.5112 + }
1.5113 + return count;
1.5114 +}
1.5115 +
1.5116 +/*
1.5117 + *---------------------------------------------------------------------------
1.5118 + *
1.5119 + * TclNewFSPathObj --
1.5120 + *
1.5121 + * Creates a path object whose string representation is
1.5122 + * '[file join dirPtr addStrRep]', but does so in a way that
1.5123 + * allows for more efficient caching of normalized paths.
1.5124 + *
1.5125 + * Assumptions:
1.5126 + * 'dirPtr' must be an absolute path.
1.5127 + * 'len' may not be zero.
1.5128 + *
1.5129 + * Results:
1.5130 + * The new Tcl object, with refCount zero.
1.5131 + *
1.5132 + * Side effects:
1.5133 + * Memory is allocated. 'dirPtr' gets an additional refCount.
1.5134 + *
1.5135 + *---------------------------------------------------------------------------
1.5136 + */
1.5137 +
1.5138 +Tcl_Obj*
1.5139 +TclNewFSPathObj(Tcl_Obj *dirPtr, CONST char *addStrRep, int len)
1.5140 +{
1.5141 + FsPath *fsPathPtr;
1.5142 + Tcl_Obj *objPtr;
1.5143 + ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);
1.5144 +
1.5145 + objPtr = Tcl_NewObj();
1.5146 + fsPathPtr = (FsPath*)ckalloc((unsigned)sizeof(FsPath));
1.5147 +
1.5148 + if (tclPlatform == TCL_PLATFORM_MAC) {
1.5149 + /*
1.5150 + * Mac relative paths may begin with a directory separator ':'.
1.5151 + * If present, we need to skip this ':' because we assume that
1.5152 + * we can join dirPtr and addStrRep by concatenating them as
1.5153 + * strings (and we ensure that dirPtr is terminated by a ':').
1.5154 + */
1.5155 + if (addStrRep[0] == ':') {
1.5156 + addStrRep++;
1.5157 + len--;
1.5158 + }
1.5159 + }
1.5160 + /* Setup the path */
1.5161 + fsPathPtr->translatedPathPtr = NULL;
1.5162 + fsPathPtr->normPathPtr = Tcl_NewStringObj(addStrRep, len);
1.5163 + Tcl_IncrRefCount(fsPathPtr->normPathPtr);
1.5164 + fsPathPtr->cwdPtr = dirPtr;
1.5165 + Tcl_IncrRefCount(dirPtr);
1.5166 + fsPathPtr->nativePathPtr = NULL;
1.5167 + fsPathPtr->fsRecPtr = NULL;
1.5168 + fsPathPtr->filesystemEpoch = tsdPtr->filesystemEpoch;
1.5169 +
1.5170 + PATHOBJ(objPtr) = (VOID *) fsPathPtr;
1.5171 + PATHFLAGS(objPtr) = TCLPATH_RELATIVE | TCLPATH_APPENDED;
1.5172 + objPtr->typePtr = &tclFsPathType;
1.5173 + objPtr->bytes = NULL;
1.5174 + objPtr->length = 0;
1.5175 +
1.5176 + return objPtr;
1.5177 +}
1.5178 +
1.5179 +/*
1.5180 + *---------------------------------------------------------------------------
1.5181 + *
1.5182 + * TclFSMakePathRelative --
1.5183 + *
1.5184 + * Only for internal use.
1.5185 + *
1.5186 + * Takes a path and a directory, where we _assume_ both path and
1.5187 + * directory are absolute, normalized and that the path lies
1.5188 + * inside the directory. Returns a Tcl_Obj representing filename
1.5189 + * of the path relative to the directory.
1.5190 + *
1.5191 + * In the case where the resulting path would start with a '~', we
1.5192 + * take special care to return an ordinary string. This means to
1.5193 + * use that path (and not have it interpreted as a user name),
1.5194 + * one must prepend './'. This may seem strange, but that is how
1.5195 + * 'glob' is currently defined.
1.5196 + *
1.5197 + * Results:
1.5198 + * NULL on error, otherwise a valid object, typically with
1.5199 + * refCount of zero, which it is assumed the caller will
1.5200 + * increment.
1.5201 + *
1.5202 + * Side effects:
1.5203 + * The old representation may be freed, and new memory allocated.
1.5204 + *
1.5205 + *---------------------------------------------------------------------------
1.5206 + */
1.5207 +
1.5208 +Tcl_Obj*
1.5209 +TclFSMakePathRelative(interp, objPtr, cwdPtr)
1.5210 + Tcl_Interp *interp; /* Used for error reporting if not NULL. */
1.5211 + Tcl_Obj *objPtr; /* The object we have. */
1.5212 + Tcl_Obj *cwdPtr; /* Make it relative to this. */
1.5213 +{
1.5214 + int cwdLen, len;
1.5215 + CONST char *tempStr;
1.5216 + ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);
1.5217 +
1.5218 + if (objPtr->typePtr == &tclFsPathType) {
1.5219 + FsPath *fsPathPtr = (FsPath*) PATHOBJ(objPtr);
1.5220 + if (PATHFLAGS(objPtr) != 0
1.5221 + && fsPathPtr->cwdPtr == cwdPtr) {
1.5222 + objPtr = fsPathPtr->normPathPtr;
1.5223 + /* Free old representation */
1.5224 + if (objPtr->typePtr != NULL) {
1.5225 + if (objPtr->bytes == NULL) {
1.5226 + if (objPtr->typePtr->updateStringProc == NULL) {
1.5227 + if (interp != NULL) {
1.5228 + Tcl_ResetResult(interp);
1.5229 + Tcl_AppendResult(interp, "can't find object",
1.5230 + "string representation", (char *) NULL);
1.5231 + }
1.5232 + return NULL;
1.5233 + }
1.5234 + objPtr->typePtr->updateStringProc(objPtr);
1.5235 + }
1.5236 + if ((objPtr->typePtr->freeIntRepProc) != NULL) {
1.5237 + (*objPtr->typePtr->freeIntRepProc)(objPtr);
1.5238 + }
1.5239 + }
1.5240 + /* Now objPtr is a string object */
1.5241 +
1.5242 + if (Tcl_GetString(objPtr)[0] == '~') {
1.5243 + /*
1.5244 + * If the first character of the path is a tilde,
1.5245 + * we must just return the path as is, to agree
1.5246 + * with the defined behaviour of 'glob'.
1.5247 + */
1.5248 + return objPtr;
1.5249 + }
1.5250 +
1.5251 + fsPathPtr = (FsPath*)ckalloc((unsigned)sizeof(FsPath));
1.5252 +
1.5253 + /* Circular reference, by design */
1.5254 + fsPathPtr->translatedPathPtr = objPtr;
1.5255 + fsPathPtr->normPathPtr = NULL;
1.5256 + fsPathPtr->cwdPtr = cwdPtr;
1.5257 + Tcl_IncrRefCount(cwdPtr);
1.5258 + fsPathPtr->nativePathPtr = NULL;
1.5259 + fsPathPtr->fsRecPtr = NULL;
1.5260 + fsPathPtr->filesystemEpoch = tsdPtr->filesystemEpoch;
1.5261 +
1.5262 + PATHOBJ(objPtr) = (VOID *) fsPathPtr;
1.5263 + PATHFLAGS(objPtr) = 0;
1.5264 + objPtr->typePtr = &tclFsPathType;
1.5265 +
1.5266 + return objPtr;
1.5267 + }
1.5268 + }
1.5269 + /*
1.5270 + * We know the cwd is a normalised object which does
1.5271 + * not end in a directory delimiter, unless the cwd
1.5272 + * is the name of a volume, in which case it will
1.5273 + * end in a delimiter! We handle this situation here.
1.5274 + * A better test than the '!= sep' might be to simply
1.5275 + * check if 'cwd' is a root volume.
1.5276 + *
1.5277 + * Note that if we get this wrong, we will strip off
1.5278 + * either too much or too little below, leading to
1.5279 + * wrong answers returned by glob.
1.5280 + */
1.5281 + tempStr = Tcl_GetStringFromObj(cwdPtr, &cwdLen);
1.5282 + /*
1.5283 + * Should we perhaps use 'Tcl_FSPathSeparator'?
1.5284 + * But then what about the Windows special case?
1.5285 + * Perhaps we should just check if cwd is a root
1.5286 + * volume.
1.5287 + */
1.5288 + switch (tclPlatform) {
1.5289 + case TCL_PLATFORM_UNIX:
1.5290 + if (tempStr[cwdLen-1] != '/') {
1.5291 + cwdLen++;
1.5292 + }
1.5293 + break;
1.5294 + case TCL_PLATFORM_WINDOWS:
1.5295 + if (tempStr[cwdLen-1] != '/'
1.5296 + && tempStr[cwdLen-1] != '\\') {
1.5297 + cwdLen++;
1.5298 + }
1.5299 + break;
1.5300 + case TCL_PLATFORM_MAC:
1.5301 + if (tempStr[cwdLen-1] != ':') {
1.5302 + cwdLen++;
1.5303 + }
1.5304 + break;
1.5305 + }
1.5306 + tempStr = Tcl_GetStringFromObj(objPtr, &len);
1.5307 +
1.5308 + return Tcl_NewStringObj(tempStr + cwdLen, len - cwdLen);
1.5309 +}
1.5310 +
1.5311 +/*
1.5312 + *---------------------------------------------------------------------------
1.5313 + *
1.5314 + * TclFSMakePathFromNormalized --
1.5315 + *
1.5316 + * Like SetFsPathFromAny, but assumes the given object is an
1.5317 + * absolute normalized path. Only for internal use.
1.5318 + *
1.5319 + * Results:
1.5320 + * Standard Tcl error code.
1.5321 + *
1.5322 + * Side effects:
1.5323 + * The old representation may be freed, and new memory allocated.
1.5324 + *
1.5325 + *---------------------------------------------------------------------------
1.5326 + */
1.5327 +
1.5328 +int
1.5329 +TclFSMakePathFromNormalized(interp, objPtr, nativeRep)
1.5330 + Tcl_Interp *interp; /* Used for error reporting if not NULL. */
1.5331 + Tcl_Obj *objPtr; /* The object to convert. */
1.5332 + ClientData nativeRep; /* The native rep for the object, if known
1.5333 + * else NULL. */
1.5334 +{
1.5335 + FsPath *fsPathPtr;
1.5336 + ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);
1.5337 +
1.5338 + if (objPtr->typePtr == &tclFsPathType) {
1.5339 + return TCL_OK;
1.5340 + }
1.5341 +
1.5342 + /* Free old representation */
1.5343 + if (objPtr->typePtr != NULL) {
1.5344 + if (objPtr->bytes == NULL) {
1.5345 + if (objPtr->typePtr->updateStringProc == NULL) {
1.5346 + if (interp != NULL) {
1.5347 + Tcl_ResetResult(interp);
1.5348 + Tcl_AppendResult(interp, "can't find object",
1.5349 + "string representation", (char *) NULL);
1.5350 + }
1.5351 + return TCL_ERROR;
1.5352 + }
1.5353 + objPtr->typePtr->updateStringProc(objPtr);
1.5354 + }
1.5355 + if ((objPtr->typePtr->freeIntRepProc) != NULL) {
1.5356 + (*objPtr->typePtr->freeIntRepProc)(objPtr);
1.5357 + }
1.5358 + }
1.5359 +
1.5360 + fsPathPtr = (FsPath*)ckalloc((unsigned)sizeof(FsPath));
1.5361 + /* It's a pure normalized absolute path */
1.5362 + fsPathPtr->translatedPathPtr = NULL;
1.5363 + fsPathPtr->normPathPtr = objPtr;
1.5364 + fsPathPtr->cwdPtr = NULL;
1.5365 + fsPathPtr->nativePathPtr = nativeRep;
1.5366 + fsPathPtr->fsRecPtr = NULL;
1.5367 + fsPathPtr->filesystemEpoch = tsdPtr->filesystemEpoch;
1.5368 +
1.5369 + PATHOBJ(objPtr) = (VOID *) fsPathPtr;
1.5370 + PATHFLAGS(objPtr) = 0;
1.5371 + objPtr->typePtr = &tclFsPathType;
1.5372 +
1.5373 + return TCL_OK;
1.5374 +}
1.5375 +
1.5376 +/*
1.5377 + *---------------------------------------------------------------------------
1.5378 + *
1.5379 + * Tcl_FSNewNativePath --
1.5380 + *
1.5381 + * This function performs the something like that reverse of the
1.5382 + * usual obj->path->nativerep conversions. If some code retrieves
1.5383 + * a path in native form (from, e.g. readlink or a native dialog),
1.5384 + * and that path is to be used at the Tcl level, then calling
1.5385 + * this function is an efficient way of creating the appropriate
1.5386 + * path object type.
1.5387 + *
1.5388 + * Any memory which is allocated for 'clientData' should be retained
1.5389 + * until clientData is passed to the filesystem's freeInternalRepProc
1.5390 + * when it can be freed. The built in platform-specific filesystems
1.5391 + * use 'ckalloc' to allocate clientData, and ckfree to free it.
1.5392 + *
1.5393 + * Results:
1.5394 + * NULL or a valid path object pointer, with refCount zero.
1.5395 + *
1.5396 + * Side effects:
1.5397 + * New memory may be allocated.
1.5398 + *
1.5399 + *---------------------------------------------------------------------------
1.5400 + */
1.5401 +
1.5402 +EXPORT_C Tcl_Obj *
1.5403 +Tcl_FSNewNativePath(fromFilesystem, clientData)
1.5404 + Tcl_Filesystem* fromFilesystem;
1.5405 + ClientData clientData;
1.5406 +{
1.5407 + Tcl_Obj *objPtr;
1.5408 + FsPath *fsPathPtr;
1.5409 +
1.5410 + FilesystemRecord *fsFromPtr;
1.5411 + ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);
1.5412 +
1.5413 + objPtr = TclFSInternalToNormalized(fromFilesystem, clientData, &fsFromPtr);
1.5414 + if (objPtr == NULL) {
1.5415 + return NULL;
1.5416 + }
1.5417 +
1.5418 + /*
1.5419 + * Free old representation; shouldn't normally be any,
1.5420 + * but best to be safe.
1.5421 + */
1.5422 + if (objPtr->typePtr != NULL) {
1.5423 + if (objPtr->bytes == NULL) {
1.5424 + if (objPtr->typePtr->updateStringProc == NULL) {
1.5425 + return NULL;
1.5426 + }
1.5427 + objPtr->typePtr->updateStringProc(objPtr);
1.5428 + }
1.5429 + if ((objPtr->typePtr->freeIntRepProc) != NULL) {
1.5430 + (*objPtr->typePtr->freeIntRepProc)(objPtr);
1.5431 + }
1.5432 + }
1.5433 +
1.5434 + fsPathPtr = (FsPath*)ckalloc((unsigned)sizeof(FsPath));
1.5435 +
1.5436 + fsPathPtr->translatedPathPtr = NULL;
1.5437 + /* Circular reference, by design */
1.5438 + fsPathPtr->normPathPtr = objPtr;
1.5439 + fsPathPtr->cwdPtr = NULL;
1.5440 + fsPathPtr->nativePathPtr = clientData;
1.5441 + fsPathPtr->fsRecPtr = fsFromPtr;
1.5442 + fsPathPtr->fsRecPtr->fileRefCount++;
1.5443 + fsPathPtr->filesystemEpoch = tsdPtr->filesystemEpoch;
1.5444 +
1.5445 + PATHOBJ(objPtr) = (VOID *) fsPathPtr;
1.5446 + PATHFLAGS(objPtr) = 0;
1.5447 + objPtr->typePtr = &tclFsPathType;
1.5448 +
1.5449 + return objPtr;
1.5450 +}
1.5451 +
1.5452 +/*
1.5453 + *---------------------------------------------------------------------------
1.5454 + *
1.5455 + * Tcl_FSGetTranslatedPath --
1.5456 + *
1.5457 + * This function attempts to extract the translated path
1.5458 + * from the given Tcl_Obj. If the translation succeeds (i.e. the
1.5459 + * object is a valid path), then it is returned. Otherwise NULL
1.5460 + * will be returned, and an error message may be left in the
1.5461 + * interpreter (if it is non-NULL)
1.5462 + *
1.5463 + * Results:
1.5464 + * NULL or a valid Tcl_Obj pointer.
1.5465 + *
1.5466 + * Side effects:
1.5467 + * Only those of 'Tcl_FSConvertToPathType'
1.5468 + *
1.5469 + *---------------------------------------------------------------------------
1.5470 + */
1.5471 +
1.5472 +EXPORT_C Tcl_Obj*
1.5473 +Tcl_FSGetTranslatedPath(interp, pathPtr)
1.5474 + Tcl_Interp *interp;
1.5475 + Tcl_Obj* pathPtr;
1.5476 +{
1.5477 + Tcl_Obj *retObj = NULL;
1.5478 + FsPath *srcFsPathPtr;
1.5479 +
1.5480 + if (Tcl_FSConvertToPathType(interp, pathPtr) != TCL_OK) {
1.5481 + return NULL;
1.5482 + }
1.5483 + srcFsPathPtr = (FsPath*) PATHOBJ(pathPtr);
1.5484 + if (srcFsPathPtr->translatedPathPtr == NULL) {
1.5485 + if (PATHFLAGS(pathPtr) != 0) {
1.5486 + retObj = Tcl_FSGetNormalizedPath(interp, pathPtr);
1.5487 + } else {
1.5488 + /*
1.5489 + * It is a pure absolute, normalized path object.
1.5490 + * This is something like being a 'pure list'. The
1.5491 + * object's string, translatedPath and normalizedPath
1.5492 + * are all identical.
1.5493 + */
1.5494 + retObj = srcFsPathPtr->normPathPtr;
1.5495 + }
1.5496 + } else {
1.5497 + /* It is an ordinary path object */
1.5498 + retObj = srcFsPathPtr->translatedPathPtr;
1.5499 + }
1.5500 +
1.5501 + if (retObj) {
1.5502 + Tcl_IncrRefCount(retObj);
1.5503 + }
1.5504 + return retObj;
1.5505 +}
1.5506 +
1.5507 +/*
1.5508 + *---------------------------------------------------------------------------
1.5509 + *
1.5510 + * Tcl_FSGetTranslatedStringPath --
1.5511 + *
1.5512 + * This function attempts to extract the translated path
1.5513 + * from the given Tcl_Obj. If the translation succeeds (i.e. the
1.5514 + * object is a valid path), then the path is returned. Otherwise NULL
1.5515 + * will be returned, and an error message may be left in the
1.5516 + * interpreter (if it is non-NULL)
1.5517 + *
1.5518 + * Results:
1.5519 + * NULL or a valid string.
1.5520 + *
1.5521 + * Side effects:
1.5522 + * Only those of 'Tcl_FSConvertToPathType'
1.5523 + *
1.5524 + *---------------------------------------------------------------------------
1.5525 + */
1.5526 +EXPORT_C CONST char*
1.5527 +Tcl_FSGetTranslatedStringPath(interp, pathPtr)
1.5528 + Tcl_Interp *interp;
1.5529 + Tcl_Obj* pathPtr;
1.5530 +{
1.5531 + Tcl_Obj *transPtr = Tcl_FSGetTranslatedPath(interp, pathPtr);
1.5532 +
1.5533 + if (transPtr != NULL) {
1.5534 + int len;
1.5535 + CONST char *result, *orig;
1.5536 + orig = Tcl_GetStringFromObj(transPtr, &len);
1.5537 + result = (char*) ckalloc((unsigned)(len+1));
1.5538 + memcpy((VOID*) result, (VOID*) orig, (size_t) (len+1));
1.5539 + Tcl_DecrRefCount(transPtr);
1.5540 + return result;
1.5541 + }
1.5542 +
1.5543 + return NULL;
1.5544 +}
1.5545 +
1.5546 +/*
1.5547 + *---------------------------------------------------------------------------
1.5548 + *
1.5549 + * Tcl_FSGetNormalizedPath --
1.5550 + *
1.5551 + * This important function attempts to extract from the given Tcl_Obj
1.5552 + * a unique normalised path representation, whose string value can
1.5553 + * be used as a unique identifier for the file.
1.5554 + *
1.5555 + * Results:
1.5556 + * NULL or a valid path object pointer.
1.5557 + *
1.5558 + * Side effects:
1.5559 + * New memory may be allocated. The Tcl 'errno' may be modified
1.5560 + * in the process of trying to examine various path possibilities.
1.5561 + *
1.5562 + *---------------------------------------------------------------------------
1.5563 + */
1.5564 +
1.5565 +EXPORT_C Tcl_Obj*
1.5566 +Tcl_FSGetNormalizedPath(interp, pathObjPtr)
1.5567 + Tcl_Interp *interp;
1.5568 + Tcl_Obj* pathObjPtr;
1.5569 +{
1.5570 + FsPath *fsPathPtr;
1.5571 +
1.5572 + if (Tcl_FSConvertToPathType(interp, pathObjPtr) != TCL_OK) {
1.5573 + return NULL;
1.5574 + }
1.5575 + fsPathPtr = (FsPath*) PATHOBJ(pathObjPtr);
1.5576 +
1.5577 + if (PATHFLAGS(pathObjPtr) != 0) {
1.5578 + /*
1.5579 + * This is a special path object which is the result of
1.5580 + * something like 'file join'
1.5581 + */
1.5582 + Tcl_Obj *dir, *copy;
1.5583 + int cwdLen;
1.5584 + int pathType;
1.5585 + CONST char *cwdStr;
1.5586 + ClientData clientData = NULL;
1.5587 +
1.5588 + pathType = Tcl_FSGetPathType(fsPathPtr->cwdPtr);
1.5589 + dir = Tcl_FSGetNormalizedPath(interp, fsPathPtr->cwdPtr);
1.5590 + if (dir == NULL) {
1.5591 + return NULL;
1.5592 + }
1.5593 + if (pathObjPtr->bytes == NULL) {
1.5594 + UpdateStringOfFsPath(pathObjPtr);
1.5595 + }
1.5596 + copy = Tcl_DuplicateObj(dir);
1.5597 + Tcl_IncrRefCount(copy);
1.5598 + Tcl_IncrRefCount(dir);
1.5599 + /* We now own a reference on both 'dir' and 'copy' */
1.5600 +
1.5601 + cwdStr = Tcl_GetStringFromObj(copy, &cwdLen);
1.5602 + /*
1.5603 + * Should we perhaps use 'Tcl_FSPathSeparator'?
1.5604 + * But then what about the Windows special case?
1.5605 + * Perhaps we should just check if cwd is a root volume.
1.5606 + * We should never get cwdLen == 0 in this code path.
1.5607 + */
1.5608 + switch (tclPlatform) {
1.5609 + case TCL_PLATFORM_UNIX:
1.5610 + if (cwdStr[cwdLen-1] != '/') {
1.5611 + Tcl_AppendToObj(copy, "/", 1);
1.5612 + cwdLen++;
1.5613 + }
1.5614 + break;
1.5615 + case TCL_PLATFORM_WINDOWS:
1.5616 + if (cwdStr[cwdLen-1] != '/'
1.5617 + && cwdStr[cwdLen-1] != '\\') {
1.5618 + Tcl_AppendToObj(copy, "/", 1);
1.5619 + cwdLen++;
1.5620 + }
1.5621 + break;
1.5622 + case TCL_PLATFORM_MAC:
1.5623 + if (cwdStr[cwdLen-1] != ':') {
1.5624 + Tcl_AppendToObj(copy, ":", 1);
1.5625 + cwdLen++;
1.5626 + }
1.5627 + break;
1.5628 + }
1.5629 + Tcl_AppendObjToObj(copy, fsPathPtr->normPathPtr);
1.5630 + /*
1.5631 + * Normalize the combined string, but only starting after
1.5632 + * the end of the previously normalized 'dir'. This should
1.5633 + * be much faster! We use 'cwdLen-1' so that we are
1.5634 + * already pointing at the dir-separator that we know about.
1.5635 + * The normalization code will actually start off directly
1.5636 + * after that separator.
1.5637 + */
1.5638 + TclFSNormalizeToUniquePath(interp, copy, cwdLen-1,
1.5639 + (fsPathPtr->nativePathPtr == NULL ? &clientData : NULL));
1.5640 + /* Now we need to construct the new path object */
1.5641 +
1.5642 + if (pathType == TCL_PATH_RELATIVE) {
1.5643 + FsPath* origDirFsPathPtr;
1.5644 + Tcl_Obj *origDir = fsPathPtr->cwdPtr;
1.5645 + origDirFsPathPtr = (FsPath*) PATHOBJ(origDir);
1.5646 +
1.5647 + fsPathPtr->cwdPtr = origDirFsPathPtr->cwdPtr;
1.5648 + Tcl_IncrRefCount(fsPathPtr->cwdPtr);
1.5649 +
1.5650 + Tcl_DecrRefCount(fsPathPtr->normPathPtr);
1.5651 + fsPathPtr->normPathPtr = copy;
1.5652 + /* That's our reference to copy used */
1.5653 + Tcl_DecrRefCount(dir);
1.5654 + Tcl_DecrRefCount(origDir);
1.5655 + } else {
1.5656 + Tcl_DecrRefCount(fsPathPtr->cwdPtr);
1.5657 + fsPathPtr->cwdPtr = NULL;
1.5658 + Tcl_DecrRefCount(fsPathPtr->normPathPtr);
1.5659 + fsPathPtr->normPathPtr = copy;
1.5660 + /* That's our reference to copy used */
1.5661 + Tcl_DecrRefCount(dir);
1.5662 + }
1.5663 + if (clientData != NULL) {
1.5664 + fsPathPtr->nativePathPtr = clientData;
1.5665 + }
1.5666 + PATHFLAGS(pathObjPtr) = 0;
1.5667 + }
1.5668 + /* Ensure cwd hasn't changed */
1.5669 + if (fsPathPtr->cwdPtr != NULL) {
1.5670 + if (!TclFSCwdPointerEquals(fsPathPtr->cwdPtr)) {
1.5671 + if (pathObjPtr->bytes == NULL) {
1.5672 + UpdateStringOfFsPath(pathObjPtr);
1.5673 + }
1.5674 + FreeFsPathInternalRep(pathObjPtr);
1.5675 + pathObjPtr->typePtr = NULL;
1.5676 + if (Tcl_ConvertToType(interp, pathObjPtr,
1.5677 + &tclFsPathType) != TCL_OK) {
1.5678 + return NULL;
1.5679 + }
1.5680 + fsPathPtr = (FsPath*) PATHOBJ(pathObjPtr);
1.5681 + } else if (fsPathPtr->normPathPtr == NULL) {
1.5682 + int cwdLen;
1.5683 + Tcl_Obj *copy;
1.5684 + CONST char *cwdStr;
1.5685 + ClientData clientData = NULL;
1.5686 +
1.5687 + copy = Tcl_DuplicateObj(fsPathPtr->cwdPtr);
1.5688 + Tcl_IncrRefCount(copy);
1.5689 + cwdStr = Tcl_GetStringFromObj(copy, &cwdLen);
1.5690 + /*
1.5691 + * Should we perhaps use 'Tcl_FSPathSeparator'?
1.5692 + * But then what about the Windows special case?
1.5693 + * Perhaps we should just check if cwd is a root volume.
1.5694 + * We should never get cwdLen == 0 in this code path.
1.5695 + */
1.5696 + switch (tclPlatform) {
1.5697 + case TCL_PLATFORM_UNIX:
1.5698 + if (cwdStr[cwdLen-1] != '/') {
1.5699 + Tcl_AppendToObj(copy, "/", 1);
1.5700 + cwdLen++;
1.5701 + }
1.5702 + break;
1.5703 + case TCL_PLATFORM_WINDOWS:
1.5704 + if (cwdStr[cwdLen-1] != '/'
1.5705 + && cwdStr[cwdLen-1] != '\\') {
1.5706 + Tcl_AppendToObj(copy, "/", 1);
1.5707 + cwdLen++;
1.5708 + }
1.5709 + break;
1.5710 + case TCL_PLATFORM_MAC:
1.5711 + if (cwdStr[cwdLen-1] != ':') {
1.5712 + Tcl_AppendToObj(copy, ":", 1);
1.5713 + cwdLen++;
1.5714 + }
1.5715 + break;
1.5716 + }
1.5717 + Tcl_AppendObjToObj(copy, pathObjPtr);
1.5718 + /*
1.5719 + * Normalize the combined string, but only starting after
1.5720 + * the end of the previously normalized 'dir'. This should
1.5721 + * be much faster!
1.5722 + */
1.5723 + TclFSNormalizeToUniquePath(interp, copy, cwdLen-1,
1.5724 + (fsPathPtr->nativePathPtr == NULL ? &clientData : NULL));
1.5725 + fsPathPtr->normPathPtr = copy;
1.5726 + if (clientData != NULL) {
1.5727 + fsPathPtr->nativePathPtr = clientData;
1.5728 + }
1.5729 + }
1.5730 + }
1.5731 + if (fsPathPtr->normPathPtr == NULL) {
1.5732 + ClientData clientData = NULL;
1.5733 + Tcl_Obj *useThisCwd = NULL;
1.5734 + /*
1.5735 + * Since normPathPtr is NULL, but this is a valid path
1.5736 + * object, we know that the translatedPathPtr cannot be NULL.
1.5737 + */
1.5738 + Tcl_Obj *absolutePath = fsPathPtr->translatedPathPtr;
1.5739 + char *path = Tcl_GetString(absolutePath);
1.5740 +
1.5741 + /*
1.5742 + * We have to be a little bit careful here to avoid infinite loops
1.5743 + * we're asking Tcl_FSGetPathType to return the path's type, but
1.5744 + * that call can actually result in a lot of other filesystem
1.5745 + * action, which might loop back through here.
1.5746 + */
1.5747 + if (path[0] != '\0') {
1.5748 + Tcl_PathType type = Tcl_FSGetPathType(pathObjPtr);
1.5749 + if (type == TCL_PATH_RELATIVE) {
1.5750 + useThisCwd = Tcl_FSGetCwd(interp);
1.5751 +
1.5752 + if (useThisCwd == NULL) return NULL;
1.5753 +
1.5754 + absolutePath = Tcl_FSJoinToPath(useThisCwd, 1, &absolutePath);
1.5755 + Tcl_IncrRefCount(absolutePath);
1.5756 + /* We have a refCount on the cwd */
1.5757 +#ifdef __WIN32__
1.5758 + } else if (type == TCL_PATH_VOLUME_RELATIVE) {
1.5759 + /*
1.5760 + * Only Windows has volume-relative paths. These
1.5761 + * paths are rather rare, but is is nice if Tcl can
1.5762 + * handle them. It is much better if we can
1.5763 + * handle them here, rather than in the native fs code,
1.5764 + * because we really need to have a real absolute path
1.5765 + * just below.
1.5766 + *
1.5767 + * We do not let this block compile on non-Windows
1.5768 + * platforms because the test suite's manual forcing
1.5769 + * of tclPlatform can otherwise cause this code path
1.5770 + * to be executed, causing various errors because
1.5771 + * volume-relative paths really do not exist.
1.5772 + */
1.5773 + useThisCwd = Tcl_FSGetCwd(interp);
1.5774 + if (useThisCwd == NULL) return NULL;
1.5775 +
1.5776 + if (path[0] == '/') {
1.5777 + /*
1.5778 + * Path of form /foo/bar which is a path in the
1.5779 + * root directory of the current volume.
1.5780 + */
1.5781 + CONST char *drive = Tcl_GetString(useThisCwd);
1.5782 + absolutePath = Tcl_NewStringObj(drive,2);
1.5783 + Tcl_AppendToObj(absolutePath, path, -1);
1.5784 + Tcl_IncrRefCount(absolutePath);
1.5785 + /* We have a refCount on the cwd */
1.5786 + } else {
1.5787 + /*
1.5788 + * Path of form C:foo/bar, but this only makes
1.5789 + * sense if the cwd is also on drive C.
1.5790 + */
1.5791 + CONST char *drive = Tcl_GetString(useThisCwd);
1.5792 + char drive_c = path[0];
1.5793 + if (drive_c >= 'a') {
1.5794 + drive_c -= ('a' - 'A');
1.5795 + }
1.5796 + if (drive[0] == drive_c) {
1.5797 + absolutePath = Tcl_DuplicateObj(useThisCwd);
1.5798 + /* We have a refCount on the cwd */
1.5799 + } else {
1.5800 + Tcl_DecrRefCount(useThisCwd);
1.5801 + useThisCwd = NULL;
1.5802 + /*
1.5803 + * The path is not in the current drive, but
1.5804 + * is volume-relative. The way Tcl 8.3 handles
1.5805 + * this is that it treats such a path as
1.5806 + * relative to the root of the drive. We
1.5807 + * therefore behave the same here.
1.5808 + */
1.5809 + absolutePath = Tcl_NewStringObj(path, 2);
1.5810 + }
1.5811 + Tcl_IncrRefCount(absolutePath);
1.5812 + Tcl_AppendToObj(absolutePath, "/", 1);
1.5813 + Tcl_AppendToObj(absolutePath, path+2, -1);
1.5814 + }
1.5815 +#endif /* __WIN32__ */
1.5816 + }
1.5817 + }
1.5818 + /* Already has refCount incremented */
1.5819 + fsPathPtr->normPathPtr = TclFSNormalizeAbsolutePath(interp, absolutePath,
1.5820 + (fsPathPtr->nativePathPtr == NULL ? &clientData : NULL));
1.5821 + if (0 && (clientData != NULL)) {
1.5822 + fsPathPtr->nativePathPtr =
1.5823 + (*fsPathPtr->fsRecPtr->fsPtr->dupInternalRepProc)(clientData);
1.5824 + }
1.5825 + if (!strcmp(Tcl_GetString(fsPathPtr->normPathPtr),
1.5826 + Tcl_GetString(pathObjPtr))) {
1.5827 + /*
1.5828 + * The path was already normalized.
1.5829 + * Get rid of the duplicate.
1.5830 + */
1.5831 + Tcl_DecrRefCount(fsPathPtr->normPathPtr);
1.5832 + /*
1.5833 + * We do *not* increment the refCount for
1.5834 + * this circular reference
1.5835 + */
1.5836 + fsPathPtr->normPathPtr = pathObjPtr;
1.5837 + }
1.5838 + if (useThisCwd != NULL) {
1.5839 + /* This was returned by Tcl_FSJoinToPath above */
1.5840 + Tcl_DecrRefCount(absolutePath);
1.5841 + fsPathPtr->cwdPtr = useThisCwd;
1.5842 + }
1.5843 + }
1.5844 +
1.5845 + return fsPathPtr->normPathPtr;
1.5846 +}
1.5847 +
1.5848 +/*
1.5849 + *---------------------------------------------------------------------------
1.5850 + *
1.5851 + * Tcl_FSGetInternalRep --
1.5852 + *
1.5853 + * Extract the internal representation of a given path object,
1.5854 + * in the given filesystem. If the path object belongs to a
1.5855 + * different filesystem, we return NULL.
1.5856 + *
1.5857 + * If the internal representation is currently NULL, we attempt
1.5858 + * to generate it, by calling the filesystem's
1.5859 + * 'Tcl_FSCreateInternalRepProc'.
1.5860 + *
1.5861 + * Results:
1.5862 + * NULL or a valid internal representation.
1.5863 + *
1.5864 + * Side effects:
1.5865 + * An attempt may be made to convert the object.
1.5866 + *
1.5867 + *---------------------------------------------------------------------------
1.5868 + */
1.5869 +
1.5870 +EXPORT_C ClientData
1.5871 +Tcl_FSGetInternalRep(pathObjPtr, fsPtr)
1.5872 + Tcl_Obj* pathObjPtr;
1.5873 + Tcl_Filesystem *fsPtr;
1.5874 +{
1.5875 + FsPath *srcFsPathPtr;
1.5876 +
1.5877 + if (Tcl_FSConvertToPathType(NULL, pathObjPtr) != TCL_OK) {
1.5878 + return NULL;
1.5879 + }
1.5880 + srcFsPathPtr = (FsPath*) PATHOBJ(pathObjPtr);
1.5881 +
1.5882 + /*
1.5883 + * We will only return the native representation for the caller's
1.5884 + * filesystem. Otherwise we will simply return NULL. This means
1.5885 + * that there must be a unique bi-directional mapping between paths
1.5886 + * and filesystems, and that this mapping will not allow 'remapped'
1.5887 + * files -- files which are in one filesystem but mapped into
1.5888 + * another. Another way of putting this is that 'stacked'
1.5889 + * filesystems are not allowed. We recognise that this is a
1.5890 + * potentially useful feature for the future.
1.5891 + *
1.5892 + * Even something simple like a 'pass through' filesystem which
1.5893 + * logs all activity and passes the calls onto the native system
1.5894 + * would be nice, but not easily achievable with the current
1.5895 + * implementation.
1.5896 + */
1.5897 + if (srcFsPathPtr->fsRecPtr == NULL) {
1.5898 + /*
1.5899 + * This only usually happens in wrappers like TclpStat which
1.5900 + * create a string object and pass it to TclpObjStat. Code
1.5901 + * which calls the Tcl_FS.. functions should always have a
1.5902 + * filesystem already set. Whether this code path is legal or
1.5903 + * not depends on whether we decide to allow external code to
1.5904 + * call the native filesystem directly. It is at least safer
1.5905 + * to allow this sub-optimal routing.
1.5906 + */
1.5907 + Tcl_FSGetFileSystemForPath(pathObjPtr);
1.5908 +
1.5909 + /*
1.5910 + * If we fail through here, then the path is probably not a
1.5911 + * valid path in the filesystsem, and is most likely to be a
1.5912 + * use of the empty path "" via a direct call to one of the
1.5913 + * objectified interfaces (e.g. from the Tcl testsuite).
1.5914 + */
1.5915 + srcFsPathPtr = (FsPath*) PATHOBJ(pathObjPtr);
1.5916 + if (srcFsPathPtr->fsRecPtr == NULL) {
1.5917 + return NULL;
1.5918 + }
1.5919 + }
1.5920 +
1.5921 + if (fsPtr != srcFsPathPtr->fsRecPtr->fsPtr) {
1.5922 + /*
1.5923 + * There is still one possibility we should consider; if the
1.5924 + * file belongs to a different filesystem, perhaps it is
1.5925 + * actually linked through to a file in our own filesystem
1.5926 + * which we do care about. The way we can check for this
1.5927 + * is we ask what filesystem this path belongs to.
1.5928 + */
1.5929 + Tcl_Filesystem *actualFs = Tcl_FSGetFileSystemForPath(pathObjPtr);
1.5930 + if (actualFs == fsPtr) {
1.5931 + return Tcl_FSGetInternalRep(pathObjPtr, fsPtr);
1.5932 + }
1.5933 + return NULL;
1.5934 + }
1.5935 +
1.5936 + if (srcFsPathPtr->nativePathPtr == NULL) {
1.5937 + Tcl_FSCreateInternalRepProc *proc;
1.5938 + char *nativePathPtr;
1.5939 +
1.5940 + proc = srcFsPathPtr->fsRecPtr->fsPtr->createInternalRepProc;
1.5941 + if (proc == NULL) {
1.5942 + return NULL;
1.5943 + }
1.5944 +
1.5945 + nativePathPtr = (*proc)(pathObjPtr);
1.5946 + srcFsPathPtr = (FsPath*) PATHOBJ(pathObjPtr);
1.5947 + srcFsPathPtr->nativePathPtr = nativePathPtr;
1.5948 + }
1.5949 +
1.5950 + return srcFsPathPtr->nativePathPtr;
1.5951 +}
1.5952 +
1.5953 +/*
1.5954 + *---------------------------------------------------------------------------
1.5955 + *
1.5956 + * TclFSEnsureEpochOk --
1.5957 + *
1.5958 + * This will ensure the pathObjPtr is up to date and can be
1.5959 + * converted into a "path" type, and that we are able to generate a
1.5960 + * complete normalized path which is used to determine the
1.5961 + * filesystem match.
1.5962 + *
1.5963 + * Results:
1.5964 + * Standard Tcl return code.
1.5965 + *
1.5966 + * Side effects:
1.5967 + * An attempt may be made to convert the object.
1.5968 + *
1.5969 + *---------------------------------------------------------------------------
1.5970 + */
1.5971 +
1.5972 +int
1.5973 +TclFSEnsureEpochOk(pathObjPtr, fsPtrPtr)
1.5974 + Tcl_Obj* pathObjPtr;
1.5975 + Tcl_Filesystem **fsPtrPtr;
1.5976 +{
1.5977 + FsPath *srcFsPathPtr;
1.5978 + ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);
1.5979 +
1.5980 + /*
1.5981 + * SHOULD BE ABLE TO IMPROVE EFFICIENCY HERE.
1.5982 + */
1.5983 +
1.5984 + if (Tcl_FSGetNormalizedPath(NULL, pathObjPtr) == NULL) {
1.5985 + return TCL_ERROR;
1.5986 + }
1.5987 +
1.5988 + srcFsPathPtr = (FsPath*) PATHOBJ(pathObjPtr);
1.5989 +
1.5990 + /*
1.5991 + * Check if the filesystem has changed in some way since
1.5992 + * this object's internal representation was calculated.
1.5993 + */
1.5994 + if (srcFsPathPtr->filesystemEpoch != tsdPtr->filesystemEpoch) {
1.5995 + /*
1.5996 + * We have to discard the stale representation and
1.5997 + * recalculate it
1.5998 + */
1.5999 + if (pathObjPtr->bytes == NULL) {
1.6000 + UpdateStringOfFsPath(pathObjPtr);
1.6001 + }
1.6002 + FreeFsPathInternalRep(pathObjPtr);
1.6003 + pathObjPtr->typePtr = NULL;
1.6004 + if (SetFsPathFromAny(NULL, pathObjPtr) != TCL_OK) {
1.6005 + return TCL_ERROR;
1.6006 + }
1.6007 + srcFsPathPtr = (FsPath*) PATHOBJ(pathObjPtr);
1.6008 + }
1.6009 + /* Check whether the object is already assigned to a fs */
1.6010 + if (srcFsPathPtr->fsRecPtr != NULL) {
1.6011 + *fsPtrPtr = srcFsPathPtr->fsRecPtr->fsPtr;
1.6012 + }
1.6013 +
1.6014 + return TCL_OK;
1.6015 +}
1.6016 +
1.6017 +void
1.6018 +TclFSSetPathDetails(pathObjPtr, fsRecPtr, clientData)
1.6019 + Tcl_Obj *pathObjPtr;
1.6020 + FilesystemRecord *fsRecPtr;
1.6021 + ClientData clientData;
1.6022 +{
1.6023 + ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);
1.6024 + /* We assume pathObjPtr is already of the correct type */
1.6025 + FsPath *srcFsPathPtr;
1.6026 +
1.6027 + srcFsPathPtr = (FsPath*) PATHOBJ(pathObjPtr);
1.6028 + srcFsPathPtr->fsRecPtr = fsRecPtr;
1.6029 + srcFsPathPtr->nativePathPtr = clientData;
1.6030 + srcFsPathPtr->filesystemEpoch = tsdPtr->filesystemEpoch;
1.6031 + fsRecPtr->fileRefCount++;
1.6032 +}
1.6033 +
1.6034 +/*
1.6035 + *---------------------------------------------------------------------------
1.6036 + *
1.6037 + * Tcl_FSEqualPaths --
1.6038 + *
1.6039 + * This function tests whether the two paths given are equal path
1.6040 + * objects. If either or both is NULL, 0 is always returned.
1.6041 + *
1.6042 + * Results:
1.6043 + * 1 or 0.
1.6044 + *
1.6045 + * Side effects:
1.6046 + * None.
1.6047 + *
1.6048 + *---------------------------------------------------------------------------
1.6049 + */
1.6050 +
1.6051 +EXPORT_C int
1.6052 +Tcl_FSEqualPaths(firstPtr, secondPtr)
1.6053 + Tcl_Obj* firstPtr;
1.6054 + Tcl_Obj* secondPtr;
1.6055 +{
1.6056 + if (firstPtr == secondPtr) {
1.6057 + return 1;
1.6058 + } else {
1.6059 + char *firstStr, *secondStr;
1.6060 + int firstLen, secondLen, tempErrno;
1.6061 +
1.6062 + if (firstPtr == NULL || secondPtr == NULL) {
1.6063 + return 0;
1.6064 + }
1.6065 + firstStr = Tcl_GetStringFromObj(firstPtr, &firstLen);
1.6066 + secondStr = Tcl_GetStringFromObj(secondPtr, &secondLen);
1.6067 + if ((firstLen == secondLen) && (strcmp(firstStr, secondStr) == 0)) {
1.6068 + return 1;
1.6069 + }
1.6070 + /*
1.6071 + * Try the most thorough, correct method of comparing fully
1.6072 + * normalized paths
1.6073 + */
1.6074 +
1.6075 + tempErrno = Tcl_GetErrno();
1.6076 + firstPtr = Tcl_FSGetNormalizedPath(NULL, firstPtr);
1.6077 + secondPtr = Tcl_FSGetNormalizedPath(NULL, secondPtr);
1.6078 + Tcl_SetErrno(tempErrno);
1.6079 +
1.6080 + if (firstPtr == NULL || secondPtr == NULL) {
1.6081 + return 0;
1.6082 + }
1.6083 + firstStr = Tcl_GetStringFromObj(firstPtr, &firstLen);
1.6084 + secondStr = Tcl_GetStringFromObj(secondPtr, &secondLen);
1.6085 + if ((firstLen == secondLen) && (strcmp(firstStr, secondStr) == 0)) {
1.6086 + return 1;
1.6087 + }
1.6088 + }
1.6089 +
1.6090 + return 0;
1.6091 +}
1.6092 +
1.6093 +/*
1.6094 + *---------------------------------------------------------------------------
1.6095 + *
1.6096 + * SetFsPathFromAny --
1.6097 + *
1.6098 + * This function tries to convert the given Tcl_Obj to a valid
1.6099 + * Tcl path type.
1.6100 + *
1.6101 + * The filename may begin with "~" (to indicate current user's
1.6102 + * home directory) or "~<user>" (to indicate any user's home
1.6103 + * directory).
1.6104 + *
1.6105 + * Results:
1.6106 + * Standard Tcl error code.
1.6107 + *
1.6108 + * Side effects:
1.6109 + * The old representation may be freed, and new memory allocated.
1.6110 + *
1.6111 + *---------------------------------------------------------------------------
1.6112 + */
1.6113 +
1.6114 +static int
1.6115 +SetFsPathFromAny(interp, objPtr)
1.6116 + Tcl_Interp *interp; /* Used for error reporting if not NULL. */
1.6117 + Tcl_Obj *objPtr; /* The object to convert. */
1.6118 +{
1.6119 + int len;
1.6120 + FsPath *fsPathPtr;
1.6121 + Tcl_Obj *transPtr;
1.6122 + char *name;
1.6123 + ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);
1.6124 +
1.6125 + if (objPtr->typePtr == &tclFsPathType) {
1.6126 + return TCL_OK;
1.6127 + }
1.6128 +
1.6129 + /*
1.6130 + * First step is to translate the filename. This is similar to
1.6131 + * Tcl_TranslateFilename, but shouldn't convert everything to
1.6132 + * windows backslashes on that platform. The current
1.6133 + * implementation of this piece is a slightly optimised version
1.6134 + * of the various Tilde/Split/Join stuff to avoid multiple
1.6135 + * split/join operations.
1.6136 + *
1.6137 + * We remove any trailing directory separator.
1.6138 + *
1.6139 + * However, the split/join routines are quite complex, and
1.6140 + * one has to make sure not to break anything on Unix, Win
1.6141 + * or MacOS (fCmd.test, fileName.test and cmdAH.test exercise
1.6142 + * most of the code).
1.6143 + */
1.6144 + name = Tcl_GetStringFromObj(objPtr,&len);
1.6145 +
1.6146 + /*
1.6147 + * Handle tilde substitutions, if needed.
1.6148 + */
1.6149 + if (name[0] == '~') {
1.6150 + char *expandedUser;
1.6151 + Tcl_DString temp;
1.6152 + int split;
1.6153 + char separator='/';
1.6154 +
1.6155 + if (tclPlatform==TCL_PLATFORM_MAC) {
1.6156 + if (strchr(name, ':') != NULL) separator = ':';
1.6157 + }
1.6158 +
1.6159 + split = FindSplitPos(name, &separator);
1.6160 + if (split != len) {
1.6161 + /* We have multiple pieces '~user/foo/bar...' */
1.6162 + name[split] = '\0';
1.6163 + }
1.6164 + /* Do some tilde substitution */
1.6165 + if (name[1] == '\0') {
1.6166 + /* We have just '~' */
1.6167 + CONST char *dir;
1.6168 + Tcl_DString dirString;
1.6169 + if (split != len) { name[split] = separator; }
1.6170 +
1.6171 + dir = TclGetEnv("HOME", &dirString);
1.6172 + if (dir == NULL) {
1.6173 + if (interp) {
1.6174 + Tcl_ResetResult(interp);
1.6175 + Tcl_AppendResult(interp, "couldn't find HOME environment ",
1.6176 + "variable to expand path", (char *) NULL);
1.6177 + }
1.6178 + return TCL_ERROR;
1.6179 + }
1.6180 + Tcl_DStringInit(&temp);
1.6181 + Tcl_JoinPath(1, &dir, &temp);
1.6182 + Tcl_DStringFree(&dirString);
1.6183 + } else {
1.6184 + /* We have a user name '~user' */
1.6185 + Tcl_DStringInit(&temp);
1.6186 + if (TclpGetUserHome(name+1, &temp) == NULL) {
1.6187 + if (interp != NULL) {
1.6188 + Tcl_ResetResult(interp);
1.6189 + Tcl_AppendResult(interp, "user \"", (name+1),
1.6190 + "\" doesn't exist", (char *) NULL);
1.6191 + }
1.6192 + Tcl_DStringFree(&temp);
1.6193 + if (split != len) { name[split] = separator; }
1.6194 + return TCL_ERROR;
1.6195 + }
1.6196 + if (split != len) { name[split] = separator; }
1.6197 + }
1.6198 +
1.6199 + expandedUser = Tcl_DStringValue(&temp);
1.6200 + transPtr = Tcl_NewStringObj(expandedUser, Tcl_DStringLength(&temp));
1.6201 +
1.6202 + if (split != len) {
1.6203 + /* Join up the tilde substitution with the rest */
1.6204 + if (name[split+1] == separator) {
1.6205 +
1.6206 + /*
1.6207 + * Somewhat tricky case like ~//foo/bar.
1.6208 + * Make use of Split/Join machinery to get it right.
1.6209 + * Assumes all paths beginning with ~ are part of the
1.6210 + * native filesystem.
1.6211 + */
1.6212 +
1.6213 + int objc;
1.6214 + Tcl_Obj **objv;
1.6215 + Tcl_Obj *parts = TclpNativeSplitPath(objPtr, NULL);
1.6216 + Tcl_ListObjGetElements(NULL, parts, &objc, &objv);
1.6217 + /* Skip '~'. It's replaced by its expansion */
1.6218 + objc--; objv++;
1.6219 + while (objc--) {
1.6220 + TclpNativeJoinPath(transPtr, Tcl_GetString(*objv++));
1.6221 + }
1.6222 + Tcl_DecrRefCount(parts);
1.6223 + } else {
1.6224 + /* Simple case. "rest" is relative path. Just join it. */
1.6225 + Tcl_Obj *rest = Tcl_NewStringObj(name+split+1,-1);
1.6226 + transPtr = Tcl_FSJoinToPath(transPtr, 1, &rest);
1.6227 + }
1.6228 + }
1.6229 + Tcl_DStringFree(&temp);
1.6230 + } else {
1.6231 + transPtr = Tcl_FSJoinToPath(objPtr,0,NULL);
1.6232 + }
1.6233 +
1.6234 +#if defined(__CYGWIN__) && defined(__WIN32__)
1.6235 + {
1.6236 + extern int cygwin_conv_to_win32_path
1.6237 + _ANSI_ARGS_((CONST char *, char *));
1.6238 + char winbuf[MAX_PATH+1];
1.6239 +
1.6240 + /*
1.6241 + * In the Cygwin world, call conv_to_win32_path in order to use the
1.6242 + * mount table to translate the file name into something Windows will
1.6243 + * understand. Take care when converting empty strings!
1.6244 + */
1.6245 + name = Tcl_GetStringFromObj(transPtr, &len);
1.6246 + if (len > 0) {
1.6247 + cygwin_conv_to_win32_path(name, winbuf);
1.6248 + TclWinNoBackslash(winbuf);
1.6249 + Tcl_SetStringObj(transPtr, winbuf, -1);
1.6250 + }
1.6251 + }
1.6252 +#endif /* __CYGWIN__ && __WIN32__ */
1.6253 +
1.6254 + /*
1.6255 + * Now we have a translated filename in 'transPtr'. This will have
1.6256 + * forward slashes on Windows, and will not contain any ~user
1.6257 + * sequences.
1.6258 + */
1.6259 +
1.6260 + fsPathPtr = (FsPath*)ckalloc((unsigned)sizeof(FsPath));
1.6261 +
1.6262 + fsPathPtr->translatedPathPtr = transPtr;
1.6263 + Tcl_IncrRefCount(fsPathPtr->translatedPathPtr);
1.6264 + fsPathPtr->normPathPtr = NULL;
1.6265 + fsPathPtr->cwdPtr = NULL;
1.6266 + fsPathPtr->nativePathPtr = NULL;
1.6267 + fsPathPtr->fsRecPtr = NULL;
1.6268 + fsPathPtr->filesystemEpoch = tsdPtr->filesystemEpoch;
1.6269 +
1.6270 + /*
1.6271 + * Free old representation before installing our new one.
1.6272 + */
1.6273 + if (objPtr->typePtr != NULL && objPtr->typePtr->freeIntRepProc != NULL) {
1.6274 + (objPtr->typePtr->freeIntRepProc)(objPtr);
1.6275 + }
1.6276 + PATHOBJ(objPtr) = (VOID *) fsPathPtr;
1.6277 + PATHFLAGS(objPtr) = 0;
1.6278 + objPtr->typePtr = &tclFsPathType;
1.6279 +
1.6280 + return TCL_OK;
1.6281 +}
1.6282 +
1.6283 +static void
1.6284 +FreeFsPathInternalRep(pathObjPtr)
1.6285 + Tcl_Obj *pathObjPtr; /* Path object with internal rep to free. */
1.6286 +{
1.6287 + FsPath *fsPathPtr = (FsPath*) PATHOBJ(pathObjPtr);
1.6288 +
1.6289 + if (fsPathPtr->translatedPathPtr != NULL) {
1.6290 + if (fsPathPtr->translatedPathPtr != pathObjPtr) {
1.6291 + Tcl_DecrRefCount(fsPathPtr->translatedPathPtr);
1.6292 + }
1.6293 + }
1.6294 + if (fsPathPtr->normPathPtr != NULL) {
1.6295 + if (fsPathPtr->normPathPtr != pathObjPtr) {
1.6296 + Tcl_DecrRefCount(fsPathPtr->normPathPtr);
1.6297 + }
1.6298 + fsPathPtr->normPathPtr = NULL;
1.6299 + }
1.6300 + if (fsPathPtr->cwdPtr != NULL) {
1.6301 + Tcl_DecrRefCount(fsPathPtr->cwdPtr);
1.6302 + }
1.6303 + if (fsPathPtr->nativePathPtr != NULL) {
1.6304 + if (fsPathPtr->fsRecPtr != NULL) {
1.6305 + if (fsPathPtr->fsRecPtr->fsPtr->freeInternalRepProc != NULL) {
1.6306 + (*fsPathPtr->fsRecPtr->fsPtr
1.6307 + ->freeInternalRepProc)(fsPathPtr->nativePathPtr);
1.6308 + fsPathPtr->nativePathPtr = NULL;
1.6309 + }
1.6310 + }
1.6311 + }
1.6312 + if (fsPathPtr->fsRecPtr != NULL) {
1.6313 + fsPathPtr->fsRecPtr->fileRefCount--;
1.6314 + if (fsPathPtr->fsRecPtr->fileRefCount <= 0) {
1.6315 + /* It has been unregistered already, so simply free it */
1.6316 + ckfree((char *)fsPathPtr->fsRecPtr);
1.6317 + }
1.6318 + }
1.6319 +
1.6320 + ckfree((char*) fsPathPtr);
1.6321 +}
1.6322 +
1.6323 +
1.6324 +static void
1.6325 +DupFsPathInternalRep(srcPtr, copyPtr)
1.6326 + Tcl_Obj *srcPtr; /* Path obj with internal rep to copy. */
1.6327 + Tcl_Obj *copyPtr; /* Path obj with internal rep to set. */
1.6328 +{
1.6329 + FsPath *srcFsPathPtr = (FsPath*) PATHOBJ(srcPtr);
1.6330 + FsPath *copyFsPathPtr = (FsPath*) ckalloc((unsigned)sizeof(FsPath));
1.6331 +
1.6332 + Tcl_FSDupInternalRepProc *dupProc;
1.6333 +
1.6334 + PATHOBJ(copyPtr) = (VOID *) copyFsPathPtr;
1.6335 +
1.6336 + if (srcFsPathPtr->translatedPathPtr != NULL) {
1.6337 + copyFsPathPtr->translatedPathPtr = srcFsPathPtr->translatedPathPtr;
1.6338 + if (copyFsPathPtr->translatedPathPtr != copyPtr) {
1.6339 + Tcl_IncrRefCount(copyFsPathPtr->translatedPathPtr);
1.6340 + }
1.6341 + } else {
1.6342 + copyFsPathPtr->translatedPathPtr = NULL;
1.6343 + }
1.6344 +
1.6345 + if (srcFsPathPtr->normPathPtr != NULL) {
1.6346 + copyFsPathPtr->normPathPtr = srcFsPathPtr->normPathPtr;
1.6347 + if (copyFsPathPtr->normPathPtr != copyPtr) {
1.6348 + Tcl_IncrRefCount(copyFsPathPtr->normPathPtr);
1.6349 + }
1.6350 + } else {
1.6351 + copyFsPathPtr->normPathPtr = NULL;
1.6352 + }
1.6353 +
1.6354 + if (srcFsPathPtr->cwdPtr != NULL) {
1.6355 + copyFsPathPtr->cwdPtr = srcFsPathPtr->cwdPtr;
1.6356 + Tcl_IncrRefCount(copyFsPathPtr->cwdPtr);
1.6357 + } else {
1.6358 + copyFsPathPtr->cwdPtr = NULL;
1.6359 + }
1.6360 +
1.6361 + copyFsPathPtr->flags = srcFsPathPtr->flags;
1.6362 +
1.6363 + if (srcFsPathPtr->fsRecPtr != NULL
1.6364 + && srcFsPathPtr->nativePathPtr != NULL) {
1.6365 + dupProc = srcFsPathPtr->fsRecPtr->fsPtr->dupInternalRepProc;
1.6366 + if (dupProc != NULL) {
1.6367 + copyFsPathPtr->nativePathPtr =
1.6368 + (*dupProc)(srcFsPathPtr->nativePathPtr);
1.6369 + } else {
1.6370 + copyFsPathPtr->nativePathPtr = NULL;
1.6371 + }
1.6372 + } else {
1.6373 + copyFsPathPtr->nativePathPtr = NULL;
1.6374 + }
1.6375 + copyFsPathPtr->fsRecPtr = srcFsPathPtr->fsRecPtr;
1.6376 + copyFsPathPtr->filesystemEpoch = srcFsPathPtr->filesystemEpoch;
1.6377 + if (copyFsPathPtr->fsRecPtr != NULL) {
1.6378 + copyFsPathPtr->fsRecPtr->fileRefCount++;
1.6379 + }
1.6380 +
1.6381 + copyPtr->typePtr = &tclFsPathType;
1.6382 +}
1.6383 +
1.6384 +/*
1.6385 + *---------------------------------------------------------------------------
1.6386 + *
1.6387 + * UpdateStringOfFsPath --
1.6388 + *
1.6389 + * Gives an object a valid string rep.
1.6390 + *
1.6391 + * Results:
1.6392 + * None.
1.6393 + *
1.6394 + * Side effects:
1.6395 + * Memory may be allocated.
1.6396 + *
1.6397 + *---------------------------------------------------------------------------
1.6398 + */
1.6399 +
1.6400 +static void
1.6401 +UpdateStringOfFsPath(objPtr)
1.6402 + register Tcl_Obj *objPtr; /* path obj with string rep to update. */
1.6403 +{
1.6404 + FsPath *fsPathPtr = (FsPath*) PATHOBJ(objPtr);
1.6405 + CONST char *cwdStr;
1.6406 + int cwdLen;
1.6407 + Tcl_Obj *copy;
1.6408 +
1.6409 + if (PATHFLAGS(objPtr) == 0 || fsPathPtr->cwdPtr == NULL) {
1.6410 + panic("Called UpdateStringOfFsPath with invalid object");
1.6411 + }
1.6412 +
1.6413 + copy = Tcl_DuplicateObj(fsPathPtr->cwdPtr);
1.6414 + Tcl_IncrRefCount(copy);
1.6415 +
1.6416 + cwdStr = Tcl_GetStringFromObj(copy, &cwdLen);
1.6417 + /*
1.6418 + * Should we perhaps use 'Tcl_FSPathSeparator'?
1.6419 + * But then what about the Windows special case?
1.6420 + * Perhaps we should just check if cwd is a root volume.
1.6421 + * We should never get cwdLen == 0 in this code path.
1.6422 + */
1.6423 + switch (tclPlatform) {
1.6424 + case TCL_PLATFORM_UNIX:
1.6425 + if (cwdStr[cwdLen-1] != '/') {
1.6426 + Tcl_AppendToObj(copy, "/", 1);
1.6427 + cwdLen++;
1.6428 + }
1.6429 + break;
1.6430 + case TCL_PLATFORM_WINDOWS:
1.6431 + /*
1.6432 + * We need the extra 'cwdLen != 2', and ':' checks because
1.6433 + * a volume relative path doesn't get a '/'. For example
1.6434 + * 'glob C:*cat*.exe' will return 'C:cat32.exe'
1.6435 + */
1.6436 + if (cwdStr[cwdLen-1] != '/'
1.6437 + && cwdStr[cwdLen-1] != '\\') {
1.6438 + if (cwdLen != 2 || cwdStr[1] != ':') {
1.6439 + Tcl_AppendToObj(copy, "/", 1);
1.6440 + cwdLen++;
1.6441 + }
1.6442 + }
1.6443 + break;
1.6444 + case TCL_PLATFORM_MAC:
1.6445 + if (cwdStr[cwdLen-1] != ':') {
1.6446 + Tcl_AppendToObj(copy, ":", 1);
1.6447 + cwdLen++;
1.6448 + }
1.6449 + break;
1.6450 + }
1.6451 + Tcl_AppendObjToObj(copy, fsPathPtr->normPathPtr);
1.6452 + objPtr->bytes = Tcl_GetStringFromObj(copy, &cwdLen);
1.6453 + objPtr->length = cwdLen;
1.6454 + copy->bytes = tclEmptyStringRep;
1.6455 + copy->length = 0;
1.6456 + Tcl_DecrRefCount(copy);
1.6457 +}
1.6458 +
1.6459 +/*
1.6460 + *---------------------------------------------------------------------------
1.6461 + *
1.6462 + * NativePathInFilesystem --
1.6463 + *
1.6464 + * Any path object is acceptable to the native filesystem, by
1.6465 + * default (we will throw errors when illegal paths are actually
1.6466 + * tried to be used).
1.6467 + *
1.6468 + * However, this behavior means the native filesystem must be
1.6469 + * the last filesystem in the lookup list (otherwise it will
1.6470 + * claim all files belong to it, and other filesystems will
1.6471 + * never get a look in).
1.6472 + *
1.6473 + * Results:
1.6474 + * TCL_OK, to indicate 'yes', -1 to indicate no.
1.6475 + *
1.6476 + * Side effects:
1.6477 + * None.
1.6478 + *
1.6479 + *---------------------------------------------------------------------------
1.6480 + */
1.6481 +static int
1.6482 +NativePathInFilesystem(pathPtr, clientDataPtr)
1.6483 + Tcl_Obj *pathPtr;
1.6484 + ClientData *clientDataPtr;
1.6485 +{
1.6486 + /*
1.6487 + * A special case is required to handle the empty path "".
1.6488 + * This is a valid path (i.e. the user should be able
1.6489 + * to do 'file exists ""' without throwing an error), but
1.6490 + * equally the path doesn't exist. Those are the semantics
1.6491 + * of Tcl (at present anyway), so we have to abide by them
1.6492 + * here.
1.6493 + */
1.6494 + if (pathPtr->typePtr == &tclFsPathType) {
1.6495 + if (pathPtr->bytes != NULL && pathPtr->bytes[0] == '\0') {
1.6496 + /* We reject the empty path "" */
1.6497 + return -1;
1.6498 + }
1.6499 + /* Otherwise there is no way this path can be empty */
1.6500 + } else {
1.6501 + /*
1.6502 + * It is somewhat unusual to reach this code path without
1.6503 + * the object being of tclFsPathType. However, we do
1.6504 + * our best to deal with the situation.
1.6505 + */
1.6506 + int len;
1.6507 + Tcl_GetStringFromObj(pathPtr,&len);
1.6508 + if (len == 0) {
1.6509 + /* We reject the empty path "" */
1.6510 + return -1;
1.6511 + }
1.6512 + }
1.6513 + /*
1.6514 + * Path is of correct type, or is of non-zero length,
1.6515 + * so we accept it.
1.6516 + */
1.6517 + return TCL_OK;
1.6518 +}