summaryrefslogtreecommitdiffstats
path: root/generic/tclIOUtil.c
diff options
context:
space:
mode:
Diffstat (limited to 'generic/tclIOUtil.c')
-rw-r--r--generic/tclIOUtil.c167
1 files changed, 87 insertions, 80 deletions
diff --git a/generic/tclIOUtil.c b/generic/tclIOUtil.c
index de5d62d..63d16be 100644
--- a/generic/tclIOUtil.c
+++ b/generic/tclIOUtil.c
@@ -57,7 +57,7 @@ typedef struct FilesystemRecord {
* this information each time the corresponding epoch counter changes.
*/
-typedef struct ThreadSpecificData {
+typedef struct {
int initialized;
size_t cwdPathEpoch;
size_t filesystemEpoch;
@@ -139,7 +139,6 @@ Tcl_FSRenameFileProc TclpObjRenameFile;
Tcl_FSCreateDirectoryProc TclpObjCreateDirectory;
Tcl_FSCopyDirectoryProc TclpObjCopyDirectory;
Tcl_FSRemoveDirectoryProc TclpObjRemoveDirectory;
-Tcl_FSUnloadFileProc TclpUnloadFile;
Tcl_FSLinkProc TclpObjLink;
Tcl_FSListVolumesProc TclpObjListVolumes;
@@ -245,7 +244,7 @@ static Tcl_ThreadDataKey fsDataKey;
* code.
*/
-typedef struct FsDivertLoad {
+typedef struct {
Tcl_LoadHandle loadHandle;
Tcl_FSUnloadFileProc *unloadProcPtr;
Tcl_Obj *divertedFile;
@@ -276,8 +275,8 @@ Tcl_Stat(
Tcl_WideInt tmp1, tmp2, tmp3 = 0;
# define OUT_OF_RANGE(x) \
- (((Tcl_WideInt)(x)) < Tcl_LongAsWide(LONG_MIN) || \
- ((Tcl_WideInt)(x)) > Tcl_LongAsWide(LONG_MAX))
+ (((Tcl_WideInt)(x)) < LONG_MIN || \
+ ((Tcl_WideInt)(x)) > LONG_MAX)
# define OUT_OF_URANGE(x) \
(((Tcl_WideUInt)(x)) > ((Tcl_WideUInt)ULONG_MAX))
@@ -412,7 +411,6 @@ Tcl_GetCwd(
return Tcl_DStringValue(cwdPtr);
}
-/* Obsolete */
int
Tcl_EvalFile(
Tcl_Interp *interp, /* Interpreter in which to process file. */
@@ -611,6 +609,7 @@ FsRecacheFilesystemList(void)
while (toFree) {
FilesystemRecord *next = toFree->nextPtr;
+
toFree->fsPtr = NULL;
ckfree(toFree);
toFree = next;
@@ -672,7 +671,6 @@ TclFSEpoch(void)
return tsdPtr->filesystemEpoch;
}
-
/*
* If non-NULL, clientData is owned by us and must be freed later.
@@ -784,7 +782,9 @@ TclFinalizeFilesystem(void)
while (fsRecPtr != NULL) {
FilesystemRecord *tmpFsRecPtr = fsRecPtr->nextPtr;
- /* The native filesystem is static, so we don't free it. */
+ /*
+ * The native filesystem is static, so we don't free it.
+ */
if (fsRecPtr != &nativeFilesystemRecord) {
ckfree(fsRecPtr);
@@ -829,15 +829,6 @@ TclResetFilesystem(void)
if (++theFilesystemEpoch == 0) {
++theFilesystemEpoch;
}
-
-#ifdef _WIN32
- /*
- * Cleans up the win32 API filesystem proc lookup table. This must happen
- * very late in finalization so that deleting of copied dlls can occur.
- */
-
- TclWinResetInterfaces();
-#endif
}
/*
@@ -947,7 +938,7 @@ Tcl_FSRegister(
int
Tcl_FSUnregister(
- const Tcl_Filesystem *fsPtr) /* The filesystem record to remove. */
+ const Tcl_Filesystem *fsPtr)/* The filesystem record to remove. */
{
int retVal = TCL_ERROR;
FilesystemRecord *fsRecPtr;
@@ -1233,7 +1224,7 @@ FsAddMountsToGlobResult(
len--;
}
- len++; /* account for '/' in the mElt [Bug 1602539] */
+ len++; /* account for '/' in the mElt [Bug 1602539] */
mElt = TclNewFSPathObj(pathPtr, mount + len, mlen - len);
Tcl_ListObjAppendElement(NULL, resultPtr, mElt);
}
@@ -1399,31 +1390,62 @@ TclFSNormalizeToUniquePath(
{
FilesystemRecord *fsRecPtr, *firstFsRecPtr;
+ int i;
+ int isVfsPath = 0;
+ char *path;
+
/*
- * Call each of the "normalise path" functions in succession. This is a
- * special case, in which if we have a native filesystem handler, we call
- * it first. This is because the root of Tcl's filesystem is always a
- * native filesystem (i.e. '/' on unix is native).
+ * Paths starting with a UNC prefix whose final character is a colon
+ * are reserved for VFS use. These names can not conflict with real
+ * UNC paths per https://msdn.microsoft.com/en-us/library/gg465305.aspx
+ * and rfc3986's definition of reg-name.
+ *
+ * We check these first to avoid useless calls to the native filesystem's
+ * normalizePathProc.
*/
+ path = Tcl_GetStringFromObj(pathPtr, &i);
+
+ if ( (i >= 3) && ( (path[0] == '/' && path[1] == '/')
+ || (path[0] == '\\' && path[1] == '\\') ) ) {
+ for ( i = 2; ; i++) {
+ if (path[i] == '\0') break;
+ if (path[i] == path[0]) break;
+ }
+ --i;
+ if (path[i] == ':') isVfsPath = 1;
+ }
+ /*
+ * Call each of the "normalise path" functions in succession.
+ */
firstFsRecPtr = FsGetFirstFilesystem();
Claim();
- for (fsRecPtr=firstFsRecPtr; fsRecPtr!=NULL; fsRecPtr=fsRecPtr->nextPtr) {
- if (fsRecPtr->fsPtr != &tclNativeFilesystem) {
- continue;
- }
+
+ if (!isVfsPath) {
/*
- * TODO: Assume that we always find the native file system; it should
- * always be there...
+ * If we have a native filesystem handler, we call it first. This is
+ * because the root of Tcl's filesystem is always a native filesystem
+ * (i.e., '/' on unix is native).
*/
- if (fsRecPtr->fsPtr->normalizePathProc != NULL) {
- startAt = fsRecPtr->fsPtr->normalizePathProc(interp, pathPtr,
- startAt);
+ for (fsRecPtr=firstFsRecPtr; fsRecPtr!=NULL; fsRecPtr=fsRecPtr->nextPtr) {
+ if (fsRecPtr->fsPtr != &tclNativeFilesystem) {
+ continue;
+ }
+
+ /*
+ * TODO: Assume that we always find the native file system; it should
+ * always be there...
+ */
+
+ if (fsRecPtr->fsPtr->normalizePathProc != NULL) {
+ startAt = fsRecPtr->fsPtr->normalizePathProc(interp, pathPtr,
+ startAt);
+ }
+ break;
}
- break;
}
for (fsRecPtr=firstFsRecPtr; fsRecPtr!=NULL; fsRecPtr=fsRecPtr->nextPtr) {
@@ -1525,7 +1547,7 @@ TclGetOpenModeEx(
#define RW_MODES (O_RDONLY|O_WRONLY|O_RDWR)
/*
- * Check for the simpler fopen-like access modes (e.g. "r"). They are
+ * Check for the simpler fopen-like access modes (e.g., "r"). They are
* distinguished from the POSIX access modes by the presence of a
* lower-case first letter.
*/
@@ -1762,7 +1784,7 @@ Tcl_FSEvalFileEx(
* this cross-platform to allow for scripted documents. [Bug: 2040]
*/
- Tcl_SetChannelOption(interp, chan, "-eofchar", "\32");
+ Tcl_SetChannelOption(interp, chan, "-eofchar", "\32 {}");
/*
* If the encoding is specified, set it for the channel. Else don't touch
@@ -1785,7 +1807,7 @@ Tcl_FSEvalFileEx(
* be handled especially.
*/
- if (Tcl_ReadChars(chan, objPtr, 1, 0) < 0) {
+ if (Tcl_ReadChars(chan, objPtr, 1, 0) == TCL_IO_FAILURE) {
Tcl_Close(interp, chan);
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"couldn't read file \"%s\": %s",
@@ -1800,7 +1822,7 @@ Tcl_FSEvalFileEx(
*/
if (Tcl_ReadChars(chan, objPtr, -1,
- memcmp(string, "\xef\xbb\xbf", 3)) < 0) {
+ memcmp(string, "\xef\xbb\xbf", 3)) == TCL_IO_FAILURE) {
Tcl_Close(interp, chan);
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"couldn't read file \"%s\": %s",
@@ -1897,7 +1919,7 @@ TclNREvalFile(
* this cross-platform to allow for scripted documents. [Bug: 2040]
*/
- Tcl_SetChannelOption(interp, chan, "-eofchar", "\32");
+ Tcl_SetChannelOption(interp, chan, "-eofchar", "\32 {}");
/*
* If the encoding is specified, set it for the channel. Else don't touch
@@ -1920,7 +1942,7 @@ TclNREvalFile(
* be handled especially.
*/
- if (Tcl_ReadChars(chan, objPtr, 1, 0) < 0) {
+ if (Tcl_ReadChars(chan, objPtr, 1, 0) == TCL_IO_FAILURE) {
Tcl_Close(interp, chan);
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"couldn't read file \"%s\": %s",
@@ -1936,7 +1958,7 @@ TclNREvalFile(
*/
if (Tcl_ReadChars(chan, objPtr, -1,
- memcmp(string, "\xef\xbb\xbf", 3)) < 0) {
+ memcmp(string, "\xef\xbb\xbf", 3)) == TCL_IO_FAILURE) {
Tcl_Close(interp, chan);
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"couldn't read file \"%s\": %s",
@@ -2671,6 +2693,7 @@ Tcl_FSGetCwd(
fsRecPtr = fsRecPtr->nextPtr) {
ClientData retCd;
TclFSGetCwdProc2 *proc2;
+
if (fsRecPtr->fsPtr->getCwdProc == NULL) {
continue;
}
@@ -3143,8 +3166,8 @@ Tcl_FSLoadFile(
* Workaround for issue with modern HPUX which do allow the unlink (no ETXTBSY
* error) yet somehow trash some internal data structures which prevents the
* second and further shared libraries from getting properly loaded. Only the
- * first is ok. We try to get around the issue by not unlinking,
- * i.e. emulating the behaviour of the older HPUX which denied removal.
+ * first is ok. We try to get around the issue by not unlinking, i.e.,
+ * emulating the behaviour of the older HPUX which denied removal.
*
* Doing the unlink is also an issue within docker containers, whose AUFS
* bungles this as well, see
@@ -3161,29 +3184,31 @@ Tcl_FSLoadFile(
* present and set to true (any integer > 0) then the unlink is skipped.
*/
-int
-TclSkipUnlink (Tcl_Obj* shlibFile)
+static int
+skipUnlink(
+ Tcl_Obj *shlibFile)
{
- /* Order of testing:
+ /*
+ * Order of testing:
* 1. On hpux we generally want to skip unlink in general
*
* Outside of hpux then:
- * 2. For a general user request (TCL_TEMPLOAD_NO_UNLINK present, non-empty, => int)
+ * 2. For a general user request (TCL_TEMPLOAD_NO_UNLINK present,
+ * non-empty, => int)
* 3. For general AUFS environment (statfs, if available).
*
* Ad 2: This variable can disable/override the AUFS detection, i.e. for
- * testing if a newer AUFS does not have the bug any more.
+ * testing if a newer AUFS does not have the bug any more.
*
- * Ad 3: This is conditionally compiled in. Condition currently must be set manually.
- * This part needs proper tests in the configure(.in).
+ * Ad 3: This is conditionally compiled in. Condition currently must be
+ * set manually. This part needs proper tests in the configure(.in).
*/
#ifdef hpux
return 1;
#else
- char* skipstr;
+ char *skipstr = getenv("TCL_TEMPLOAD_NO_UNLINK");
- skipstr = getenv ("TCL_TEMPLOAD_NO_UNLINK");
if (skipstr && (skipstr[0] != '\0')) {
return atoi(skipstr);
}
@@ -3192,7 +3217,8 @@ TclSkipUnlink (Tcl_Obj* shlibFile)
#ifndef NO_FSTATFS
{
struct statfs fs;
- /* Have fstatfs. May not have the AUFS super magic ... Indeed our build
+ /*
+ * Have fstatfs. May not have the AUFS super magic ... Indeed our build
* box is too old to have it directly in the headers. Define taken from
* http://mooon.googlecode.com/svn/trunk/linux_include/linux/aufs_type.h
* http://aufs.sourceforge.net/
@@ -3201,16 +3227,18 @@ TclSkipUnlink (Tcl_Obj* shlibFile)
#ifndef AUFS_SUPER_MAGIC
#define AUFS_SUPER_MAGIC ('a' << 24 | 'u' << 16 | 'f' << 8 | 's')
#endif /* AUFS_SUPER_MAGIC */
- if ((statfs(Tcl_GetString (shlibFile), &fs) == 0) &&
- (fs.f_type == AUFS_SUPER_MAGIC)) {
+ if ((statfs(Tcl_GetString(shlibFile), &fs) == 0)
+ && (fs.f_type == AUFS_SUPER_MAGIC)) {
return 1;
}
}
#endif /* ... NO_FSTATFS */
#endif /* ... TCL_TEMPLOAD_NO_UNLINK */
- /* Fallback: !hpux, no EV override, no AUFS (detection, nor detected):
- * Don't skip */
+ /*
+ * Fallback: !hpux, no EV override, no AUFS (detection, nor detected):
+ * Don't skip
+ */
return 0;
#endif /* hpux */
}
@@ -3415,9 +3443,8 @@ Tcl_LoadFile(
* avoids any worries about leaving the copy laying around on exit.
*/
- if (
- !TclSkipUnlink (copyToPtr) &&
- (Tcl_FSDeleteFile(copyToPtr) == TCL_OK)) {
+ if (!skipUnlink(copyToPtr) &&
+ (Tcl_FSDeleteFile(copyToPtr) == TCL_OK)) {
Tcl_DecrRefCount(copyToPtr);
/*
@@ -3685,30 +3712,10 @@ Tcl_FSUnloadFile(
}
return TCL_ERROR;
}
- TclpUnloadFile(handle);
- return TCL_OK;
-}
-
-/*
- *----------------------------------------------------------------------
- *
- * TclpUnloadFile --
- *
- * Unloads a library given its handle
- *
- * This function was once filesystem-specific, but has been made portable by
- * having TclpDlopen return a structure that includes procedure pointers.
- *
- *----------------------------------------------------------------------
- */
-
-void
-TclpUnloadFile(
- Tcl_LoadHandle handle)
-{
if (handle->unloadFileProcPtr != NULL) {
handle->unloadFileProcPtr(handle);
}
+ return TCL_OK;
}
/*
generated by cgit v0.12 at 2024-10-20 23:55:51 (GMT)