summaryrefslogtreecommitdiffstats
diff options
context:
space:
mode:
Diffstat
-rw-r--r--ChangeLog38
-rw-r--r--doc/FileSystem.330
-rw-r--r--generic/tcl.decls18
-rw-r--r--generic/tclCmdAH.c141
-rw-r--r--generic/tclDecls.h37
-rw-r--r--generic/tclFCmd.c32
-rw-r--r--generic/tclFileName.c810
-rw-r--r--generic/tclFileSystem.h17
-rw-r--r--generic/tclIOUtil.c328
-rw-r--r--generic/tclInt.decls13
-rw-r--r--generic/tclInt.h39
-rw-r--r--generic/tclIntDecls.h21
-rw-r--r--generic/tclPathObj.c752
-rw-r--r--generic/tclStubInit.c4
-rw-r--r--generic/tclTest.c8
-rw-r--r--mac/tclMacFile.c85
-rw-r--r--tests/fCmd.test8
-rw-r--r--tests/fileName.test51
-rw-r--r--tests/fileSystem.test8
-rw-r--r--tests/winFCmd.test4
-rw-r--r--unix/tclUnixFile.c74
-rw-r--r--win/tclWin32Dll.c7
-rw-r--r--win/tclWinFCmd.c32
-rw-r--r--win/tclWinFile.c117
-rw-r--r--win/tclWinInt.h3
25 files changed, 1765 insertions, 912 deletions
diff --git a/ChangeLog b/ChangeLog
index e18e9ae..d1b4b81 100644
--- a/ChangeLog
+++ b/ChangeLog
@@ -1,3 +1,41 @@
+2004-01-21 Vince Darley <vincentdarley@users.sourceforge.net>
+
+ * doc/FileSystem.3:
+ * generic/tcl.decls:
+ * generic/tclCmdAH.c
+ * generic/tclDecls.h
+ * generic/tclFCmd.c
+ * generic/tclFileName.c
+ * generic/tclFileSystem.h
+ * generic/tclIOUtil.c
+ * generic/tclInt.decls
+ * generic/tclInt.h
+ * generic/tclIntDecls.h
+ * generic/tclPathObj.c
+ * generic/tclStubInit.c
+ * generic/tclTest.c
+ * mac/tclMacFile.c
+ * tests/fileName.test
+ * tests/fileSystem.test
+ * tests/winFCmd.test
+ * unix/tclUnixFile.c
+ * win/tclWin32Dll.c
+ * win/tclWinFCmd.c
+ * win/tclWinFile.c
+ * win/tclWinInt.h
+
+ Three main issues accomplished: (1) cleaned up variable names in
+ the filesystem code so that 'pathPtr' is used throughout. (2)
+ applied a round of filesystem optimisation with better handling
+ and caching of relative and absolute paths, requiring fewer
+ conversions. (3) clarifications to the documentation,
+ particularly regarding the acceptable refCounts of objects.
+ Some new tests added. Tcl benchmarks show a significant
+ improvement over 8.4.5, and typically a small improvement over
+ 8.3.5. TCL_FILESYSTEM_VERSION_2 introduced, but for internal
+ use only. There should be no public incompatibilities from
+ these changes. Thanks to dgp for extensive testing.
+
2004-01-19 David Gravereaux <davygrvy@pobox.com>
* win/tclWinPipe.c (Tcl_WaitPid): Fixed a thread-safety problem
diff --git a/doc/FileSystem.3 b/doc/FileSystem.3
index 66cb596..00a38da 100644
--- a/doc/FileSystem.3
+++ b/doc/FileSystem.3
@@ -4,7 +4,7 @@
'\" See the file "license.terms" for information on usage and redistribution
'\" of this file, and for a DISCLAIMER OF ALL WARRANTIES.
'\"
-'\" RCS: @(#) $Id: FileSystem.3,v 1.37 2003/12/16 18:20:49 vincentdarley Exp $
+'\" RCS: @(#) $Id: FileSystem.3,v 1.38 2004/01/21 19:59:33 vincentdarley Exp $
'\"
.so man.macros
.TH Filesystem 3 8.4 Tcl "Tcl Library Procedures"
@@ -499,12 +499,16 @@ part of the path).
The separator is returned as a Tcl_Obj containing a string of length
1. If the path is invalid, NULL is returned.
.PP
-\fBTcl_FSJoinPath\fR takes the given Tcl_Obj, which should be a valid list,
-and returns the path object given by considering the first 'elements'
-elements as valid path segments. If elements < 0, we use the entire
-list.
+\fBTcl_FSJoinPath\fR takes the given Tcl_Obj, which should be a valid
+list (which is allowed to have a refCount of zero), and returns the path
+object given by considering the first 'elements' elements as valid path
+segments. If elements < 0, we use the entire list.
.PP
-Returns object with refCount of zero, containing the joined path.
+Returns object, typically with refCount of zero (but it could be shared
+under some conditions) , containing the joined path. The caller must
+add a refCount to the object before using it. In particular, the
+returned object could be an element of the given list, so freeing the
+list might free the object prematurely if no refCount has been taken.
.PP
\fBTcl_FSSplitPath\fR takes the given Tcl_Obj, which should be a valid path,
and returns a Tcl List object containing each segment of that path as
@@ -539,7 +543,11 @@ course increment the refCount if it wishes to maintain a copy for longer.
valid path or NULL, and joins onto it the array of paths segments
given.
.PP
-Returns object with refCount of zero, containing the joined path.
+Returns object, typically with refCount of zero (but it could be shared
+under some conditions), containing the joined path. The caller must
+add a refCount to the object before using it. If any of the objects
+passed into this function (pathPtr or path elements) have a refCount
+of zero, they will be freed when this function returns.
.PP
\fBTcl_FSConvertToPathType\fR tries to convert the given Tcl_Obj to a valid
Tcl path type, taking account of the fact that the cwd may have changed
@@ -600,8 +608,12 @@ have non-string-based native representations (for example, on MacOS, a
representation using a fileSpec of FSRef structure would probably be
more efficient). On Windows a full Unicode representation would allow
for paths of unlimited length. Currently the representation is simply a
-character string containing the complete, absolute normalized path in
-the native encoding. If for some reason a non-absolute or
+character string which may contain either the relative path or a
+complete, absolute normalized path in the native encoding (complex
+conditions dictate which of these will be provided, so neither can be
+relied upon, unless the path is known to be absolute). If you need a
+native path which must be absolute, then you should ask for the native
+version of a normalized path. If for some reason a non-absolute,
non-normalized version of the path is needed, that must be constructed
separately (e.g. using \fBTcl_FSGetTranslatedPath\fR).
.PP
diff --git a/generic/tcl.decls b/generic/tcl.decls
index 084aed6..886354c 100644
--- a/generic/tcl.decls
+++ b/generic/tcl.decls
@@ -11,7 +11,7 @@
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
#
-# RCS: @(#) $Id: tcl.decls,v 1.101 2003/09/29 21:38:49 dkf Exp $
+# RCS: @(#) $Id: tcl.decls,v 1.102 2004/01/21 19:59:33 vincentdarley Exp $
library tcl
@@ -1639,14 +1639,14 @@ declare 462 generic {
int Tcl_FSEqualPaths(Tcl_Obj* firstPtr, Tcl_Obj* secondPtr)
}
declare 463 generic {
- Tcl_Obj* Tcl_FSGetNormalizedPath(Tcl_Interp *interp, Tcl_Obj* pathObjPtr)
+ Tcl_Obj* Tcl_FSGetNormalizedPath(Tcl_Interp *interp, Tcl_Obj* pathPtr)
}
declare 464 generic {
- Tcl_Obj* Tcl_FSJoinToPath(Tcl_Obj *basePtr, int objc,
+ Tcl_Obj* Tcl_FSJoinToPath(Tcl_Obj *pathPtr, int objc,
Tcl_Obj *CONST objv[])
}
declare 465 generic {
- ClientData Tcl_FSGetInternalRep(Tcl_Obj* pathObjPtr,
+ ClientData Tcl_FSGetInternalRep(Tcl_Obj* pathPtr,
Tcl_Filesystem *fsPtr)
}
declare 466 generic {
@@ -1660,13 +1660,13 @@ declare 468 generic {
ClientData clientData)
}
declare 469 generic {
- CONST char* Tcl_FSGetNativePath(Tcl_Obj* pathObjPtr)
+ CONST char* Tcl_FSGetNativePath(Tcl_Obj* pathPtr)
}
declare 470 generic {
- Tcl_Obj* Tcl_FSFileSystemInfo(Tcl_Obj* pathObjPtr)
+ Tcl_Obj* Tcl_FSFileSystemInfo(Tcl_Obj* pathPtr)
}
declare 471 generic {
- Tcl_Obj* Tcl_FSPathSeparator(Tcl_Obj* pathObjPtr)
+ Tcl_Obj* Tcl_FSPathSeparator(Tcl_Obj* pathPtr)
}
declare 472 generic {
Tcl_Obj* Tcl_FSListVolumes(void)
@@ -1685,10 +1685,10 @@ declare 476 generic {
Tcl_Obj* pathPtr)
}
declare 477 generic {
- Tcl_Filesystem* Tcl_FSGetFileSystemForPath(Tcl_Obj* pathObjPtr)
+ Tcl_Filesystem* Tcl_FSGetFileSystemForPath(Tcl_Obj* pathPtr)
}
declare 478 generic {
- Tcl_PathType Tcl_FSGetPathType(Tcl_Obj *pathObjPtr)
+ Tcl_PathType Tcl_FSGetPathType(Tcl_Obj *pathPtr)
}
# New function due to TIP#49
declare 479 generic {
diff --git a/generic/tclCmdAH.c b/generic/tclCmdAH.c
index 48d3101..c679195 100644
--- a/generic/tclCmdAH.c
+++ b/generic/tclCmdAH.c
@@ -11,7 +11,7 @@
* See the file "license.terms" for information on usage and redistribution
* of this file, and for a DISCLAIMER OF ALL WARRANTIES.
*
- * RCS: @(#) $Id: tclCmdAH.c,v 1.39 2003/12/24 04:18:18 davygrvy Exp $
+ * RCS: @(#) $Id: tclCmdAH.c,v 1.40 2004/01/21 19:59:33 vincentdarley Exp $
*/
#include "tclInt.h"
@@ -23,13 +23,13 @@
*/
static int CheckAccess _ANSI_ARGS_((Tcl_Interp *interp,
- Tcl_Obj *objPtr, int mode));
+ Tcl_Obj *pathPtr, int mode));
static int GetStatBuf _ANSI_ARGS_((Tcl_Interp *interp,
- Tcl_Obj *objPtr, Tcl_FSStatProc *statProc,
+ Tcl_Obj *pathPtr, Tcl_FSStatProc *statProc,
Tcl_StatBuf *statPtr));
static char * GetTypeFromMode _ANSI_ARGS_((int mode));
static int StoreStatData _ANSI_ARGS_((Tcl_Interp *interp,
- char *varName, Tcl_StatBuf *statPtr));
+ Tcl_Obj *varName, Tcl_StatBuf *statPtr));
/*
*----------------------------------------------------------------------
@@ -948,7 +948,7 @@ Tcl_FileObjCmd(dummy, interp, objc, objv)
if (objc != 3) {
goto only3Args;
}
- dirPtr = TclFileDirname(interp, objv[2]);
+ dirPtr = TclPathPart(interp, objv[2], TCL_PATH_DIRNAME);
if (dirPtr == NULL) {
return TCL_ERROR;
} else {
@@ -968,17 +968,19 @@ Tcl_FileObjCmd(dummy, interp, objc, objv)
}
return CheckAccess(interp, objv[2], F_OK);
case FCMD_EXTENSION: {
- char *fileName, *extension;
-
+ Tcl_Obj *ext;
+
if (objc != 3) {
goto only3Args;
}
- fileName = Tcl_GetString(objv[2]);
- extension = TclGetExtension(fileName);
- if (extension != NULL) {
- Tcl_SetStringObj(Tcl_GetObjResult(interp), extension, -1);
+ ext = TclPathPart(interp, objv[2], TCL_PATH_EXTENSION);
+ if (ext != NULL) {
+ Tcl_SetObjResult(interp, ext);
+ Tcl_DecrRefCount(ext);
+ return TCL_OK;
+ } else {
+ return TCL_ERROR;
}
- return TCL_OK;
}
case FCMD_ISDIRECTORY: {
int value;
@@ -1077,7 +1079,7 @@ Tcl_FileObjCmd(dummy, interp, objc, objv)
* doesn't exist.
*/
int access;
- Tcl_Obj *dirPtr = TclFileDirname(interp, objv[index]);
+ Tcl_Obj *dirPtr = TclPathPart(interp, objv[index], TCL_PATH_DIRNAME);
if (dirPtr == NULL) {
return TCL_ERROR;
}
@@ -1131,7 +1133,6 @@ Tcl_FileObjCmd(dummy, interp, objc, objv)
return TCL_OK;
}
case FCMD_LSTAT: {
- char *varName;
Tcl_StatBuf buf;
if (objc != 4) {
@@ -1141,8 +1142,7 @@ Tcl_FileObjCmd(dummy, interp, objc, objv)
if (GetStatBuf(interp, objv[2], Tcl_FSLstat, &buf) != TCL_OK) {
return TCL_ERROR;
}
- varName = Tcl_GetString(objv[3]);
- return StoreStatData(interp, varName, &buf);
+ return StoreStatData(interp, objv[3], &buf);
}
case FCMD_MTIME: {
Tcl_StatBuf buf;
@@ -1297,21 +1297,19 @@ Tcl_FileObjCmd(dummy, interp, objc, objv)
case FCMD_RENAME:
return TclFileRenameCmd(interp, objc, objv);
case FCMD_ROOTNAME: {
- int length;
- char *fileName, *extension;
+ Tcl_Obj *root;
if (objc != 3) {
goto only3Args;
}
- fileName = Tcl_GetStringFromObj(objv[2], &length);
- extension = TclGetExtension(fileName);
- if (extension == NULL) {
- Tcl_SetObjResult(interp, objv[2]);
+ root = TclPathPart(interp, objv[2], TCL_PATH_ROOT);
+ if (root != NULL) {
+ Tcl_SetObjResult(interp, root);
+ Tcl_DecrRefCount(root);
+ return TCL_OK;
} else {
- Tcl_SetStringObj(Tcl_GetObjResult(interp), fileName,
- (int) (length - strlen(extension)));
+ return TCL_ERROR;
}
- return TCL_OK;
}
case FCMD_SEPARATOR:
if ((objc < 2) || (objc > 3)) {
@@ -1356,14 +1354,27 @@ Tcl_FileObjCmd(dummy, interp, objc, objv)
(Tcl_WideInt) buf.st_size);
return TCL_OK;
}
- case FCMD_SPLIT:
+ case FCMD_SPLIT: {
+ Tcl_Obj *res;
+
if (objc != 3) {
goto only3Args;
}
- Tcl_SetObjResult(interp, Tcl_FSSplitPath(objv[2], NULL));
- return TCL_OK;
+ res = Tcl_FSSplitPath(objv[2], NULL);
+ if (res == NULL) {
+ if (interp != NULL) {
+ Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
+ "could not read \"", Tcl_GetString(objv[2]),
+ "\": no such file or directory",
+ (char *) NULL);
+ }
+ return TCL_ERROR;
+ } else {
+ Tcl_SetObjResult(interp, res);
+ return TCL_OK;
+ }
+ }
case FCMD_STAT: {
- char *varName;
Tcl_StatBuf buf;
if (objc != 4) {
@@ -1373,8 +1384,7 @@ Tcl_FileObjCmd(dummy, interp, objc, objv)
if (GetStatBuf(interp, objv[2], Tcl_FSStat, &buf) != TCL_OK) {
return TCL_ERROR;
}
- varName = Tcl_GetString(objv[3]);
- return StoreStatData(interp, varName, &buf);
+ return StoreStatData(interp, objv[3], &buf);
}
case FCMD_SYSTEM: {
Tcl_Obj* fsInfo;
@@ -1393,45 +1403,19 @@ Tcl_FileObjCmd(dummy, interp, objc, objv)
}
}
case FCMD_TAIL: {
- int splitElements;
- Tcl_Obj *splitPtr;
+ Tcl_Obj *dirPtr;
if (objc != 3) {
goto only3Args;
}
- /*
- * The behaviour we want here is slightly different to
- * the standard Tcl_FSSplitPath in the handling of home
- * directories; Tcl_FSSplitPath preserves the "~" while
- * this code computes the actual full path name, if we
- * had just a single component.
- */
- splitPtr = Tcl_FSSplitPath(objv[2], &splitElements);
- if ((splitElements == 1) && (Tcl_GetString(objv[2])[0] == '~')) {
- Tcl_DecrRefCount(splitPtr);
- splitPtr = Tcl_FSGetNormalizedPath(interp, objv[2]);
- if (splitPtr == NULL) {
- return TCL_ERROR;
- }
- splitPtr = Tcl_FSSplitPath(splitPtr, &splitElements);
- }
-
- /*
- * Return the last component, unless it is the only component,
- * and it is the root of an absolute path.
- */
-
- if (splitElements > 0) {
- if ((splitElements > 1)
- || (Tcl_FSGetPathType(objv[2]) == TCL_PATH_RELATIVE)) {
-
- Tcl_Obj *tail = NULL;
- Tcl_ListObjIndex(NULL, splitPtr, splitElements-1, &tail);
- Tcl_SetObjResult(interp, tail);
- }
+ dirPtr = TclPathPart(interp, objv[2], TCL_PATH_TAIL);
+ if (dirPtr == NULL) {
+ return TCL_ERROR;
+ } else {
+ Tcl_SetObjResult(interp, dirPtr);
+ Tcl_DecrRefCount(dirPtr);
+ return TCL_OK;
}
- Tcl_DecrRefCount(splitPtr);
- return TCL_OK;
}
case FCMD_TYPE: {
Tcl_StatBuf buf;
@@ -1484,19 +1468,19 @@ Tcl_FileObjCmd(dummy, interp, objc, objv)
*/
static int
-CheckAccess(interp, objPtr, mode)
+CheckAccess(interp, pathPtr, mode)
Tcl_Interp *interp; /* Interp for status return. Must not be
* NULL. */
- Tcl_Obj *objPtr; /* Name of file to check. */
+ Tcl_Obj *pathPtr; /* Name of file to check. */
int mode; /* Attribute to check; passed as argument to
* access(). */
{
int value;
- if (Tcl_FSConvertToPathType(interp, objPtr) != TCL_OK) {
+ if (Tcl_FSConvertToPathType(interp, pathPtr) != TCL_OK) {
value = 0;
} else {
- value = (Tcl_FSAccess(objPtr, mode) == 0);
+ value = (Tcl_FSAccess(pathPtr, mode) == 0);
}
Tcl_SetBooleanObj(Tcl_GetObjResult(interp), value);
@@ -1524,9 +1508,9 @@ CheckAccess(interp, objPtr, mode)
*/
static int
-GetStatBuf(interp, objPtr, statProc, statPtr)
+GetStatBuf(interp, pathPtr, statProc, statPtr)
Tcl_Interp *interp; /* Interp for error return. May be NULL. */
- Tcl_Obj *objPtr; /* Path name to examine. */
+ Tcl_Obj *pathPtr; /* Path name to examine. */
Tcl_FSStatProc *statProc; /* Either stat() or lstat() depending on
* desired behavior. */
Tcl_StatBuf *statPtr; /* Filled with info about file obtained by
@@ -1534,16 +1518,16 @@ GetStatBuf(interp, objPtr, statProc, statPtr)
{
int status;
- if (Tcl_FSConvertToPathType(interp, objPtr) != TCL_OK) {
+ if (Tcl_FSConvertToPathType(interp, pathPtr) != TCL_OK) {
return TCL_ERROR;
}
- status = (*statProc)(objPtr, statPtr);
+ status = (*statProc)(pathPtr, statPtr);
if (status < 0) {
if (interp != NULL) {
Tcl_AppendResult(interp, "could not read \"",
- Tcl_GetString(objPtr), "\": ",
+ Tcl_GetString(pathPtr), "\": ",
Tcl_PosixError(interp), (char *) NULL);
}
return TCL_ERROR;
@@ -1573,12 +1557,11 @@ GetStatBuf(interp, objPtr, statProc, statPtr)
static int
StoreStatData(interp, varName, statPtr)
Tcl_Interp *interp; /* Interpreter for error reports. */
- char *varName; /* Name of associative array variable
+ Tcl_Obj *varName; /* Name of associative array variable
* in which to store stat results. */
Tcl_StatBuf *statPtr; /* Pointer to buffer containing
* stat data to store in varName. */
{
- Tcl_Obj *var = Tcl_NewStringObj(varName, -1);
Tcl_Obj *field = Tcl_NewObj();
Tcl_Obj *value;
register unsigned short mode;
@@ -1589,14 +1572,13 @@ StoreStatData(interp, varName, statPtr)
#define STORE_ARY(fieldName, object) \
Tcl_SetStringObj(field, (fieldName), -1); \
value = (object); \
- if (Tcl_ObjSetVar2(interp,var,field,value,TCL_LEAVE_ERR_MSG) == NULL) { \
- Tcl_DecrRefCount(var); \
+ if (Tcl_ObjSetVar2(interp,varName,field,value,TCL_LEAVE_ERR_MSG) == NULL) { \
+ Tcl_DecrRefCount(varName); \
Tcl_DecrRefCount(field); \
Tcl_DecrRefCount(value); \
return TCL_ERROR; \
}
- Tcl_IncrRefCount(var);
Tcl_IncrRefCount(field);
STORE_ARY("dev", Tcl_NewLongObj((long)statPtr->st_dev));
/*
@@ -1619,7 +1601,6 @@ StoreStatData(interp, varName, statPtr)
STORE_ARY("mode", Tcl_NewIntObj(mode));
STORE_ARY("type", Tcl_NewStringObj(GetTypeFromMode(mode), -1));
#undef STORE_ARY
- Tcl_DecrRefCount(var);
Tcl_DecrRefCount(field);
return TCL_OK;
}
diff --git a/generic/tclDecls.h b/generic/tclDecls.h
index 1cacfd4..dba4689 100644
--- a/generic/tclDecls.h
+++ b/generic/tclDecls.h
@@ -8,7 +8,7 @@
* See the file "license.terms" for information on usage and redistribution
* of this file, and for a DISCLAIMER OF ALL WARRANTIES.
*
- * RCS: @(#) $Id: tclDecls.h,v 1.100 2003/09/29 21:45:35 dkf Exp $
+ * RCS: @(#) $Id: tclDecls.h,v 1.101 2004/01/21 19:59:33 vincentdarley Exp $
*/
#ifndef _TCLDECLS
@@ -2870,19 +2870,19 @@ EXTERN int Tcl_FSEqualPaths _ANSI_ARGS_((Tcl_Obj* firstPtr,
#define Tcl_FSGetNormalizedPath_TCL_DECLARED
/* 463 */
EXTERN Tcl_Obj* Tcl_FSGetNormalizedPath _ANSI_ARGS_((
- Tcl_Interp * interp, Tcl_Obj* pathObjPtr));
+ Tcl_Interp * interp, Tcl_Obj* pathPtr));
#endif
#ifndef Tcl_FSJoinToPath_TCL_DECLARED
#define Tcl_FSJoinToPath_TCL_DECLARED
/* 464 */
-EXTERN Tcl_Obj* Tcl_FSJoinToPath _ANSI_ARGS_((Tcl_Obj * basePtr,
+EXTERN Tcl_Obj* Tcl_FSJoinToPath _ANSI_ARGS_((Tcl_Obj * pathPtr,
int objc, Tcl_Obj *CONST objv[]));
#endif
#ifndef Tcl_FSGetInternalRep_TCL_DECLARED
#define Tcl_FSGetInternalRep_TCL_DECLARED
/* 465 */
-EXTERN ClientData Tcl_FSGetInternalRep _ANSI_ARGS_((
- Tcl_Obj* pathObjPtr, Tcl_Filesystem * fsPtr));
+EXTERN ClientData Tcl_FSGetInternalRep _ANSI_ARGS_((Tcl_Obj* pathPtr,
+ Tcl_Filesystem * fsPtr));
#endif
#ifndef Tcl_FSGetTranslatedPath_TCL_DECLARED
#define Tcl_FSGetTranslatedPath_TCL_DECLARED
@@ -2906,18 +2906,17 @@ EXTERN Tcl_Obj* Tcl_FSNewNativePath _ANSI_ARGS_((
#ifndef Tcl_FSGetNativePath_TCL_DECLARED
#define Tcl_FSGetNativePath_TCL_DECLARED
/* 469 */
-EXTERN CONST char* Tcl_FSGetNativePath _ANSI_ARGS_((Tcl_Obj* pathObjPtr));
+EXTERN CONST char* Tcl_FSGetNativePath _ANSI_ARGS_((Tcl_Obj* pathPtr));
#endif
#ifndef Tcl_FSFileSystemInfo_TCL_DECLARED
#define Tcl_FSFileSystemInfo_TCL_DECLARED
/* 470 */
-EXTERN Tcl_Obj* Tcl_FSFileSystemInfo _ANSI_ARGS_((
- Tcl_Obj* pathObjPtr));
+EXTERN Tcl_Obj* Tcl_FSFileSystemInfo _ANSI_ARGS_((Tcl_Obj* pathPtr));
#endif
#ifndef Tcl_FSPathSeparator_TCL_DECLARED
#define Tcl_FSPathSeparator_TCL_DECLARED
/* 471 */
-EXTERN Tcl_Obj* Tcl_FSPathSeparator _ANSI_ARGS_((Tcl_Obj* pathObjPtr));
+EXTERN Tcl_Obj* Tcl_FSPathSeparator _ANSI_ARGS_((Tcl_Obj* pathPtr));
#endif
#ifndef Tcl_FSListVolumes_TCL_DECLARED
#define Tcl_FSListVolumes_TCL_DECLARED
@@ -2950,12 +2949,12 @@ EXTERN CONST char* Tcl_FSGetTranslatedStringPath _ANSI_ARGS_((
#define Tcl_FSGetFileSystemForPath_TCL_DECLARED
/* 477 */
EXTERN Tcl_Filesystem* Tcl_FSGetFileSystemForPath _ANSI_ARGS_((
- Tcl_Obj* pathObjPtr));
+ Tcl_Obj* pathPtr));
#endif
#ifndef Tcl_FSGetPathType_TCL_DECLARED
#define Tcl_FSGetPathType_TCL_DECLARED
/* 478 */
-EXTERN Tcl_PathType Tcl_FSGetPathType _ANSI_ARGS_((Tcl_Obj * pathObjPtr));
+EXTERN Tcl_PathType Tcl_FSGetPathType _ANSI_ARGS_((Tcl_Obj * pathPtr));
#endif
#ifndef Tcl_OutputBuffered_TCL_DECLARED
#define Tcl_OutputBuffered_TCL_DECLARED
@@ -3745,22 +3744,22 @@ typedef struct TclStubs {
Tcl_Obj* (*tcl_FSJoinPath) _ANSI_ARGS_((Tcl_Obj * listObj, int elements)); /* 460 */
Tcl_Obj* (*tcl_FSSplitPath) _ANSI_ARGS_((Tcl_Obj* pathPtr, int * lenPtr)); /* 461 */
int (*tcl_FSEqualPaths) _ANSI_ARGS_((Tcl_Obj* firstPtr, Tcl_Obj* secondPtr)); /* 462 */
- Tcl_Obj* (*tcl_FSGetNormalizedPath) _ANSI_ARGS_((Tcl_Interp * interp, Tcl_Obj* pathObjPtr)); /* 463 */
- Tcl_Obj* (*tcl_FSJoinToPath) _ANSI_ARGS_((Tcl_Obj * basePtr, int objc, Tcl_Obj *CONST objv[])); /* 464 */
- ClientData (*tcl_FSGetInternalRep) _ANSI_ARGS_((Tcl_Obj* pathObjPtr, Tcl_Filesystem * fsPtr)); /* 465 */
+ Tcl_Obj* (*tcl_FSGetNormalizedPath) _ANSI_ARGS_((Tcl_Interp * interp, Tcl_Obj* pathPtr)); /* 463 */
+ Tcl_Obj* (*tcl_FSJoinToPath) _ANSI_ARGS_((Tcl_Obj * pathPtr, int objc, Tcl_Obj *CONST objv[])); /* 464 */
+ ClientData (*tcl_FSGetInternalRep) _ANSI_ARGS_((Tcl_Obj* pathPtr, Tcl_Filesystem * fsPtr)); /* 465 */
Tcl_Obj* (*tcl_FSGetTranslatedPath) _ANSI_ARGS_((Tcl_Interp * interp, Tcl_Obj* pathPtr)); /* 466 */
int (*tcl_FSEvalFile) _ANSI_ARGS_((Tcl_Interp * interp, Tcl_Obj * fileName)); /* 467 */
Tcl_Obj* (*tcl_FSNewNativePath) _ANSI_ARGS_((Tcl_Filesystem* fromFilesystem, ClientData clientData)); /* 468 */
- CONST char* (*tcl_FSGetNativePath) _ANSI_ARGS_((Tcl_Obj* pathObjPtr)); /* 469 */
- Tcl_Obj* (*tcl_FSFileSystemInfo) _ANSI_ARGS_((Tcl_Obj* pathObjPtr)); /* 470 */
- Tcl_Obj* (*tcl_FSPathSeparator) _ANSI_ARGS_((Tcl_Obj* pathObjPtr)); /* 471 */
+ CONST char* (*tcl_FSGetNativePath) _ANSI_ARGS_((Tcl_Obj* pathPtr)); /* 469 */
+ Tcl_Obj* (*tcl_FSFileSystemInfo) _ANSI_ARGS_((Tcl_Obj* pathPtr)); /* 470 */
+ Tcl_Obj* (*tcl_FSPathSeparator) _ANSI_ARGS_((Tcl_Obj* pathPtr)); /* 471 */
Tcl_Obj* (*tcl_FSListVolumes) _ANSI_ARGS_((void)); /* 472 */
int (*tcl_FSRegister) _ANSI_ARGS_((ClientData clientData, Tcl_Filesystem * fsPtr)); /* 473 */
int (*tcl_FSUnregister) _ANSI_ARGS_((Tcl_Filesystem * fsPtr)); /* 474 */
ClientData (*tcl_FSData) _ANSI_ARGS_((Tcl_Filesystem * fsPtr)); /* 475 */
CONST char* (*tcl_FSGetTranslatedStringPath) _ANSI_ARGS_((Tcl_Interp * interp, Tcl_Obj* pathPtr)); /* 476 */
- Tcl_Filesystem* (*tcl_FSGetFileSystemForPath) _ANSI_ARGS_((Tcl_Obj* pathObjPtr)); /* 477 */
- Tcl_PathType (*tcl_FSGetPathType) _ANSI_ARGS_((Tcl_Obj * pathObjPtr)); /* 478 */
+ Tcl_Filesystem* (*tcl_FSGetFileSystemForPath) _ANSI_ARGS_((Tcl_Obj* pathPtr)); /* 477 */
+ Tcl_PathType (*tcl_FSGetPathType) _ANSI_ARGS_((Tcl_Obj * pathPtr)); /* 478 */
int (*tcl_OutputBuffered) _ANSI_ARGS_((Tcl_Channel chan)); /* 479 */
void (*tcl_FSMountsChanged) _ANSI_ARGS_((Tcl_Filesystem * fsPtr)); /* 480 */
int (*tcl_EvalTokensStandard) _ANSI_ARGS_((Tcl_Interp * interp, Tcl_Token * tokenPtr, int count)); /* 481 */
diff --git a/generic/tclFCmd.c b/generic/tclFCmd.c
index fb4a880..3d78f4c 100644
--- a/generic/tclFCmd.c
+++ b/generic/tclFCmd.c
@@ -9,7 +9,7 @@
* See the file "license.terms" for information on usage and redistribution
* of this file, and for a DISCLAIMER OF ALL WARRANTIES.
*
- * RCS: @(#) $Id: tclFCmd.c,v 1.22 2003/06/23 10:14:02 vincentdarley Exp $
+ * RCS: @(#) $Id: tclFCmd.c,v 1.23 2004/01/21 19:59:33 vincentdarley Exp $
*/
#include "tclInt.h"
@@ -241,6 +241,7 @@ TclFileMakeDirsCmd(interp, objc, objv)
}
split = Tcl_FSSplitPath(objv[i],&pobjc);
+ Tcl_IncrRefCount(split);
if (pobjc == 0) {
errno = ENOENT;
errfile = objv[i];
@@ -553,12 +554,18 @@ CopyRenameOneFile(interp, source, target, copyFlag, force)
actualSource = source;
Tcl_IncrRefCount(actualSource);
-#if 0
-#ifdef S_ISLNK
/*
- * To add a flag to make 'copy' copy links instead of files, we could
- * add a condition to ignore this 'if' here.
+ * Activate the following block to copy files instead of links.
+ * However Tcl's semantics currently say we should copy links, so
+ * any such change should be the subject of careful study on
+ * the consequences.
+ *
+ * Perhaps there could be an optional flag to 'file copy' to
+ * dictate which approach to use, with the default being _not_
+ * to have this block active.
*/
+#if 0
+#ifdef S_ISLNK
if (copyFlag && S_ISLNK(sourceStatBuf.st_mode)) {
/*
* We want to copy files not links. Therefore we must follow the
@@ -581,6 +588,17 @@ CopyRenameOneFile(interp, source, target, copyFlag, force)
if (path == NULL) {
break;
}
+ /*
+ * Now we want to check if this is a relative path,
+ * and if so, to make it absolute
+ */
+ if (Tcl_FSGetPathType(path) == TCL_PATH_RELATIVE) {
+ Tcl_Obj *abs = Tcl_FSJoinToPath(actualSource, 1, &path);
+ if (abs == NULL) break;
+ Tcl_IncrRefCount(abs);
+ Tcl_DecrRefCount(path);
+ path = abs;
+ }
Tcl_DecrRefCount(actualSource);
actualSource = path;
counter++;
@@ -796,7 +814,8 @@ FileBasename(interp, pathPtr)
Tcl_Obj *resultPtr = NULL;
splitPtr = Tcl_FSSplitPath(pathPtr, &objc);
-
+ Tcl_IncrRefCount(splitPtr);
+
if (objc != 0) {
if ((objc == 1) && (*Tcl_GetString(pathPtr) == '~')) {
Tcl_DecrRefCount(splitPtr);
@@ -804,6 +823,7 @@ FileBasename(interp, pathPtr)
return NULL;
}
splitPtr = Tcl_FSSplitPath(pathPtr, &objc);
+ Tcl_IncrRefCount(splitPtr);
}
/*
diff --git a/generic/tclFileName.c b/generic/tclFileName.c
index 52ebfd8..54c11cc 100644
--- a/generic/tclFileName.c
+++ b/generic/tclFileName.c
@@ -10,7 +10,7 @@
* See the file "license.terms" for information on usage and redistribution
* of this file, and for a DISCLAIMER OF ALL WARRANTIES.
*
- * RCS: @(#) $Id: tclFileName.c,v 1.45 2004/01/13 17:13:01 dgp Exp $
+ * RCS: @(#) $Id: tclFileName.c,v 1.46 2004/01/21 19:59:33 vincentdarley Exp $
*/
#include "tclInt.h"
@@ -75,11 +75,15 @@ static CONST char * DoTildeSubst _ANSI_ARGS_((Tcl_Interp *interp,
static CONST char * ExtractWinRoot _ANSI_ARGS_((CONST char *path,
Tcl_DString *resultPtr, int offset,
Tcl_PathType *typePtr));
-static int SkipToChar _ANSI_ARGS_((char **stringPtr,
- char *match));
+static int SkipToChar _ANSI_ARGS_((CONST char **stringPtr,
+ char match));
static Tcl_Obj* SplitMacPath _ANSI_ARGS_((CONST char *path));
static Tcl_Obj* SplitWinPath _ANSI_ARGS_((CONST char *path));
static Tcl_Obj* SplitUnixPath _ANSI_ARGS_((CONST char *path));
+static int DoGlob _ANSI_ARGS_((Tcl_Interp *interp,
+ char *separators, Tcl_Obj *pathPtr,
+ int flags, char *pattern, Tcl_GlobTypeData *types));
+
#ifdef MAC_UNDERSTANDS_UNIX_PATHS
/*
@@ -347,14 +351,15 @@ Tcl_GetPathType(path)
*/
Tcl_PathType
-TclpGetNativePathType(pathObjPtr, driveNameLengthPtr, driveNameRef)
- Tcl_Obj *pathObjPtr;
- int *driveNameLengthPtr;
- Tcl_Obj **driveNameRef;
+TclpGetNativePathType(pathPtr, driveNameLengthPtr, driveNameRef)
+ Tcl_Obj *pathPtr; /* Native path of interest */
+ int *driveNameLengthPtr; /* Returns length of drive, if non-NULL
+ * and path was absolute */
+ Tcl_Obj **driveNameRef;
{
Tcl_PathType type = TCL_PATH_ABSOLUTE;
int pathLen;
- char *path = Tcl_GetStringFromObj(pathObjPtr, &pathLen);
+ char *path = Tcl_GetStringFromObj(pathPtr, &pathLen);
if (path[0] == '~') {
/*
@@ -611,6 +616,7 @@ Tcl_SplitPath(path, argcPtr, argvPtr)
tmpPtr = Tcl_NewStringObj(path, -1);
Tcl_IncrRefCount(tmpPtr);
resultPtr = Tcl_FSSplitPath(tmpPtr, argcPtr);
+ Tcl_IncrRefCount(resultPtr);
Tcl_DecrRefCount(tmpPtr);
/* Calculate space required for the result */
@@ -1055,9 +1061,15 @@ SplitMacPath(path)
* This function takes the given object, which should usually be a
* valid path or NULL, and joins onto it the array of paths
* segments given.
- *
+ *
+ * The objects in the array given will temporarily have their
+ * refCount increased by one, and then decreased by one when this
+ * function exits (which means if they had zero refCount when we
+ * were called, they will be freed).
+ *
* Results:
- * Returns object with refCount of zero
+ * Returns object owned by the caller (which should increment its
+ * refCount) - typically an object with refCount of zero.
*
* Side effects:
* None.
@@ -1066,25 +1078,35 @@ SplitMacPath(path)
*/
Tcl_Obj*
-Tcl_FSJoinToPath(basePtr, objc, objv)
- Tcl_Obj *basePtr;
- int objc;
- Tcl_Obj *CONST objv[];
+Tcl_FSJoinToPath(pathPtr, objc, objv)
+ Tcl_Obj *pathPtr; /* Valid path or NULL. */
+ int objc; /* Number of array elements to join */
+ Tcl_Obj *CONST objv[]; /* Path elements to join. */
{
int i;
Tcl_Obj *lobj, *ret;
- if (basePtr == NULL) {
+ if (pathPtr == NULL) {
lobj = Tcl_NewListObj(0, NULL);
} else {
- lobj = Tcl_NewListObj(1, &basePtr);
+ lobj = Tcl_NewListObj(1, &pathPtr);
}
for (i = 0; i<objc;i++) {
Tcl_ListObjAppendElement(NULL, lobj, objv[i]);
}
ret = Tcl_FSJoinPath(lobj, -1);
+ /*
+ * It is possible that 'ret' is just a member of the list and is
+ * therefore going to be freed here. Therefore we must adjust the
+ * refCount manually. (It would be better if we changed the
+ * documentation of this function and Tcl_FSJoinPath so that
+ * the returned object already has a refCount for the caller,
+ * hence avoiding these subtleties (and code ugliness)).
+ */
+ Tcl_IncrRefCount(ret);
Tcl_DecrRefCount(lobj);
+ ret->refCount--;
return ret;
}
@@ -1428,11 +1450,11 @@ Tcl_TranslateFileName(interp, name, bufferPtr)
*----------------------------------------------------------------------
*/
-char *
+CONST char *
TclGetExtension(name)
- char *name; /* File name to parse. */
+ CONST char *name; /* File name to parse. */
{
- char *p, *lastSep;
+ CONST char *p, *lastSep;
/*
* First find the last directory separator.
@@ -1710,8 +1732,15 @@ Tcl_GlobObjCmd(dummy, interp, objc, objv)
char *search, *find;
Tcl_DStringInit(&pref);
if (last == first) {
- /* The whole thing is a prefix */
+ /*
+ * The whole thing is a prefix. This means we must
+ * remove any 'tails' flag too, since it is irrelevant
+ * now (the same effect will happen without it), but in
+ * particular its use in TclGlob requires a non-NULL
+ * pathOrDir.
+ */
Tcl_DStringAppend(&pref, first, -1);
+ globFlags &= ~TCL_GLOBMODE_TAILS;
pathOrDir = NULL;
} else {
/* Have to split off the end */
@@ -1957,20 +1986,24 @@ Tcl_GlobObjCmd(dummy, interp, objc, objv)
*
* TclGlob --
*
- * This procedure prepares arguments for the TclDoGlob call.
+ * This procedure prepares arguments for the DoGlob call.
* It sets the separator string based on the platform, performs
- * tilde substitution, and calls TclDoGlob.
+ * tilde substitution, and calls DoGlob.
*
* The interpreter's result, on entry to this function, must
* be a valid Tcl list (e.g. it could be empty), since we will
* lappend any new results to that list. If it is not a valid
* list, this function will fail to do anything very meaningful.
+ *
+ * Note that if globFlags contains 'TCL_GLOBMODE_TAILS' then
+ * pathPrefix cannot be NULL (it is only allowed with -dir or
+ * -path).
*
* Results:
* The return value is a standard Tcl result indicating whether
* an error occurred in globbing. After a normal return the
- * result in interp (set by TclDoGlob) holds all of the file names
- * given by the pattern and unquotedPrefix arguments. After an
+ * result in interp (set by DoGlob) holds all of the file names
+ * given by the pattern and pathPrefix arguments. After an
* error the result in interp will hold an error message, unless
* the 'TCL_GLOBMODE_NO_COMPLAIN' flag was given, in which case
* an error results in a TCL_OK return leaving the interpreter's
@@ -1984,13 +2017,13 @@ Tcl_GlobObjCmd(dummy, interp, objc, objv)
/* ARGSUSED */
int
-TclGlob(interp, pattern, unquotedPrefix, globFlags, types)
+TclGlob(interp, pattern, pathPrefix, globFlags, types)
Tcl_Interp *interp; /* Interpreter for returning error message
* or appending list of matching file names. */
char *pattern; /* Glob pattern to match. Must not refer
* to a static string. */
- Tcl_Obj *unquotedPrefix; /* Prefix to glob pattern, if non-null, which
- * is considered literally. */
+ Tcl_Obj *pathPrefix; /* Path prefix to glob pattern, if non-null,
+ * which is considered literally. */
int globFlags; /* Stores or'ed combination of flags */
Tcl_GlobTypeData *types; /* Struct containing acceptable types.
* May be NULL. */
@@ -1998,11 +2031,9 @@ TclGlob(interp, pattern, unquotedPrefix, globFlags, types)
char *separators;
CONST char *head;
char *tail, *start;
- char c;
- int result, prefixLen;
- Tcl_DString buffer;
+ int result;
Tcl_Obj *oldResult;
-
+
separators = NULL; /* lint. */
switch (tclPlatform) {
case TCL_PLATFORM_UNIX:
@@ -2013,7 +2044,7 @@ TclGlob(interp, pattern, unquotedPrefix, globFlags, types)
break;
case TCL_PLATFORM_MAC:
#ifdef MAC_UNDERSTANDS_UNIX_PATHS
- if (unquotedPrefix == NULL) {
+ if (pathPrefix == NULL) {
separators = (strchr(pattern, ':') == NULL) ? "/" : ":";
} else {
separators = ":";
@@ -2024,91 +2055,120 @@ TclGlob(interp, pattern, unquotedPrefix, globFlags, types)
break;
}
- Tcl_DStringInit(&buffer);
- if (unquotedPrefix != NULL) {
- start = Tcl_GetString(unquotedPrefix);
- } else {
- start = pattern;
- }
-
- /*
- * Perform tilde substitution, if needed.
- */
+ if (pathPrefix == NULL) {
+ char c;
+ Tcl_DString buffer;
+ Tcl_DStringInit(&buffer);
- if (start[0] == '~') {
-
+ start = pattern;
/*
- * Find the first path separator after the tilde.
+ * Perform tilde substitution, if needed.
*/
- for (tail = start; *tail != '\0'; tail++) {
- if (*tail == '\\') {
- if (strchr(separators, tail[1]) != NULL) {
+
+ if (start[0] == '~') {
+
+ /*
+ * Find the first path separator after the tilde.
+ */
+ for (tail = start; *tail != '\0'; tail++) {
+ if (*tail == '\\') {
+ if (strchr(separators, tail[1]) != NULL) {
+ break;
+ }
+ } else if (strchr(separators, *tail) != NULL) {
break;
}
- } else if (strchr(separators, *tail) != NULL) {
- break;
}
- }
- /*
- * Determine the home directory for the specified user.
- */
-
- c = *tail;
- *tail = '\0';
- if (globFlags & TCL_GLOBMODE_NO_COMPLAIN) {
- /*
- * We will ignore any error message here, and we
- * don't want to mess up the interpreter's result.
+ /*
+ * Determine the home directory for the specified user.
*/
- head = DoTildeSubst(NULL, start+1, &buffer);
- } else {
- head = DoTildeSubst(interp, start+1, &buffer);
- }
- *tail = c;
- if (head == NULL) {
+
+ c = *tail;
+ *tail = '\0';
if (globFlags & TCL_GLOBMODE_NO_COMPLAIN) {
- return TCL_OK;
+ /*
+ * We will ignore any error message here, and we
+ * don't want to mess up the interpreter's result.
+ */
+ head = DoTildeSubst(NULL, start+1, &buffer);
} else {
- return TCL_ERROR;
+ head = DoTildeSubst(interp, start+1, &buffer);
}
- }
- if (head != Tcl_DStringValue(&buffer)) {
- Tcl_DStringAppend(&buffer, head, -1);
- }
- if (unquotedPrefix != NULL) {
- Tcl_DStringAppend(&buffer, tail, -1);
+ *tail = c;
+ if (head == NULL) {
+ if (globFlags & TCL_GLOBMODE_NO_COMPLAIN) {
+ return TCL_OK;
+ } else {
+ return TCL_ERROR;
+ }
+ }
+ if (head != Tcl_DStringValue(&buffer)) {
+ Tcl_DStringAppend(&buffer, head, -1);
+ }
+ pathPrefix = Tcl_NewStringObj(Tcl_DStringValue(&buffer),
+ Tcl_DStringLength(&buffer));
+ Tcl_IncrRefCount(pathPrefix);
+ globFlags |= TCL_GLOBMODE_DIR;
+ if (c != '\0') {
+ tail++;
+ }
+ Tcl_DStringFree(&buffer);
+ } else {
tail = pattern;
}
} else {
+ Tcl_IncrRefCount(pathPrefix);
tail = pattern;
- if (unquotedPrefix != NULL) {
- Tcl_DStringAppend(&buffer,Tcl_GetString(unquotedPrefix),-1);
- }
}
/*
- * We want to remember the length of the current prefix,
- * in case we are using TCL_GLOBMODE_TAILS. Also if we
- * are using TCL_GLOBMODE_DIR, we must make sure the
- * prefix ends in a directory separator.
+ * Handling empty path prefixes with glob patterns like 'C:' or
+ * 'c:////////' is a pain on Windows if we leave it too late, since
+ * these aren't really patterns at all! We therefore check the head
+ * of the pattern now for such cases, if we don't have an unquoted
+ * prefix yet.
+ *
+ * Similarly on Unix with '/' at the head of the pattern -- it
+ * just indicates the root volume, so we treat it as such.
*/
- prefixLen = Tcl_DStringLength(&buffer);
-
- if (prefixLen > 0) {
- c = Tcl_DStringValue(&buffer)[prefixLen-1];
- if (strchr(separators, c) == NULL) {
- /*
- * If the prefix is a directory, make sure it ends in a
- * directory separator.
- */
- if (globFlags & TCL_GLOBMODE_DIR) {
- Tcl_DStringAppend(&buffer,separators,1);
+ if (tclPlatform == TCL_PLATFORM_WINDOWS) {
+ if (pathPrefix == NULL && tail[0] != '\0' && tail[1] == ':') {
+ char *p = tail + 1;
+ pathPrefix = Tcl_NewStringObj(tail, 1);
+ while (*p != '\0') {
+ char c = p[1];
+ if (*p == '\\') {
+ if (strchr(separators, c) != NULL) {
+ if (c == '\\') c = '/';
+ Tcl_AppendToObj(pathPrefix, &c, 1);
+ p++;
+ } else {
+ break;
+ }
+ } else if (strchr(separators, *p) != NULL) {
+ Tcl_AppendToObj(pathPrefix, p, 1);
+ } else {
+ break;
+ }
+ p++;
}
- prefixLen++;
+ tail = p;
+ Tcl_IncrRefCount(pathPrefix);
+ }
+ /*
+ * ':' no longer needed as a separator. It is only relevant
+ * to the beginning of the path.
+ */
+ separators = "/\\";
+ } else if (tclPlatform == TCL_PLATFORM_UNIX) {
+ if (pathPrefix == NULL && tail[0] == '/') {
+ pathPrefix = Tcl_NewStringObj(tail, 1);
+ tail++;
+ Tcl_IncrRefCount(pathPrefix);
}
}
-
+
/*
* We need to get the old result, in case it is over-written
* below when we still need it.
@@ -2116,8 +2176,18 @@ TclGlob(interp, pattern, unquotedPrefix, globFlags, types)
oldResult = Tcl_GetObjResult(interp);
Tcl_IncrRefCount(oldResult);
Tcl_ResetResult(interp);
-
- result = TclDoGlob(interp, separators, &buffer, tail, types);
+
+ if (*tail == '\0' && pathPrefix != NULL) {
+ /*
+ * An empty pattern
+ */
+ result = Tcl_FSMatchInDirectory(interp, Tcl_GetObjResult(interp),
+ pathPrefix, NULL, types);
+
+ } else {
+ result = DoGlob(interp, separators, pathPrefix,
+ globFlags & TCL_GLOBMODE_DIR, tail, types);
+ }
if (result != TCL_OK) {
if (globFlags & TCL_GLOBMODE_NO_COMPLAIN) {
@@ -2132,37 +2202,49 @@ TclGlob(interp, pattern, unquotedPrefix, globFlags, types)
*
* If we only want the tails, we must strip off the prefix now.
* It may seem more efficient to pass the tails flag down into
- * TclDoGlob, Tcl_FSMatchInDirectory, but those functions are
+ * DoGlob, Tcl_FSMatchInDirectory, but those functions are
* continually adjusting the prefix as the various pieces of
* the pattern are assimilated, so that would add a lot of
* complexity to the code. This way is a little slower (when
* the -tails flag is given), but much simpler to code.
*/
- int objc, i;
- Tcl_Obj **objv;
- /* Ensure sole ownership */
+ /*
+ * Ensure sole ownership. We also assume that oldResult
+ * is a valid list in the code below.
+ */
if (Tcl_IsShared(oldResult)) {
Tcl_DecrRefCount(oldResult);
oldResult = Tcl_DuplicateObj(oldResult);
Tcl_IncrRefCount(oldResult);
}
- Tcl_ListObjGetElements(NULL, Tcl_GetObjResult(interp),
- &objc, &objv);
-#ifdef MAC_TCL
- /* adjust prefixLen if TclDoGlob prepended a ':' */
- if ((prefixLen > 0) && (objc > 0)
- && (Tcl_DStringValue(&buffer)[0] != ':')) {
- char *str = Tcl_GetStringFromObj(objv[0],NULL);
- if (str[0] == ':') {
+ if (globFlags & TCL_GLOBMODE_TAILS) {
+ int objc, i;
+ Tcl_Obj **objv;
+ int prefixLen;
+
+ /* If this length has never been set, set it here */
+ CONST char *pre = Tcl_GetStringFromObj(pathPrefix, &prefixLen);
+ if (prefixLen > 0) {
+ if (strchr(separators, pre[prefixLen-1]) == NULL) {
prefixLen++;
+ }
}
- }
-#endif
- for (i = 0; i< objc; i++) {
- Tcl_Obj* elt;
- if (globFlags & TCL_GLOBMODE_TAILS) {
+
+ Tcl_ListObjGetElements(NULL, Tcl_GetObjResult(interp),
+ &objc, &objv);
+ #ifdef MAC_TCL
+ /* adjust prefixLen if DoGlob prepended a ':' */
+ if ((prefixLen > 0) && (objc > 0) && (pre[0] != ':')) {
+ CONST char *str = Tcl_GetStringFromObj(objv[0],NULL);
+ if (str[0] == ':') {
+ prefixLen++;
+ }
+ }
+ #endif
+ for (i = 0; i< objc; i++) {
+ Tcl_Obj* elt;
int len;
char *oldStr = Tcl_GetStringFromObj(objv[i],&len);
if (len == prefixLen) {
@@ -2176,11 +2258,10 @@ TclGlob(interp, pattern, unquotedPrefix, globFlags, types)
elt = Tcl_NewStringObj(oldStr + prefixLen,
len - prefixLen);
}
- } else {
- elt = objv[i];
+ Tcl_ListObjAppendElement(interp, oldResult, elt);
}
- /* Assumption that 'oldResult' is a valid list */
- Tcl_ListObjAppendElement(interp, oldResult, elt);
+ } else {
+ Tcl_ListObjAppendList(interp, oldResult, Tcl_GetObjResult(interp));
}
Tcl_SetObjResult(interp, oldResult);
}
@@ -2189,7 +2270,6 @@ TclGlob(interp, pattern, unquotedPrefix, globFlags, types)
* end here so we free our reference.
*/
Tcl_DecrRefCount(oldResult);
- Tcl_DStringFree(&buffer);
return result;
}
@@ -2215,11 +2295,11 @@ TclGlob(interp, pattern, unquotedPrefix, globFlags, types)
static int
SkipToChar(stringPtr, match)
- char **stringPtr; /* Pointer string to check. */
- char *match; /* Pointer to character to find. */
+ CONST char **stringPtr; /* Pointer string to check. */
+ char match; /* Pointer to character to find. */
{
int quoted, level;
- register char *p;
+ register CONST char *p;
quoted = 0;
level = 0;
@@ -2229,7 +2309,7 @@ SkipToChar(stringPtr, match)
quoted = 0;
continue;
}
- if ((level == 0) && (*p == *match)) {
+ if ((level == 0) && (*p == match)) {
*stringPtr = p;
return 1;
}
@@ -2248,22 +2328,20 @@ SkipToChar(stringPtr, match)
/*
*----------------------------------------------------------------------
*
- * TclDoGlob --
- *
- * This recursive procedure forms the heart of the globbing
- * code. It performs a depth-first traversal of the tree
- * given by the path name to be globbed. The directory and
- * remainder are assumed to be native format paths. The prefix
- * contained in 'headPtr' is not used as a glob pattern, simply
- * as a path specifier, so it can contain unquoted glob-sensitive
- * characters (if the directories to which it points contain
- * such strange characters).
+ * DoGlob --
*
+ * This recursive procedure forms the heart of the globbing code.
+ * It performs a depth-first traversal of the tree given by the
+ * path name to be globbed and the pattern. The directory and
+ * remainder are assumed to be native format paths. The prefix
+ * contained in 'pathPtr' is either a directory or path from which
+ * to start the search (or NULL).
+ *
* Results:
* The return value is a standard Tcl result indicating whether
* an error occurred in globbing. After a normal return the
* result in interp will be set to hold all of the file names
- * given by the dir and rem arguments. After an error the
+ * given by the dir and remaining arguments. After an error the
* result in interp will hold an error message.
*
* Side effects:
@@ -2272,128 +2350,142 @@ SkipToChar(stringPtr, match)
*----------------------------------------------------------------------
*/
-int
-TclDoGlob(interp, separators, headPtr, tail, types)
+static int
+DoGlob(interp, separators, pathPtr, flags, pattern, types)
Tcl_Interp *interp; /* Interpreter to use for error reporting
* (e.g. unmatched brace). */
char *separators; /* String containing separator characters
* that should be used to identify globbing
* boundaries. */
- Tcl_DString *headPtr; /* Completely expanded prefix. */
- char *tail; /* The unexpanded remainder of the path.
+ Tcl_Obj *pathPtr; /* Completely expanded prefix. */
+ int flags; /* If non-zero then pathPtr is a
+ * directory */
+ char *pattern; /* The pattern to match against.
* Must not be a pointer to a static string. */
Tcl_GlobTypeData *types; /* List object containing list of acceptable
- * types. May be NULL. */
+ * types. May be NULL. */
{
int baseLength, quoted, count;
int result = TCL_OK;
- char *name, *p, *openBrace, *closeBrace, *firstSpecialChar, savedChar;
- char lastChar = 0;
-
- int length = Tcl_DStringLength(headPtr);
-
- if (length > 0) {
- lastChar = Tcl_DStringValue(headPtr)[length-1];
- }
+ char *name, *p, *openBrace, *closeBrace, *firstSpecialChar;
/*
- * Consume any leading directory separators, leaving tail pointing
+ * Consume any leading directory separators, leaving pattern pointing
* just past the last initial separator.
*/
count = 0;
- name = tail;
- for (; *tail != '\0'; tail++) {
- if (*tail == '\\') {
+ name = pattern;
+ for (; *pattern != '\0'; pattern++) {
+ if (*pattern == '\\') {
/*
* If the first character is escaped, either we have a directory
* separator, or we have any other character. In the latter case
- * the rest of tail is a pattern, and we must break from the loop.
+ * the rest is a pattern, and we must break from the loop.
* This is particularly important on Windows where '\' is both
* the escaping character and a directory separator.
*/
- if (strchr(separators, tail[1]) != NULL) {
- tail++;
+ if (strchr(separators, pattern[1]) != NULL) {
+ pattern++;
} else {
break;
}
- } else if (strchr(separators, *tail) == NULL) {
+ } else if (strchr(separators, *pattern) == NULL) {
break;
}
count++;
}
+ /*
+ * This block of code is not exercised by the Tcl test suite as of
+ * Tcl 8.5a0. Simplifications to the calling paths suggest it may
+ * not be necessary any more, since path separators are handled
+ * elsewhere. It is left in place in case new bugs are reported
+ * (particularly on MacOS)
+ */
+
+#if 0
/*
* Deal with path separators. On the Mac, we have to watch out
* for multiple separators, since they are special in Mac-style
* paths.
*/
+ if (pathPtr == NULL) {
+ /*
+ * Length used to be the length of the prefix, and lastChar
+ * the lastChar of the prefix. But, none of this is used
+ * any more.
+ */
+ int length = 0;
+ char lastChar = 0;
- switch (tclPlatform) {
- case TCL_PLATFORM_MAC:
-#ifdef MAC_UNDERSTANDS_UNIX_PATHS
- if (*separators == '/') {
- if (((length == 0) && (count == 0))
- || ((length > 0) && (lastChar != ':'))) {
- Tcl_DStringAppend(headPtr, ":", 1);
- }
- } else {
-#endif
- if (count == 0) {
- if ((length > 0) && (lastChar != ':')) {
- Tcl_DStringAppend(headPtr, ":", 1);
+ switch (tclPlatform) {
+ case TCL_PLATFORM_MAC:
+ #ifdef MAC_UNDERSTANDS_UNIX_PATHS
+ if (*separators == '/') {
+ if (((length == 0) && (count == 0))
+ || ((length > 0) && (lastChar != ':'))) {
+ Tcl_DStringAppend(&append, ":", 1);
}
} else {
- if (lastChar == ':') {
- count--;
- }
- while (count-- > 0) {
- Tcl_DStringAppend(headPtr, ":", 1);
+ #endif
+ if (count == 0) {
+ if ((length > 0) && (lastChar != ':')) {
+ Tcl_DStringAppend(&append, ":", 1);
+ }
+ } else {
+ if (lastChar == ':') {
+ count--;
+ }
+ while (count-- > 0) {
+ Tcl_DStringAppend(&append, ":", 1);
+ }
}
+ #ifdef MAC_UNDERSTANDS_UNIX_PATHS
}
-#ifdef MAC_UNDERSTANDS_UNIX_PATHS
- }
-#endif
- break;
- case TCL_PLATFORM_WINDOWS:
- /*
- * If this is a drive relative path, add the colon and the
- * trailing slash if needed. Otherwise add the slash if
- * this is the first absolute element, or a later relative
- * element. Add an extra slash if this is a UNC path.
- */
+ #endif
+ break;
+ case TCL_PLATFORM_WINDOWS:
+ /*
+ * If this is a drive relative path, add the colon and the
+ * trailing slash if needed. Otherwise add the slash if
+ * this is the first absolute element, or a later relative
+ * element. Add an extra slash if this is a UNC path.
+ */
- if (*name == ':') {
- Tcl_DStringAppend(headPtr, ":", 1);
- if (count > 1) {
- Tcl_DStringAppend(headPtr, "/", 1);
- }
- } else if ((*tail != '\0')
- && (((length > 0)
- && (strchr(separators, lastChar) == NULL))
- || ((length == 0) && (count > 0)))) {
- Tcl_DStringAppend(headPtr, "/", 1);
- if ((length == 0) && (count > 1)) {
- Tcl_DStringAppend(headPtr, "/", 1);
+ if (*name == ':') {
+ Tcl_DStringAppend(&append, ":", 1);
+ if (count > 1) {
+ Tcl_DStringAppend(&append, "/", 1);
+ }
+ } else if ((*pattern != '\0')
+ && (((length > 0)
+ && (strchr(separators, lastChar) == NULL))
+ || ((length == 0) && (count > 0)))) {
+ Tcl_DStringAppend(&append, "/", 1);
+ if ((length == 0) && (count > 1)) {
+ Tcl_DStringAppend(&append, "/", 1);
+ }
}
- }
-
- break;
- case TCL_PLATFORM_UNIX:
- /*
- * Add a separator if this is the first absolute element, or
- * a later relative element.
- */
+
+ break;
+ case TCL_PLATFORM_UNIX:
+ /*
+ * Add a separator if this is the first absolute element, or
+ * a later relative element.
+ */
- if ((*tail != '\0')
- && (((length > 0)
- && (strchr(separators, lastChar) == NULL))
- || ((length == 0) && (count > 0)))) {
- Tcl_DStringAppend(headPtr, "/", 1);
- }
- break;
+ if ((*pattern != '\0')
+ && (((length > 0)
+ && (strchr(separators, lastChar) == NULL))
+ || ((length == 0) && (count > 0)))) {
+ Tcl_DStringAppend(&append, "/", 1);
+ }
+ break;
+ }
}
-
+#endif
+
/*
* Look for the first matching pair of braces or the first
* directory separator that is not inside a pair of braces.
@@ -2401,21 +2493,24 @@ TclDoGlob(interp, separators, headPtr, tail, types)
openBrace = closeBrace = NULL;
quoted = 0;
- for (p = tail; *p != '\0'; p++) {
+ for (p = pattern; *p != '\0'; p++) {
if (quoted) {
quoted = 0;
} else if (*p == '\\') {
quoted = 1;
if (strchr(separators, p[1]) != NULL) {
- break; /* Quoted directory separator. */
+ /* Quoted directory separator. */
+ break;
}
} else if (strchr(separators, *p) != NULL) {
- break; /* Unquoted directory separator. */
+ /* Unquoted directory separator. */
+ break;
} else if (*p == '{') {
openBrace = p;
p++;
- if (SkipToChar(&p, "}")) {
- closeBrace = p; /* Balanced braces. */
+ if (SkipToChar(&p, '}')) {
+ /* Balanced braces. */
+ closeBrace = p;
break;
}
Tcl_SetResult(interp, "unmatched open-brace in file name",
@@ -2434,6 +2529,7 @@ TclDoGlob(interp, separators, headPtr, tail, types)
if (openBrace != NULL) {
char *element;
+
Tcl_DString newName;
Tcl_DStringInit(&newName);
@@ -2443,20 +2539,18 @@ TclDoGlob(interp, separators, headPtr, tail, types)
* before the first brace and recursively call TclDoGlob.
*/
- Tcl_DStringAppend(&newName, tail, openBrace-tail);
+ Tcl_DStringAppend(&newName, pattern, openBrace-pattern);
baseLength = Tcl_DStringLength(&newName);
- length = Tcl_DStringLength(headPtr);
*closeBrace = '\0';
for (p = openBrace; p != closeBrace; ) {
p++;
element = p;
- SkipToChar(&p, ",");
- Tcl_DStringSetLength(headPtr, length);
+ SkipToChar(&p, ',');
Tcl_DStringSetLength(&newName, baseLength);
Tcl_DStringAppend(&newName, element, p-element);
Tcl_DStringAppend(&newName, closeBrace+1, -1);
- result = TclDoGlob(interp, separators, headPtr,
- Tcl_DStringValue(&newName), types);
+ result = DoGlob(interp, separators, pathPtr, flags,
+ Tcl_DStringValue(&newName), types);
if (result != TCL_OK) {
break;
}
@@ -2471,7 +2565,17 @@ TclDoGlob(interp, separators, headPtr, tail, types)
* this path component. The variable p is pointing at a quoted or
* unquoted directory separator or the end of the string. So we need
* to check for special globbing characters in the current pattern.
- * We avoid modifying tail if p is pointing at the end of the string.
+ * We avoid modifying pattern if p is pointing at the end of the string.
+ *
+ * If we find any globbing characters, then we must call
+ * Tcl_FSMatchInDirectory. If we're at the end of the string, then
+ * that's all we need to do. If we're not at the end of the
+ * string, then we must recurse, so we do that below.
+ *
+ * Alternatively, if there are no globbing characters then again
+ * there are two cases. If we're at the end of the string, we just
+ * need to check for the given path's existence and type. If we're
+ * not at the end of the string, we recurse.
*/
if (*p != '\0') {
@@ -2481,27 +2585,26 @@ TclDoGlob(interp, separators, headPtr, tail, types)
* if the string is a static.
*/
- savedChar = *p;
+ char savedChar = *p;
*p = '\0';
- firstSpecialChar = strpbrk(tail, "*[]?\\");
+ firstSpecialChar = strpbrk(pattern, "*[]?\\");
*p = savedChar;
} else {
- firstSpecialChar = strpbrk(tail, "*[]?\\");
+ firstSpecialChar = strpbrk(pattern, "*[]?\\");
}
if (firstSpecialChar != NULL) {
int ret;
- Tcl_Obj *head = Tcl_NewStringObj(Tcl_DStringValue(headPtr),-1);
- Tcl_IncrRefCount(head);
+
/*
* Look for matching files in the given directory. The
- * implementation of this function is platform specific. For
+ * implementation of this function is filesystem specific. For
* each file that matches, it will add the match onto the
* resultPtr given.
*/
if (*p == '\0') {
ret = Tcl_FSMatchInDirectory(interp, Tcl_GetObjResult(interp),
- head, tail, types);
+ pathPtr, pattern, types);
} else {
Tcl_Obj* resultPtr;
@@ -2515,7 +2618,7 @@ TclDoGlob(interp, separators, headPtr, tail, types)
*p = '\0';
resultPtr = Tcl_NewListObj(0, NULL);
ret = Tcl_FSMatchInDirectory(interp, resultPtr,
- head, tail, &dirOnly);
+ pathPtr, pattern, &dirOnly);
*p = save;
if (ret == TCL_OK) {
int resLength;
@@ -2524,17 +2627,9 @@ TclDoGlob(interp, separators, headPtr, tail, types)
int i;
for (i =0; i< resLength; i++) {
Tcl_Obj *elt;
- Tcl_DString ds;
+
Tcl_ListObjIndex(interp, resultPtr, i, &elt);
- Tcl_DStringInit(&ds);
- Tcl_DStringAppend(&ds, Tcl_GetString(elt), -1);
- if(tclPlatform == TCL_PLATFORM_MAC) {
- Tcl_DStringAppend(&ds, ":",1);
- } else {
- Tcl_DStringAppend(&ds, "/",1);
- }
- ret = TclDoGlob(interp, separators, &ds, p+1, types);
- Tcl_DStringFree(&ds);
+ ret = DoGlob(interp, separators, elt, 1, p+1, types);
if (ret != TCL_OK) {
break;
}
@@ -2543,154 +2638,121 @@ TclDoGlob(interp, separators, headPtr, tail, types)
}
Tcl_DecrRefCount(resultPtr);
}
- Tcl_DecrRefCount(head);
return ret;
- }
- Tcl_DStringAppend(headPtr, tail, p-tail);
- if (*p != '\0') {
- return TclDoGlob(interp, separators, headPtr, p, types);
} else {
- /*
- * This is the code path reached by a command like 'glob foo'.
- *
- * There are no more wildcards in the pattern and no more
- * unprocessed characters in the tail, so now we can construct
- * the path, and pass it to Tcl_FSMatchInDirectory with an
- * empty pattern to verify the existence of the file and check
- * it is of the correct type (if a 'types' flag it given -- if
- * no such flag was given, we could just use 'Tcl_FSLStat', but
- * for simplicity we keep to a common approach).
+ /*
+ * We reach here with no pattern char in current section
*/
+
+ if (*p != '\0') {
+ Tcl_Obj *joined;
+ int ret;
+
+ /*
+ * If it's not the end of the string, we must recurse
+ */
+ if (pathPtr != NULL) {
+ if (flags) {
+ joined = TclNewFSPathObj(pathPtr, pattern, p-pattern);
+ } else {
+ joined = Tcl_DuplicateObj(pathPtr);
+ Tcl_AppendToObj(joined, pattern, p-pattern);
+ }
+ } else {
+ joined = Tcl_NewStringObj(pattern, p-pattern);
+ }
+ Tcl_IncrRefCount(joined);
+ ret = DoGlob(interp, separators, joined, 1, p, types);
+ Tcl_DecrRefCount(joined);
+ return ret;
+ } else {
+ /*
+ * This is the code path reached by a command like 'glob foo'.
+ *
+ * There are no more wildcards in the pattern and no more
+ * unprocessed characters in the pattern, so now we can construct
+ * the path, and pass it to Tcl_FSMatchInDirectory with an
+ * empty pattern to verify the existence of the file and check
+ * it is of the correct type (if a 'types' flag it given -- if
+ * no such flag was given, we could just use 'Tcl_FSLStat', but
+ * for simplicity we keep to a common approach).
+ */
- Tcl_Obj *nameObj;
+ Tcl_Obj *joined;
+ int length;
+ Tcl_DString append;
+
+ Tcl_DStringInit(&append);
+ Tcl_DStringAppend(&append, pattern, p-pattern);
- switch (tclPlatform) {
- case TCL_PLATFORM_MAC: {
- if (strchr(Tcl_DStringValue(headPtr), ':') == NULL) {
- Tcl_DStringAppend(headPtr, ":", 1);
- }
- break;
+ if (pathPtr != NULL) {
+ Tcl_GetStringFromObj(pathPtr, &length);
+ } else {
+ length = 0;
}
- case TCL_PLATFORM_WINDOWS: {
- if (Tcl_DStringLength(headPtr) == 0) {
- if (((*name == '\\') && (name[1] == '/' || name[1] == '\\'))
- || (*name == '/')) {
- Tcl_DStringAppend(headPtr, "/", 1);
- } else {
- Tcl_DStringAppend(headPtr, ".", 1);
+
+ switch (tclPlatform) {
+ case TCL_PLATFORM_MAC: {
+ if (strchr(Tcl_DStringValue(&append), ':') == NULL) {
+ Tcl_DStringAppend(&append, ":", 1);
}
+ break;
}
-#if defined(__CYGWIN__) && defined(__WIN32__)
- {
- extern int cygwin_conv_to_win32_path
- _ANSI_ARGS_((CONST char *, char *));
- char winbuf[MAX_PATH+1];
-
- cygwin_conv_to_win32_path(Tcl_DStringValue(headPtr), winbuf);
- Tcl_DStringFree(headPtr);
- Tcl_DStringAppend(headPtr, winbuf, -1);
+ case TCL_PLATFORM_WINDOWS: {
+ if (length == 0 && (Tcl_DStringLength(&append) == 0)) {
+ if (((*name == '\\') && (name[1] == '/' || name[1] == '\\'))
+ || (*name == '/')) {
+ Tcl_DStringAppend(&append, "/", 1);
+ } else {
+ Tcl_DStringAppend(&append, ".", 1);
+ }
+ }
+ #if defined(__CYGWIN__) && defined(__WIN32__)
+ {
+ extern int cygwin_conv_to_win32_path
+ _ANSI_ARGS_((CONST char *, char *));
+ char winbuf[MAX_PATH+1];
+
+ cygwin_conv_to_win32_path(Tcl_DStringValue(&append), winbuf);
+ Tcl_DStringFree(&append);
+ Tcl_DStringAppend(&append, winbuf, -1);
+ }
+ #endif /* __CYGWIN__ && __WIN32__ */
+ break;
}
-#endif /* __CYGWIN__ && __WIN32__ */
- /*
- * Convert to forward slashes. This is required to pass
- * some Tcl tests. We should probably remove the conversions
- * here and in tclWinFile.c, since they aren't needed since
- * the dropping of support for Win32s.
- */
- for (p = Tcl_DStringValue(headPtr); *p != '\0'; p++) {
- if (*p == '\\') {
- *p = '/';
+ case TCL_PLATFORM_UNIX: {
+ if (length == 0 && (Tcl_DStringLength(&append) == 0)) {
+ if ((*name == '\\' && name[1] == '/') || (*name == '/')) {
+ Tcl_DStringAppend(&append, "/", 1);
+ } else {
+ Tcl_DStringAppend(&append, ".", 1);
+ }
}
+ break;
}
- break;
}
- case TCL_PLATFORM_UNIX: {
- if (Tcl_DStringLength(headPtr) == 0) {
- if ((*name == '\\' && name[1] == '/') || (*name == '/')) {
- Tcl_DStringAppend(headPtr, "/", 1);
- } else {
- Tcl_DStringAppend(headPtr, ".", 1);
- }
+ /* Common for all platforms */
+ if (pathPtr != NULL) {
+ if (flags) {
+ joined = TclNewFSPathObj(pathPtr, Tcl_DStringValue(&append),
+ Tcl_DStringLength(&append));
+ } else {
+ joined = Tcl_DuplicateObj(pathPtr);
+ Tcl_AppendToObj(joined, Tcl_DStringValue(&append),
+ Tcl_DStringLength(&append));
}
- break;
+ } else {
+ joined = Tcl_NewStringObj(Tcl_DStringValue(&append),
+ Tcl_DStringLength(&append));
}
+ Tcl_IncrRefCount(joined);
+ Tcl_DStringFree(&append);
+ Tcl_FSMatchInDirectory(interp, Tcl_GetObjResult(interp), joined,
+ NULL, types);
+ Tcl_DecrRefCount(joined);
+ return TCL_OK;
}
- /* Common for all platforms */
- name = Tcl_DStringValue(headPtr);
- nameObj = Tcl_NewStringObj(name, Tcl_DStringLength(headPtr));
-
- Tcl_IncrRefCount(nameObj);
- Tcl_FSMatchInDirectory(interp, Tcl_GetObjResult(interp), nameObj,
- NULL, types);
- Tcl_DecrRefCount(nameObj);
- return TCL_OK;
- }
-}
-
-
-/*
- *---------------------------------------------------------------------------
- *
- * TclFileDirname
- *
- * This procedure calculates the directory above a given
- * path: basically 'file dirname'. It is used both by
- * the 'dirname' subcommand of file and by code in tclIOUtil.c.
- *
- * Results:
- * NULL if an error occurred, otherwise a Tcl_Obj owned by
- * the caller (i.e. most likely with refCount 1).
- *
- * Side effects:
- * None.
- *
- *---------------------------------------------------------------------------
- */
-
-Tcl_Obj*
-TclFileDirname(interp, pathPtr)
- Tcl_Interp *interp; /* Used for error reporting */
- Tcl_Obj *pathPtr; /* Path to take dirname of */
-{
- int splitElements;
- Tcl_Obj *splitPtr;
- Tcl_Obj *splitResultPtr = NULL;
-
- /*
- * The behaviour we want here is slightly different to
- * the standard Tcl_FSSplitPath in the handling of home
- * directories; Tcl_FSSplitPath preserves the "~" while
- * this code computes the actual full path name, if we
- * had just a single component.
- */
- splitPtr = Tcl_FSSplitPath(pathPtr, &splitElements);
- if ((splitElements == 1) && (Tcl_GetString(pathPtr)[0] == '~')) {
- Tcl_DecrRefCount(splitPtr);
- splitPtr = Tcl_FSGetNormalizedPath(interp, pathPtr);
- if (splitPtr == NULL) {
- return NULL;
- }
- splitPtr = Tcl_FSSplitPath(splitPtr, &splitElements);
- }
-
- /*
- * Return all but the last component. If there is only one
- * component, return it if the path was non-relative, otherwise
- * return the current directory.
- */
-
- if (splitElements > 1) {
- splitResultPtr = Tcl_FSJoinPath(splitPtr, splitElements - 1);
- } else if (splitElements == 0 ||
- (Tcl_FSGetPathType(pathPtr) == TCL_PATH_RELATIVE)) {
- splitResultPtr = Tcl_NewStringObj(
- ((tclPlatform == TCL_PLATFORM_MAC) ? ":" : "."), 1);
- } else {
- Tcl_ListObjIndex(NULL, splitPtr, 0, &splitResultPtr);
}
- Tcl_IncrRefCount(splitResultPtr);
- Tcl_DecrRefCount(splitPtr);
- return splitResultPtr;
}
/*
diff --git a/generic/tclFileSystem.h b/generic/tclFileSystem.h
index e7e9421..8d0ab34 100644
--- a/generic/tclFileSystem.h
+++ b/generic/tclFileSystem.h
@@ -9,7 +9,7 @@
* See the file "license.terms" for information on usage and redistribution
* of this file, and for a DISCLAIMER OF ALL WARRANTIES.
*
- * RCS: @(#) $Id: tclFileSystem.h,v 1.5 2003/10/10 15:50:35 dkf Exp $
+ * RCS: @(#) $Id: tclFileSystem.h,v 1.6 2004/01/21 19:59:33 vincentdarley Exp $
*/
/*
@@ -50,6 +50,7 @@ typedef struct ThreadSpecificData {
int cwdPathEpoch;
int filesystemEpoch;
Tcl_Obj *cwdPathPtr;
+ ClientData cwdClientData;
FilesystemRecord *filesystemList;
} ThreadSpecificData;
@@ -61,19 +62,19 @@ typedef struct ThreadSpecificData {
* These functions are not exported at all at present.
*/
-int TclFSCwdPointerEquals _ANSI_ARGS_((Tcl_Obj* objPtr));
+int TclFSCwdPointerEquals _ANSI_ARGS_((Tcl_Obj** pathPtrPtr));
int TclFSMakePathFromNormalized _ANSI_ARGS_((Tcl_Interp *interp,
- Tcl_Obj *objPtr, ClientData clientData));
+ Tcl_Obj *pathPtr, ClientData clientData));
int TclFSNormalizeToUniquePath _ANSI_ARGS_((Tcl_Interp *interp,
Tcl_Obj *pathPtr, int startAt, ClientData *clientDataPtr));
Tcl_Obj* TclFSMakePathRelative _ANSI_ARGS_((Tcl_Interp *interp,
- Tcl_Obj *objPtr, Tcl_Obj *cwdPtr));
+ Tcl_Obj *pathPtr, Tcl_Obj *cwdPtr));
Tcl_Obj* TclFSInternalToNormalized _ANSI_ARGS_((
Tcl_Filesystem *fromFilesystem, ClientData clientData,
FilesystemRecord **fsRecPtrPtr));
-int TclFSEnsureEpochOk _ANSI_ARGS_((Tcl_Obj* pathObjPtr,
+int TclFSEnsureEpochOk _ANSI_ARGS_((Tcl_Obj* pathPtr,
Tcl_Filesystem **fsPtrPtr));
-void TclFSSetPathDetails _ANSI_ARGS_((Tcl_Obj *pathObjPtr,
+void TclFSSetPathDetails _ANSI_ARGS_((Tcl_Obj *pathPtr,
FilesystemRecord *fsRecPtr, ClientData clientData ));
Tcl_Obj* TclFSNormalizeAbsolutePath _ANSI_ARGS_((Tcl_Interp* interp,
Tcl_Obj *pathPtr, ClientData *clientDataPtr));
@@ -87,10 +88,10 @@ extern Tcl_ThreadDataKey tclFsDataKey;
/*
* Private shared functions for use by tclIOUtil.c and tclPathObj.c
*/
-Tcl_PathType TclFSGetPathType _ANSI_ARGS_((Tcl_Obj *pathObjPtr,
+Tcl_PathType TclFSGetPathType _ANSI_ARGS_((Tcl_Obj *pathPtr,
Tcl_Filesystem **filesystemPtrPtr,
int *driveNameLengthPtr));
-Tcl_PathType TclGetPathType _ANSI_ARGS_((Tcl_Obj *pathObjPtr,
+Tcl_PathType TclGetPathType _ANSI_ARGS_((Tcl_Obj *pathPtr,
Tcl_Filesystem **filesystemPtrPtr,
int *driveNameLengthPtr, Tcl_Obj **driveNameRef));
Tcl_FSPathInFilesystemProc TclNativePathInFilesystem;
diff --git a/generic/tclIOUtil.c b/generic/tclIOUtil.c
index c47e07f..738f182 100644
--- a/generic/tclIOUtil.c
+++ b/generic/tclIOUtil.c
@@ -17,7 +17,7 @@
* See the file "license.terms" for information on usage and redistribution
* of this file, and for a DISCLAIMER OF ALL WARRANTIES.
*
- * RCS: @(#) $Id: tclIOUtil.c,v 1.92 2004/01/09 15:22:46 vincentdarley Exp $
+ * RCS: @(#) $Id: tclIOUtil.c,v 1.93 2004/01/21 19:59:33 vincentdarley Exp $
*/
#include "tclInt.h"
@@ -35,13 +35,16 @@
* Prototypes for procedures defined later in this file.
*/
-static FilesystemRecord* FsGetFirstFilesystem _ANSI_ARGS_((void));
-static void FsThrExitProc _ANSI_ARGS_((ClientData cd));
-static Tcl_Obj* FsListMounts _ANSI_ARGS_((Tcl_Obj *pathPtr,
- CONST char *pattern));
-static Tcl_Obj* FsAddMountsToGlobResult _ANSI_ARGS_((Tcl_Obj *result,
- Tcl_Obj *pathPtr, CONST char *pattern, Tcl_GlobTypeData *types));
-
+static FilesystemRecord* FsGetFirstFilesystem _ANSI_ARGS_((void));
+static void FsThrExitProc _ANSI_ARGS_((ClientData cd));
+static Tcl_Obj* FsListMounts _ANSI_ARGS_((Tcl_Obj *pathPtr,
+ CONST char *pattern));
+static Tcl_Obj* FsAddMountsToGlobResult _ANSI_ARGS_((Tcl_Obj *result,
+ Tcl_Obj *pathPtr, CONST char *pattern,
+ Tcl_GlobTypeData *types));
+static void FsUpdateCwd _ANSI_ARGS_((Tcl_Obj *cwdObj,
+ ClientData clientData));
+
#ifdef TCL_THREADS
static void FsRecacheFilesystemList(void);
#endif
@@ -297,7 +300,6 @@ TCL_DECLARE_MUTEX(obsoleteFsHookMutex)
*/
static Tcl_FSFilesystemSeparatorProc NativeFilesystemSeparator;
static Tcl_FSFreeInternalRepProc NativeFreeInternalRep;
-Tcl_FSDupInternalRepProc TclNativeDupInternalRep;
static Tcl_FSCreateInternalRepProc NativeCreateNativeRep;
static Tcl_FSFileAttrStringsProc NativeFileAttrStrings;
static Tcl_FSFileAttrsGetProc NativeFileAttrsGet;
@@ -318,7 +320,6 @@ Tcl_FSInternalToNormalizedProc TclpNativeToNormalized;
Tcl_FSStatProc TclpObjStat;
Tcl_FSAccessProc TclpObjAccess;
Tcl_FSMatchInDirectoryProc TclpMatchInDirectory;
-Tcl_FSGetCwdProc TclpObjGetCwd;
Tcl_FSChdirProc TclpObjChdir;
Tcl_FSLstatProc TclpObjLstat;
Tcl_FSCopyFileProc TclpObjCopyFile;
@@ -342,7 +343,7 @@ Tcl_FSListVolumesProc TclpObjListVolumes;
Tcl_Filesystem tclNativeFilesystem = {
"native",
sizeof(Tcl_Filesystem),
- TCL_FILESYSTEM_VERSION_1,
+ TCL_FILESYSTEM_VERSION_2,
&TclNativePathInFilesystem,
&TclNativeDupInternalRep,
&NativeFreeInternalRep,
@@ -373,7 +374,8 @@ Tcl_Filesystem tclNativeFilesystem = {
&TclpObjCopyDirectory,
&TclpObjLstat,
&TclpDlopen,
- &TclpObjGetCwd,
+ /* Needs a cast since we're using version_2 */
+ (Tcl_FSGetCwdProc*)&TclpGetNativeCwd,
&TclpObjChdir
};
@@ -415,6 +417,7 @@ TCL_DECLARE_MUTEX(filesystemMutex)
*/
static Tcl_Obj* cwdPathPtr = NULL;
static int cwdPathEpoch = 0;
+static ClientData cwdClientData = NULL;
TCL_DECLARE_MUTEX(cwdMutex)
Tcl_ThreadDataKey tclFsDataKey;
@@ -454,6 +457,9 @@ FsThrExitProc(cd)
if (tsdPtr->cwdPathPtr != NULL) {
Tcl_DecrRefCount(tsdPtr->cwdPathPtr);
}
+ if (tsdPtr->cwdClientData != NULL) {
+ NativeFreeInternalRep(tsdPtr->cwdClientData);
+ }
/* Trash the filesystems cache */
fsRecPtr = tsdPtr->filesystemList;
while (fsRecPtr != NULL) {
@@ -465,24 +471,53 @@ FsThrExitProc(cd)
}
}
+/*
+ *----------------------------------------------------------------------
+ *
+ * TclFSCwdPointerEquals --
+ *
+ * Check whether the current working directory is equal to the
+ * path given.
+ *
+ * Results:
+ * 1 (equal) or 0 (un-equal) as appropriate.
+ *
+ * Side effects:
+ * If the paths are equal, but are not the same object, this
+ * method will modify the given pathPtrPtr to refer to the same
+ * object. In this case the object pointed to by pathPtrPtr will
+ * have its refCount decremented, and it will be adjusted to
+ * point to the cwd (with a new refCount).
+ *
+ *----------------------------------------------------------------------
+ */
+
int
-TclFSCwdPointerEquals(objPtr)
- Tcl_Obj* objPtr;
+TclFSCwdPointerEquals(pathPtrPtr)
+ Tcl_Obj** pathPtrPtr;
{
ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&tclFsDataKey);
Tcl_MutexLock(&cwdMutex);
if (tsdPtr->cwdPathPtr == NULL
|| tsdPtr->cwdPathEpoch != cwdPathEpoch) {
- if (tsdPtr->cwdPathPtr) {
+ if (tsdPtr->cwdPathPtr != NULL) {
Tcl_DecrRefCount(tsdPtr->cwdPathPtr);
}
+ if (tsdPtr->cwdClientData != NULL) {
+ NativeFreeInternalRep(tsdPtr->cwdClientData);
+ }
if (cwdPathPtr == NULL) {
tsdPtr->cwdPathPtr = NULL;
} else {
tsdPtr->cwdPathPtr = Tcl_DuplicateObj(cwdPathPtr);
Tcl_IncrRefCount(tsdPtr->cwdPathPtr);
}
+ if (cwdClientData == NULL) {
+ tsdPtr->cwdClientData = NULL;
+ } else {
+ tsdPtr->cwdClientData = TclNativeDupInternalRep(cwdClientData);
+ }
tsdPtr->cwdPathEpoch = cwdPathEpoch;
}
Tcl_MutexUnlock(&cwdMutex);
@@ -492,7 +527,30 @@ TclFSCwdPointerEquals(objPtr)
tsdPtr->initialized = 1;
}
- return (tsdPtr->cwdPathPtr == objPtr);
+ if (pathPtrPtr == NULL) {
+ return (tsdPtr->cwdPathPtr == NULL);
+ }
+
+ if (tsdPtr->cwdPathPtr == *pathPtrPtr) {
+ return 1;
+ } else {
+ int len1, len2;
+ CONST char *str1, *str2;
+ str1 = Tcl_GetStringFromObj(tsdPtr->cwdPathPtr, &len1);
+ str2 = Tcl_GetStringFromObj(*pathPtrPtr, &len2);
+ if (len1 == len2 && !strcmp(str1,str2)) {
+ /*
+ * They are equal, but different objects. Update so they
+ * will be the same object in the future.
+ */
+ Tcl_DecrRefCount(*pathPtrPtr);
+ *pathPtrPtr = tsdPtr->cwdPathPtr;
+ Tcl_IncrRefCount(*pathPtrPtr);
+ return 1;
+ } else {
+ return 0;
+ }
+ }
}
#ifdef TCL_THREADS
@@ -568,9 +626,13 @@ FsGetFirstFilesystem(void) {
return fsRecPtr;
}
+/*
+ * If non-NULL, clientData is owned by us and must be freed later.
+ */
static void
-FsUpdateCwd(cwdObj)
+FsUpdateCwd(cwdObj, clientData)
Tcl_Obj *cwdObj;
+ ClientData clientData;
{
int len;
char *str = NULL;
@@ -584,12 +646,17 @@ FsUpdateCwd(cwdObj)
if (cwdPathPtr != NULL) {
Tcl_DecrRefCount(cwdPathPtr);
}
+ if (cwdClientData != NULL) {
+ NativeFreeInternalRep(cwdClientData);
+ }
if (cwdObj == NULL) {
cwdPathPtr = NULL;
+ cwdClientData = NULL;
} else {
/* This must be stored as string obj! */
cwdPathPtr = Tcl_NewStringObj(str, len);
Tcl_IncrRefCount(cwdPathPtr);
+ cwdClientData = TclNativeDupInternalRep(clientData);
}
cwdPathEpoch++;
tsdPtr->cwdPathEpoch = cwdPathEpoch;
@@ -598,10 +665,15 @@ FsUpdateCwd(cwdObj)
if (tsdPtr->cwdPathPtr) {
Tcl_DecrRefCount(tsdPtr->cwdPathPtr);
}
+ if (tsdPtr->cwdClientData) {
+ NativeFreeInternalRep(tsdPtr->cwdClientData);
+ }
if (cwdObj == NULL) {
tsdPtr->cwdPathPtr = NULL;
+ tsdPtr->cwdClientData = NULL;
} else {
tsdPtr->cwdPathPtr = Tcl_NewStringObj(str, len);
+ tsdPtr->cwdClientData = clientData;
Tcl_IncrRefCount(tsdPtr->cwdPathPtr);
}
}
@@ -641,6 +713,10 @@ TclFinalizeFilesystem()
cwdPathPtr = NULL;
cwdPathEpoch = 0;
}
+ if (cwdClientData != NULL) {
+ NativeFreeInternalRep(cwdClientData);
+ cwdClientData = NULL;
+ }
/*
* Remove all filesystems, freeing any allocated memory
@@ -922,7 +998,13 @@ Tcl_FSMatchInDirectory(interp, result, pathPtr, pattern, types)
* May be NULL. In particular the directory
* flag is very important. */
{
- Tcl_Filesystem *fsPtr = Tcl_FSGetFileSystemForPath(pathPtr);
+ Tcl_Filesystem *fsPtr;
+ if (pathPtr != NULL) {
+ fsPtr = Tcl_FSGetFileSystemForPath(pathPtr);
+ } else {
+ fsPtr = NULL;
+ }
+
if (fsPtr != NULL) {
Tcl_FSMatchInDirectoryProc *proc = fsPtr->matchInDirectoryProc;
if (proc != NULL) {
@@ -1024,10 +1106,12 @@ Tcl_FSMatchInDirectory(interp, result, pathPtr, pattern, types)
*/
static Tcl_Obj*
FsAddMountsToGlobResult(result, pathPtr, pattern, types)
- Tcl_Obj *result; /* The current list of matching paths */
- Tcl_Obj *pathPtr; /* The directory in question */
- CONST char *pattern;
- Tcl_GlobTypeData *types;
+ Tcl_Obj *result; /* The current list of matching paths */
+ Tcl_Obj *pathPtr; /* The directory in question */
+ CONST char *pattern; /* Pattern to match against. */
+ Tcl_GlobTypeData *types; /* Object containing list of acceptable types.
+ * May be NULL. In particular the directory
+ * flag is very important. */
{
int mLength, gLength, i;
int dir = (types == NULL || (types->type & TCL_GLOB_TYPE_DIR));
@@ -1234,10 +1318,13 @@ Tcl_FSData(fsPtr)
*/
int
TclFSNormalizeToUniquePath(interp, pathPtr, startAt, clientDataPtr)
- Tcl_Interp *interp;
- Tcl_Obj *pathPtr;
- int startAt;
- ClientData *clientDataPtr;
+ Tcl_Interp *interp; /* Used for error messages. */
+ Tcl_Obj *pathPtr; /* The path to normalize in place */
+ int startAt; /* Start at this char-offset */
+ ClientData *clientDataPtr; /* If we generated a complete
+ * normalized path for a given
+ * filesystem, we can optionally return
+ * an fs-specific clientdata here. */
{
FilesystemRecord *fsRecPtr, *firstFsRecPtr;
/* Ignore this variable */
@@ -1497,7 +1584,8 @@ Tcl_FSEvalFileEx(interp, pathPtr, encodingName)
Tcl_Interp *interp; /* Interpreter in which to process file. */
Tcl_Obj *pathPtr; /* Path of file to process. Tilde-substitution
* will be performed on this name. */
- CONST char *encodingName;
+ CONST char *encodingName; /* If non-NULL, then use this encoding
+ * for the file. */
{
int result, length;
Tcl_StatBuf statBuf;
@@ -1540,7 +1628,7 @@ Tcl_FSEvalFileEx(interp, pathPtr, encodingName)
* Else don't touch it (and use the system encoding)
* Report error on unknown encoding.
*/
- if (encodingName) {
+ if (encodingName != NULL) {
if (Tcl_SetChannelOption(interp, chan, "-encoding", encodingName)
!= TCL_OK) {
Tcl_Close(interp,chan);
@@ -2307,7 +2395,48 @@ Tcl_FSGetCwd(interp)
while ((retVal == NULL) && (fsRecPtr != NULL)) {
Tcl_FSGetCwdProc *proc = fsRecPtr->fsPtr->getCwdProc;
if (proc != NULL) {
- retVal = (*proc)(interp);
+ if (fsRecPtr->fsPtr->version != TCL_FILESYSTEM_VERSION_1) {
+ ClientData retCd;
+ TclFSGetCwdProc2 *proc2 = (TclFSGetCwdProc2*)proc;
+
+ retCd = (*proc2)(NULL);
+ if (retCd != NULL) {
+ Tcl_Obj *norm;
+ /* Looks like a new current directory */
+ retVal = (*fsRecPtr->fsPtr->internalToNormalizedProc)(retCd);
+ Tcl_IncrRefCount(retVal);
+ norm = TclFSNormalizeAbsolutePath(interp, retVal, NULL);
+ if (norm != NULL) {
+ /*
+ * We found a cwd, which is now in our global storage.
+ * We must make a copy. Norm already has a refCount of 1.
+ *
+ * Threading issue: note that multiple threads at system
+ * startup could in principle call this procedure
+ * simultaneously. They will therefore each set the
+ * cwdPathPtr independently. That behaviour is a bit
+ * peculiar, but should be fine. Once we have a cwd,
+ * we'll always be in the 'else' branch below which
+ * is simpler.
+ */
+ FsUpdateCwd(norm, retCd);
+ Tcl_DecrRefCount(norm);
+ } else {
+ (*fsRecPtr->fsPtr->freeInternalRepProc)(retCd);
+ }
+ Tcl_DecrRefCount(retVal);
+ retVal = NULL;
+ goto cdDidNotChange;
+ } else {
+ if (interp != NULL) {
+ Tcl_AppendResult(interp,
+ "error getting working directory name: ",
+ Tcl_PosixError(interp), (char *) NULL);
+ }
+ }
+ } else {
+ retVal = (*proc)(interp);
+ }
}
fsRecPtr = fsRecPtr->nextPtr;
}
@@ -2334,7 +2463,8 @@ Tcl_FSGetCwd(interp)
* we'll always be in the 'else' branch below which
* is simpler.
*/
- FsUpdateCwd(norm);
+ ClientData cd = (ClientData) Tcl_FSGetNativePath(norm);
+ FsUpdateCwd(norm, TclNativeDupInternalRep(cd));
Tcl_DecrRefCount(norm);
}
Tcl_DecrRefCount(retVal);
@@ -2359,10 +2489,32 @@ Tcl_FSGetCwd(interp)
*/
if (fsPtr != NULL) {
Tcl_FSGetCwdProc *proc = fsPtr->getCwdProc;
+ ClientData retCd = NULL;
if (proc != NULL) {
- Tcl_Obj *retVal = (*proc)(interp);
+ Tcl_Obj *retVal;
+ if (fsPtr->version != TCL_FILESYSTEM_VERSION_1) {
+ TclFSGetCwdProc2 *proc2 = (TclFSGetCwdProc2*)proc;
+
+ retCd = (*proc2)(tsdPtr->cwdClientData);
+ if (retCd == NULL && interp != NULL) {
+ Tcl_AppendResult(interp,
+ "error getting working directory name: ",
+ Tcl_PosixError(interp), (char *) NULL);
+ }
+
+ if (retCd == tsdPtr->cwdClientData) {
+ goto cdDidNotChange;
+ }
+
+ /* Looks like a new current directory */
+ retVal = (*fsPtr->internalToNormalizedProc)(retCd);
+ Tcl_IncrRefCount(retVal);
+ } else {
+ retVal = (*proc)(interp);
+ }
if (retVal != NULL) {
- Tcl_Obj *norm = TclFSNormalizeAbsolutePath(interp, retVal, NULL);
+ Tcl_Obj *norm = TclFSNormalizeAbsolutePath(interp, retVal,
+ NULL);
/*
* Check whether cwd has changed from the value
* previously stored in cwdPathPtr. Really 'norm'
@@ -2370,6 +2522,9 @@ Tcl_FSGetCwd(interp)
*/
if (norm == NULL) {
/* Do nothing */
+ if (retCd != NULL) {
+ (*fsPtr->freeInternalRepProc)(retCd);
+ }
} else if (Tcl_FSEqualPaths(tsdPtr->cwdPathPtr, norm)) {
/*
* If the paths were equal, we can be more
@@ -2379,19 +2534,23 @@ Tcl_FSGetCwd(interp)
* path we just calculated.
*/
Tcl_DecrRefCount(norm);
+ if (retCd != NULL) {
+ (*fsPtr->freeInternalRepProc)(retCd);
+ }
} else {
- FsUpdateCwd(norm);
+ FsUpdateCwd(norm, retCd);
Tcl_DecrRefCount(norm);
}
Tcl_DecrRefCount(retVal);
} else {
/* The 'cwd' function returned an error; reset the cwd */
- FsUpdateCwd(NULL);
+ FsUpdateCwd(NULL, NULL);
}
}
}
}
+ cdDidNotChange:
if (tsdPtr->cwdPathPtr != NULL) {
Tcl_IncrRefCount(tsdPtr->cwdPathPtr);
}
@@ -2469,11 +2628,13 @@ Tcl_FSChdir(pathPtr)
* will have been cached as a result of the
* Tcl_FSGetFileSystemForPath call above anyway).
*/
+ ClientData cd;
Tcl_Obj *normDirName = Tcl_FSGetNormalizedPath(NULL, pathPtr);
if (normDirName == NULL) {
return TCL_ERROR;
}
- FsUpdateCwd(normDirName);
+ cd = (ClientData) Tcl_FSGetNativePath(pathPtr);
+ FsUpdateCwd(normDirName, TclNativeDupInternalRep(cd));
}
} else {
Tcl_SetErrno(ENOENT);
@@ -3239,10 +3400,13 @@ TclFSInternalToNormalized(fromFilesystem, clientData, fsRecPtrPtr)
*/
Tcl_PathType
-TclGetPathType(pathObjPtr, filesystemPtrPtr, driveNameLengthPtr, driveNameRef)
- Tcl_Obj *pathObjPtr;
- Tcl_Filesystem **filesystemPtrPtr;
- int *driveNameLengthPtr;
+TclGetPathType(pathPtr, filesystemPtrPtr, driveNameLengthPtr, driveNameRef)
+ Tcl_Obj *pathPtr; /* Path to determine type for */
+ Tcl_Filesystem **filesystemPtrPtr; /* If absolute path and this is
+ * non-NULL, then set to the
+ * filesystem which claims this
+ * path */
+ int *driveNameLengthPtr;
Tcl_Obj **driveNameRef;
{
FilesystemRecord *fsRecPtr;
@@ -3250,7 +3414,7 @@ TclGetPathType(pathObjPtr, filesystemPtrPtr, driveNameLengthPtr, driveNameRef)
char *path;
Tcl_PathType type = TCL_PATH_RELATIVE;
- path = Tcl_GetStringFromObj(pathObjPtr, &pathLen);
+ path = Tcl_GetStringFromObj(pathPtr, &pathLen);
/*
* Call each of the "listVolumes" function in succession, checking
@@ -3335,7 +3499,7 @@ TclGetPathType(pathObjPtr, filesystemPtrPtr, driveNameLengthPtr, driveNameRef)
}
if (type != TCL_PATH_ABSOLUTE) {
- type = TclpGetNativePathType(pathObjPtr, driveNameLengthPtr,
+ type = TclpGetNativePathType(pathPtr, driveNameLengthPtr,
driveNameRef);
if ((type == TCL_PATH_ABSOLUTE) && (filesystemPtrPtr != NULL)) {
*filesystemPtrPtr = &tclNativeFilesystem;
@@ -3655,7 +3819,8 @@ Tcl_FSRemoveDirectory(pathPtr, recursive, errorPtr)
* the cwd is inside the directory, so we
* perform a 'cd [file dirname $path]'
*/
- Tcl_Obj *dirPtr = TclFileDirname(NULL, pathPtr);
+ Tcl_Obj *dirPtr = TclPathPart(NULL, pathPtr,
+ TCL_PATH_DIRNAME);
Tcl_FSChdir(dirPtr);
Tcl_DecrRefCount(dirPtr);
}
@@ -3690,13 +3855,13 @@ Tcl_FSRemoveDirectory(pathPtr, recursive, errorPtr)
*/
Tcl_Filesystem*
-Tcl_FSGetFileSystemForPath(pathObjPtr)
- Tcl_Obj* pathObjPtr;
+Tcl_FSGetFileSystemForPath(pathPtr)
+ Tcl_Obj* pathPtr;
{
FilesystemRecord *fsRecPtr;
Tcl_Filesystem* retVal = NULL;
- if (pathObjPtr == NULL) {
+ if (pathPtr == NULL) {
Tcl_Panic("Tcl_FSGetFileSystemForPath called with NULL object");
return NULL;
}
@@ -3708,7 +3873,7 @@ Tcl_FSGetFileSystemForPath(pathObjPtr)
* the ref count on return or not).
*/
- if (pathObjPtr->refCount == 0) {
+ if (pathPtr->refCount == 0) {
Tcl_Panic("Tcl_FSGetFileSystemForPath called with object with refCount == 0");
return NULL;
}
@@ -3717,7 +3882,7 @@ Tcl_FSGetFileSystemForPath(pathObjPtr)
* Check if the filesystem has changed in some way since
* this object's internal representation was calculated.
*/
- if (TclFSEnsureEpochOk(pathObjPtr, &retVal) != TCL_OK) {
+ if (TclFSEnsureEpochOk(pathPtr, &retVal) != TCL_OK) {
return NULL;
}
@@ -3732,13 +3897,13 @@ Tcl_FSGetFileSystemForPath(pathObjPtr)
Tcl_FSPathInFilesystemProc *proc = fsRecPtr->fsPtr->pathInFilesystemProc;
if (proc != NULL) {
ClientData clientData = NULL;
- int ret = (*proc)(pathObjPtr, &clientData);
+ int ret = (*proc)(pathPtr, &clientData);
if (ret != -1) {
/*
- * We assume the type of pathObjPtr hasn't been changed
+ * We assume the type of pathPtr hasn't been changed
* by the above call to the pathInFilesystemProc.
*/
- TclFSSetPathDetails(pathObjPtr, fsRecPtr, clientData);
+ TclFSSetPathDetails(pathPtr, fsRecPtr, clientData);
retVal = fsRecPtr->fsPtr;
}
}
@@ -3781,10 +3946,10 @@ Tcl_FSGetFileSystemForPath(pathObjPtr)
*/
CONST char *
-Tcl_FSGetNativePath(pathObjPtr)
- Tcl_Obj *pathObjPtr;
+Tcl_FSGetNativePath(pathPtr)
+ Tcl_Obj *pathPtr;
{
- return (CONST char *)Tcl_FSGetInternalRep(pathObjPtr, &tclNativeFilesystem);
+ return (CONST char *)Tcl_FSGetInternalRep(pathPtr, &tclNativeFilesystem);
}
/*
@@ -3803,19 +3968,26 @@ Tcl_FSGetNativePath(pathObjPtr)
*---------------------------------------------------------------------------
*/
static ClientData
-NativeCreateNativeRep(pathObjPtr)
- Tcl_Obj* pathObjPtr;
+NativeCreateNativeRep(pathPtr)
+ Tcl_Obj* pathPtr;
{
char *nativePathPtr;
Tcl_DString ds;
- Tcl_Obj* validPathObjPtr;
+ Tcl_Obj* validPathPtr;
int len;
char *str;
+ ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&tclFsDataKey);
- /* Make sure the normalized path is set */
- validPathObjPtr = Tcl_FSGetNormalizedPath(NULL, pathObjPtr);
+ if (tsdPtr->cwdClientData != NULL) {
+ /* The cwd is native */
+ validPathPtr = Tcl_FSGetTranslatedPath(NULL, pathPtr);
+ } else {
+ /* Make sure the normalized path is set */
+ validPathPtr = Tcl_FSGetNormalizedPath(NULL, pathPtr);
+ Tcl_IncrRefCount(validPathPtr);
+ }
- str = Tcl_GetStringFromObj(validPathObjPtr, &len);
+ str = Tcl_GetStringFromObj(validPathPtr, &len);
#ifdef __WIN32__
Tcl_WinUtfToTChar(str, len, &ds);
if (tclWinProcs->useWide) {
@@ -3827,6 +3999,7 @@ NativeCreateNativeRep(pathObjPtr)
Tcl_UtfToExternalDString(NULL, str, len, &ds);
len = Tcl_DStringLength(&ds) + sizeof(char);
#endif
+ Tcl_DecrRefCount(validPathPtr);
nativePathPtr = ckalloc((unsigned) len);
memcpy((VOID*)nativePathPtr, (VOID*)Tcl_DStringValue(&ds), (size_t) len);
@@ -3841,6 +4014,11 @@ NativeCreateNativeRep(pathObjPtr)
*
* Convert native format to a normalized path object, with refCount
* of zero.
+ *
+ * Currently assumes all native paths are actually normalized
+ * already, so if the path given is not normalized this will
+ * actually just convert to a valid string path, but not
+ * necessarily a normalized one.
*
* Results:
* A valid normalized path.
@@ -3856,12 +4034,14 @@ TclpNativeToNormalized(clientData)
{
Tcl_DString ds;
Tcl_Obj *objPtr;
- CONST char *copy;
int len;
#ifdef __WIN32__
+ char *copy;
+ char *p;
Tcl_WinTCharToUtf((CONST char*)clientData, -1, &ds);
#else
+ CONST char *copy;
Tcl_ExternalToUtfDString(NULL, (CONST char*)clientData, -1, &ds);
#endif
@@ -3883,6 +4063,14 @@ TclpNativeToNormalized(clientData)
len -= 4;
}
}
+ /*
+ * Ensure we are using forward slashes only.
+ */
+ for (p = copy; *p != '\0'; p++) {
+ if (*p == '\\') {
+ *p = '/';
+ }
+ }
#endif
objPtr = Tcl_NewStringObj(copy,len);
@@ -3978,12 +4166,12 @@ NativeFreeInternalRep(clientData)
*---------------------------------------------------------------------------
*/
Tcl_Obj*
-Tcl_FSFileSystemInfo(pathObjPtr)
- Tcl_Obj* pathObjPtr;
+Tcl_FSFileSystemInfo(pathPtr)
+ Tcl_Obj* pathPtr;
{
Tcl_Obj *resPtr;
Tcl_FSFilesystemPathTypeProc *proc;
- Tcl_Filesystem *fsPtr = Tcl_FSGetFileSystemForPath(pathObjPtr);
+ Tcl_Filesystem *fsPtr = Tcl_FSGetFileSystemForPath(pathPtr);
if (fsPtr == NULL) {
return NULL;
@@ -3996,7 +4184,7 @@ Tcl_FSFileSystemInfo(pathObjPtr)
proc = fsPtr->filesystemPathTypeProc;
if (proc != NULL) {
- Tcl_Obj *typePtr = (*proc)(pathObjPtr);
+ Tcl_Obj *typePtr = (*proc)(pathPtr);
if (typePtr != NULL) {
Tcl_ListObjAppendElement(NULL, resPtr, typePtr);
}
@@ -4024,16 +4212,16 @@ Tcl_FSFileSystemInfo(pathObjPtr)
*---------------------------------------------------------------------------
*/
Tcl_Obj*
-Tcl_FSPathSeparator(pathObjPtr)
- Tcl_Obj* pathObjPtr;
+Tcl_FSPathSeparator(pathPtr)
+ Tcl_Obj* pathPtr;
{
- Tcl_Filesystem *fsPtr = Tcl_FSGetFileSystemForPath(pathObjPtr);
+ Tcl_Filesystem *fsPtr = Tcl_FSGetFileSystemForPath(pathPtr);
if (fsPtr == NULL) {
return NULL;
}
if (fsPtr->filesystemSeparatorProc != NULL) {
- return (*fsPtr->filesystemSeparatorProc)(pathObjPtr);
+ return (*fsPtr->filesystemSeparatorProc)(pathPtr);
}
return NULL;
@@ -4056,8 +4244,8 @@ Tcl_FSPathSeparator(pathObjPtr)
*---------------------------------------------------------------------------
*/
static Tcl_Obj*
-NativeFilesystemSeparator(pathObjPtr)
- Tcl_Obj* pathObjPtr;
+NativeFilesystemSeparator(pathPtr)
+ Tcl_Obj* pathPtr;
{
char *separator = NULL; /* lint */
switch (tclPlatform) {
diff --git a/generic/tclInt.decls b/generic/tclInt.decls
index ec6604c..b9dae7e 100644
--- a/generic/tclInt.decls
+++ b/generic/tclInt.decls
@@ -12,7 +12,7 @@
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
#
-# RCS: @(#) $Id: tclInt.decls,v 1.67 2003/12/15 00:49:38 davygrvy Exp $
+# RCS: @(#) $Id: tclInt.decls,v 1.68 2004/01/21 19:59:33 vincentdarley Exp $
library tcl
@@ -75,10 +75,11 @@ declare 11 generic {
declare 12 generic {
void TclDeleteVars(Interp *iPtr, Tcl_HashTable *tablePtr)
}
-declare 13 generic {
- int TclDoGlob(Tcl_Interp *interp, char *separators,
- Tcl_DString *headPtr, char *tail, Tcl_GlobTypeData *types)
-}
+# Removed in 8.5
+#declare 13 generic {
+# int TclDoGlob(Tcl_Interp *interp, char *separators,
+# Tcl_DString *headPtr, char *tail, Tcl_GlobTypeData *types)
+#}
declare 14 generic {
void TclDumpMemoryInfo(FILE *outFile)
}
@@ -140,7 +141,7 @@ declare 28 generic {
# char *TclGetEnv(CONST char *name)
# }
declare 31 generic {
- char *TclGetExtension(char *name)
+ CONST char *TclGetExtension(CONST char *name)
}
declare 32 generic {
int TclGetFrame(Tcl_Interp *interp, CONST char *str,
diff --git a/generic/tclInt.h b/generic/tclInt.h
index 8ab9900..6825d08 100644
--- a/generic/tclInt.h
+++ b/generic/tclInt.h
@@ -12,7 +12,7 @@
* See the file "license.terms" for information on usage and redistribution
* of this file, and for a DISCLAIMER OF ALL WARRANTIES.
*
- * RCS: @(#) $Id: tclInt.h,v 1.142 2004/01/18 16:19:06 dkf Exp $
+ * RCS: @(#) $Id: tclInt.h,v 1.143 2004/01/21 19:59:33 vincentdarley Exp $
*/
#ifndef _TCLINT
@@ -1483,6 +1483,22 @@ typedef struct List {
Tcl_Obj **elements; /* Array of pointers to element objects. */
} List;
+/*
+ *----------------------------------------------------------------
+ * Data structures related to the filesystem internals
+ *----------------------------------------------------------------
+ */
+
+
+/*
+ * The version_2 filesystem is private to Tcl. As and when these
+ * changes have been thoroughly tested and investigated a new public
+ * filesystem interface will be released. The aim is more versatile
+ * virtual filesystem interfaces, more efficiency in 'path' manipulation
+ * and usage, and cleaner filesystem code internally.
+ */
+#define TCL_FILESYSTEM_VERSION_2 ((Tcl_FSVersion) 0x2)
+typedef ClientData (TclFSGetCwdProc2) _ANSI_ARGS_((ClientData clientData));
/*
* The following types are used for getting and storing platform-specific
@@ -1525,6 +1541,13 @@ typedef struct TclpTime_t_ *TclpTime_t;
#define TCL_GLOBMODE_DIR 4
#define TCL_GLOBMODE_TAILS 8
+typedef enum Tcl_PathPart {
+ TCL_PATH_DIRNAME,
+ TCL_PATH_TAIL,
+ TCL_PATH_EXTENSION,
+ TCL_PATH_ROOT
+} Tcl_PathPart;
+
/*
*----------------------------------------------------------------
* Data structures related to obsolete filesystem hooks
@@ -1760,7 +1783,7 @@ EXTERN void TclpNativeJoinPath _ANSI_ARGS_((Tcl_Obj *prefix,
char *joining));
EXTERN Tcl_Obj* TclpNativeSplitPath _ANSI_ARGS_((Tcl_Obj *pathPtr,
int *lenPtr));
-EXTERN Tcl_PathType TclpGetNativePathType _ANSI_ARGS_((Tcl_Obj *pathObjPtr,
+EXTERN Tcl_PathType TclpGetNativePathType _ANSI_ARGS_((Tcl_Obj *pathPtr,
int *driveNameLengthPtr, Tcl_Obj **driveNameRef));
EXTERN int TclCrossFilesystemCopy _ANSI_ARGS_((Tcl_Interp *interp,
Tcl_Obj *source, Tcl_Obj *target));
@@ -1776,13 +1799,15 @@ EXTERN int TclpObjRenameFile _ANSI_ARGS_((Tcl_Obj *srcPathPtr,
EXTERN int TclpMatchInDirectory _ANSI_ARGS_((Tcl_Interp *interp,
Tcl_Obj *resultPtr, Tcl_Obj *pathPtr,
CONST char *pattern, Tcl_GlobTypeData *types));
-EXTERN Tcl_Obj* TclpObjGetCwd _ANSI_ARGS_((Tcl_Interp *interp));
+EXTERN ClientData TclpGetNativeCwd _ANSI_ARGS_((ClientData clientData));
+EXTERN Tcl_FSDupInternalRepProc TclNativeDupInternalRep;
EXTERN Tcl_Obj* TclpObjLink _ANSI_ARGS_((Tcl_Obj *pathPtr,
Tcl_Obj *toPtr, int linkType));
EXTERN int TclpObjChdir _ANSI_ARGS_((Tcl_Obj *pathPtr));
-EXTERN Tcl_Obj* TclFileDirname _ANSI_ARGS_((Tcl_Interp *interp,
- Tcl_Obj*pathPtr));
-EXTERN int TclpObjStat _ANSI_ARGS_((Tcl_Obj *pathPtr, Tcl_StatBuf *buf));
+EXTERN Tcl_Obj* TclPathPart _ANSI_ARGS_((Tcl_Interp *interp,
+ Tcl_Obj *pathPtr, Tcl_PathPart portion));
+EXTERN int TclpObjStat _ANSI_ARGS_((Tcl_Obj *pathPtr,
+ Tcl_StatBuf *buf));
EXTERN Tcl_Channel TclpOpenFileChannel _ANSI_ARGS_((Tcl_Interp *interp,
Tcl_Obj *pathPtr, int mode,
int permissions));
@@ -1818,7 +1843,7 @@ EXTERN void TclTransferResult _ANSI_ARGS_((Tcl_Interp *sourceInterp,
EXTERN Tcl_Obj* TclpNativeToNormalized
_ANSI_ARGS_((ClientData clientData));
EXTERN Tcl_Obj* TclpFilesystemPathType
- _ANSI_ARGS_((Tcl_Obj* pathObjPtr));
+ _ANSI_ARGS_((Tcl_Obj* pathPtr));
EXTERN Tcl_PackageInitProc* TclpFindSymbol _ANSI_ARGS_((Tcl_Interp *interp,
Tcl_LoadHandle loadHandle, CONST char *symbol));
EXTERN int TclpDlopen _ANSI_ARGS_((Tcl_Interp *interp,
diff --git a/generic/tclIntDecls.h b/generic/tclIntDecls.h
index 429c6cc..0d2e455 100644
--- a/generic/tclIntDecls.h
+++ b/generic/tclIntDecls.h
@@ -11,7 +11,7 @@
* See the file "license.terms" for information on usage and redistribution
* of this file, and for a DISCLAIMER OF ALL WARRANTIES.
*
- * RCS: @(#) $Id: tclIntDecls.h,v 1.55 2003/12/15 00:49:38 davygrvy Exp $
+ * RCS: @(#) $Id: tclIntDecls.h,v 1.56 2004/01/21 19:59:33 vincentdarley Exp $
*/
#ifndef _TCLINTDECLS
@@ -124,13 +124,7 @@ EXTERN void TclDeleteCompiledLocalVars _ANSI_ARGS_((
EXTERN void TclDeleteVars _ANSI_ARGS_((Interp * iPtr,
Tcl_HashTable * tablePtr));
#endif
-#ifndef TclDoGlob_TCL_DECLARED
-#define TclDoGlob_TCL_DECLARED
-/* 13 */
-EXTERN int TclDoGlob _ANSI_ARGS_((Tcl_Interp * interp,
- char * separators, Tcl_DString * headPtr,
- char * tail, Tcl_GlobTypeData * types));
-#endif
+/* Slot 13 is reserved */
#ifndef TclDumpMemoryInfo_TCL_DECLARED
#define TclDumpMemoryInfo_TCL_DECLARED
/* 14 */
@@ -190,7 +184,7 @@ EXTERN Tcl_Channel TclpGetDefaultStdChannel _ANSI_ARGS_((int type));
#ifndef TclGetExtension_TCL_DECLARED
#define TclGetExtension_TCL_DECLARED
/* 31 */
-EXTERN char * TclGetExtension _ANSI_ARGS_((char * name));
+EXTERN CONST char * TclGetExtension _ANSI_ARGS_((CONST char * name));
#endif
#ifndef TclGetFrame_TCL_DECLARED
#define TclGetFrame_TCL_DECLARED
@@ -991,7 +985,7 @@ typedef struct TclIntStubs {
int (*tclCreateProc) _ANSI_ARGS_((Tcl_Interp * interp, Namespace * nsPtr, CONST char * procName, Tcl_Obj * argsPtr, Tcl_Obj * bodyPtr, Proc ** procPtrPtr)); /* 10 */
void (*tclDeleteCompiledLocalVars) _ANSI_ARGS_((Interp * iPtr, CallFrame * framePtr)); /* 11 */
void (*tclDeleteVars) _ANSI_ARGS_((Interp * iPtr, Tcl_HashTable * tablePtr)); /* 12 */
- int (*tclDoGlob) _ANSI_ARGS_((Tcl_Interp * interp, char * separators, Tcl_DString * headPtr, char * tail, Tcl_GlobTypeData * types)); /* 13 */
+ void *reserved13;
void (*tclDumpMemoryInfo) _ANSI_ARGS_((FILE * outFile)); /* 14 */
void *reserved15;
void (*tclExprFloatError) _ANSI_ARGS_((Tcl_Interp * interp, double value)); /* 16 */
@@ -1009,7 +1003,7 @@ typedef struct TclIntStubs {
Tcl_Channel (*tclpGetDefaultStdChannel) _ANSI_ARGS_((int type)); /* 28 */
void *reserved29;
void *reserved30;
- char * (*tclGetExtension) _ANSI_ARGS_((char * name)); /* 31 */
+ CONST char * (*tclGetExtension) _ANSI_ARGS_((CONST char * name)); /* 31 */
int (*tclGetFrame) _ANSI_ARGS_((Tcl_Interp * interp, CONST char * str, CallFrame ** framePtrPtr)); /* 32 */
TclCmdProcType (*tclGetInterpProc) _ANSI_ARGS_((void)); /* 33 */
int (*tclGetIntForIndex) _ANSI_ARGS_((Tcl_Interp * interp, Tcl_Obj * objPtr, int endValue, int * indexPtr)); /* 34 */
@@ -1246,10 +1240,7 @@ extern TclIntStubs *tclIntStubsPtr;
#define TclDeleteVars \
(tclIntStubsPtr->tclDeleteVars) /* 12 */
#endif
-#ifndef TclDoGlob
-#define TclDoGlob \
- (tclIntStubsPtr->tclDoGlob) /* 13 */
-#endif
+/* Slot 13 is reserved */
#ifndef TclDumpMemoryInfo
#define TclDumpMemoryInfo \
(tclIntStubsPtr->tclDumpMemoryInfo) /* 14 */
diff --git a/generic/tclPathObj.c b/generic/tclPathObj.c
index 30bffcc..acb16b7 100644
--- a/generic/tclPathObj.c
+++ b/generic/tclPathObj.c
@@ -10,7 +10,7 @@
* See the file "license.terms" for information on usage and redistribution
* of this file, and for a DISCLAIMER OF ALL WARRANTIES.
*
- * RCS: @(#) $Id: tclPathObj.c,v 1.19 2003/12/24 04:18:20 davygrvy Exp $
+ * RCS: @(#) $Id: tclPathObj.c,v 1.20 2004/01/21 19:59:33 vincentdarley Exp $
*/
#include "tclInt.h"
@@ -26,12 +26,13 @@
static void DupFsPathInternalRep _ANSI_ARGS_((Tcl_Obj *srcPtr,
Tcl_Obj *copyPtr));
-static void FreeFsPathInternalRep _ANSI_ARGS_((Tcl_Obj *listPtr));
-static void UpdateStringOfFsPath _ANSI_ARGS_((Tcl_Obj *objPtr));
+static void FreeFsPathInternalRep _ANSI_ARGS_((Tcl_Obj *pathPtr));
+static void UpdateStringOfFsPath _ANSI_ARGS_((Tcl_Obj *pathPtr));
static int SetFsPathFromAny _ANSI_ARGS_((Tcl_Interp *interp,
- Tcl_Obj *objPtr));
+ Tcl_Obj *pathPtr));
static int FindSplitPos _ANSI_ARGS_((CONST char *path, int separator));
static int IsSeparatorOrNull _ANSI_ARGS_((int ch));
+static Tcl_Obj* GetExtension _ANSI_ARGS_((Tcl_Obj *pathPtr));
/*
@@ -54,8 +55,25 @@ Tcl_ObjType tclFsPathType = {
* certain optimisations when used to represent paths which are
* already normalized and absolute.
*
- * Note that 'normPathPtr' can be a circular reference to the
- * container Tcl_Obj of this FsPath.
+ * Note that both 'translatedPathPtr' and 'normPathPtr' can be a
+ * circular reference to the container Tcl_Obj of this FsPath.
+ *
+ * There are two cases, with the first being the most common:
+ *
+ * (i) flags == 0, => Ordinary path.
+ *
+ * translatedPathPtr contains the translated path (which may be
+ * a circular reference to the object itself). If it is NULL
+ * then the path is pure normalized (and the normPathPtr will be
+ * a circular reference). cwdPtr is null for an absolute path,
+ * and non-null for a relative path (unless the cwd has never been
+ * set, in which case the cwdPtr may also be null for a relative path).
+ *
+ * (ii) flags != 0, => Special path, see TclNewFSPathObj
+ *
+ * Now, this is a path like 'file join $dir $tail' where, cwdPtr is
+ * the $dir and normPathPtr is the $tail.
+ *
*/
typedef struct FsPath {
Tcl_Obj *translatedPathPtr; /* Name without any ~user sequences.
@@ -75,7 +93,8 @@ typedef struct FsPath {
* this points to the cwd object used
* for this path. We have a refCount
* on the object. */
- int flags; /* Flags to describe interpretation */
+ int flags; /* Flags to describe interpretation -
+ * see below. */
ClientData nativePathPtr; /* Native representation of this path,
* which is filesystem dependent. */
int filesystemEpoch; /* Used to ensure the path representation
@@ -87,16 +106,19 @@ typedef struct FsPath {
* entry to use for this path. */
} FsPath;
+/*
+ * Flag values for FsPath->flags.
+ */
+#define TCLPATH_APPENDED 1
+
/*
* Define some macros to give us convenient access to path-object
* specific fields.
*/
-#define PATHOBJ(objPtr) (objPtr->internalRep.otherValuePtr)
-#define PATHFLAGS(objPtr) \
- (((FsPath*)(objPtr->internalRep.otherValuePtr))->flags)
+#define PATHOBJ(pathPtr) (pathPtr->internalRep.otherValuePtr)
+#define PATHFLAGS(pathPtr) \
+ (((FsPath*)(pathPtr->internalRep.otherValuePtr))->flags)
-#define TCLPATH_APPENDED 1
-#define TCLPATH_RELATIVE 2
/*
*---------------------------------------------------------------------------
@@ -344,10 +366,10 @@ TclFSNormalizeAbsolutePath(interp, pathPtr, clientDataPtr)
*/
Tcl_PathType
-Tcl_FSGetPathType(pathObjPtr)
- Tcl_Obj *pathObjPtr;
+Tcl_FSGetPathType(pathPtr)
+ Tcl_Obj *pathPtr;
{
- return TclFSGetPathType(pathObjPtr, NULL, NULL);
+ return TclFSGetPathType(pathPtr, NULL, NULL);
}
/*
@@ -375,24 +397,24 @@ Tcl_FSGetPathType(pathObjPtr)
*/
Tcl_PathType
-TclFSGetPathType(pathObjPtr, filesystemPtrPtr, driveNameLengthPtr)
- Tcl_Obj *pathObjPtr;
+TclFSGetPathType(pathPtr, filesystemPtrPtr, driveNameLengthPtr)
+ Tcl_Obj *pathPtr;
Tcl_Filesystem **filesystemPtrPtr;
int *driveNameLengthPtr;
{
- if (Tcl_FSConvertToPathType(NULL, pathObjPtr) != TCL_OK) {
- return TclGetPathType(pathObjPtr, filesystemPtrPtr,
+ if (Tcl_FSConvertToPathType(NULL, pathPtr) != TCL_OK) {
+ return TclGetPathType(pathPtr, filesystemPtrPtr,
driveNameLengthPtr, NULL);
} else {
- FsPath *fsPathPtr = (FsPath*) PATHOBJ(pathObjPtr);
+ FsPath *fsPathPtr = (FsPath*) PATHOBJ(pathPtr);
if (fsPathPtr->cwdPtr != NULL) {
- if (PATHFLAGS(pathObjPtr) == 0) {
+ if (PATHFLAGS(pathPtr) == 0) {
return TCL_PATH_RELATIVE;
}
return TclFSGetPathType(fsPathPtr->cwdPtr, filesystemPtrPtr,
driveNameLengthPtr);
} else {
- return TclGetPathType(pathObjPtr, filesystemPtrPtr,
+ return TclGetPathType(pathPtr, filesystemPtrPtr,
driveNameLengthPtr, NULL);
}
}
@@ -401,6 +423,205 @@ TclFSGetPathType(pathObjPtr, filesystemPtrPtr, driveNameLengthPtr)
/*
*---------------------------------------------------------------------------
*
+ * TclPathPart
+ *
+ * This procedure calculates the requested part of the the given
+ * path, which can be:
+ *
+ * - the directory above ('file dirname')
+ * - the tail ('file tail')
+ * - the extension ('file extension')
+ * - the root ('file root')
+ *
+ * The 'portion' parameter dictates which of these to calculate.
+ * There are a number of special cases both to be more efficient,
+ * and because the behaviour when given a path with only a single
+ * element is defined to require the expansion of that single
+ * element, where possible.
+ *
+ * Should look into integrating 'FileBasename' in tclFCmd.c into
+ * this function.
+ *
+ * Results:
+ * NULL if an error occurred, otherwise a Tcl_Obj owned by
+ * the caller (i.e. most likely with refCount 1).
+ *
+ * Side effects:
+ * None.
+ *
+ *---------------------------------------------------------------------------
+ */
+
+Tcl_Obj*
+TclPathPart(interp, pathPtr, portion)
+ Tcl_Interp *interp; /* Used for error reporting */
+ Tcl_Obj *pathPtr; /* Path to take dirname of */
+ Tcl_PathPart portion; /* Requested portion of name */
+{
+ if (pathPtr->typePtr == &tclFsPathType) {
+ FsPath *fsPathPtr = (FsPath*) PATHOBJ(pathPtr);
+ if (PATHFLAGS(pathPtr) != 0) {
+ switch (portion) {
+ case TCL_PATH_DIRNAME: {
+ Tcl_IncrRefCount(fsPathPtr->cwdPtr);
+ return fsPathPtr->cwdPtr;
+ }
+ case TCL_PATH_TAIL: {
+ Tcl_IncrRefCount(fsPathPtr->normPathPtr);
+ return fsPathPtr->normPathPtr;
+ }
+ case TCL_PATH_EXTENSION: {
+ return GetExtension(fsPathPtr->normPathPtr);
+ }
+ case TCL_PATH_ROOT: {
+ /* Unimplemented */
+ CONST char *fileName, *extension;
+ int length;
+ fileName = Tcl_GetStringFromObj(fsPathPtr->normPathPtr,
+ &length);
+ extension = TclGetExtension(fileName);
+ if (extension == NULL) {
+ /*
+ * There is no extension so the root is the
+ * same as the path we were given.
+ */
+ Tcl_IncrRefCount(pathPtr);
+ return pathPtr;
+ } else {
+ /*
+ * Duplicate the object we were given and
+ * then trim off the extension of the
+ * tail component of the path.
+ */
+ Tcl_Obj *root;
+ FsPath *fsDupPtr;
+ root = Tcl_DuplicateObj(pathPtr);
+ Tcl_IncrRefCount(root);
+ fsDupPtr = (FsPath*) PATHOBJ(root);
+ if (Tcl_IsShared(fsDupPtr->normPathPtr)) {
+ Tcl_DecrRefCount(fsDupPtr->normPathPtr);
+ fsDupPtr->normPathPtr = Tcl_NewStringObj(fileName,
+ (int)(length - strlen(extension)));
+ Tcl_IncrRefCount(fsDupPtr->normPathPtr);
+ } else {
+ Tcl_SetObjLength(fsDupPtr->normPathPtr,
+ (int)(length - strlen(extension)));
+ }
+ return root;
+ }
+ }
+ }
+ } else if (fsPathPtr->cwdPtr != NULL) {
+ /* Relative path */
+ goto standardPath;
+ } else {
+ /* Absolute path */
+ goto standardPath;
+ }
+ } else {
+ int splitElements;
+ Tcl_Obj *splitPtr;
+ Tcl_Obj *resultPtr = NULL;
+ standardPath:
+
+ if (portion == TCL_PATH_EXTENSION) {
+ return GetExtension(pathPtr);
+ } else if (portion == TCL_PATH_ROOT) {
+ int length;
+ CONST char *fileName, *extension;
+
+ fileName = Tcl_GetStringFromObj(pathPtr, &length);
+ extension = TclGetExtension(fileName);
+ if (extension == NULL) {
+ Tcl_IncrRefCount(pathPtr);
+ return pathPtr;
+ } else {
+ Tcl_Obj *root = Tcl_NewStringObj(fileName,
+ (int) (length - strlen(extension)));
+ Tcl_IncrRefCount(root);
+ return root;
+ }
+ }
+
+ /*
+ * The behaviour we want here is slightly different to
+ * the standard Tcl_FSSplitPath in the handling of home
+ * directories; Tcl_FSSplitPath preserves the "~" while
+ * this code computes the actual full path name, if we
+ * had just a single component.
+ */
+ splitPtr = Tcl_FSSplitPath(pathPtr, &splitElements);
+ Tcl_IncrRefCount(splitPtr);
+ if ((splitElements == 1) && (Tcl_GetString(pathPtr)[0] == '~')) {
+ Tcl_Obj *norm;
+
+ Tcl_DecrRefCount(splitPtr);
+ norm = Tcl_FSGetNormalizedPath(interp, pathPtr);
+ if (norm == NULL) {
+ return NULL;
+ }
+ splitPtr = Tcl_FSSplitPath(norm, &splitElements);
+ Tcl_IncrRefCount(splitPtr);
+ }
+ if (portion == TCL_PATH_TAIL) {
+ /*
+ * Return the last component, unless it is the only component,
+ * and it is the root of an absolute path.
+ */
+
+ if ((splitElements > 0) && ((splitElements > 1)
+ || (Tcl_FSGetPathType(pathPtr) == TCL_PATH_RELATIVE))) {
+ Tcl_ListObjIndex(NULL, splitPtr, splitElements-1, &resultPtr);
+ } else {
+ resultPtr = Tcl_NewObj();
+ }
+ } else {
+ /*
+ * Return all but the last component. If there is only one
+ * component, return it if the path was non-relative, otherwise
+ * return the current directory.
+ */
+
+ if (splitElements > 1) {
+ resultPtr = Tcl_FSJoinPath(splitPtr, splitElements - 1);
+ } else if (splitElements == 0 ||
+ (Tcl_FSGetPathType(pathPtr) == TCL_PATH_RELATIVE)) {
+ resultPtr = Tcl_NewStringObj(
+ ((tclPlatform == TCL_PLATFORM_MAC) ? ":" : "."), 1);
+ } else {
+ Tcl_ListObjIndex(NULL, splitPtr, 0, &resultPtr);
+ }
+ }
+ Tcl_IncrRefCount(resultPtr);
+ Tcl_DecrRefCount(splitPtr);
+ return resultPtr;
+ }
+}
+
+/*
+ * Simple helper function
+ */
+static Tcl_Obj*
+GetExtension(pathPtr)
+ Tcl_Obj *pathPtr;
+{
+ CONST char *tail, *extension;
+ Tcl_Obj *ret;
+
+ tail = Tcl_GetString(pathPtr);
+ extension = TclGetExtension(tail);
+ if (extension == NULL) {
+ ret = Tcl_NewObj();
+ } else {
+ ret = Tcl_NewStringObj(extension, -1);
+ }
+ Tcl_IncrRefCount(ret);
+ return ret;
+}
+
+/*
+ *---------------------------------------------------------------------------
+ *
* Tcl_FSJoinPath --
*
* This function takes the given Tcl_Obj, which should be a valid
@@ -408,6 +629,10 @@ TclFSGetPathType(pathObjPtr, filesystemPtrPtr, driveNameLengthPtr)
* first 'elements' elements as valid path segments. If elements < 0,
* we use the entire list.
*
+ * It is possible that the returned object is actually an element
+ * of the given list, so the caller should be careful to store a
+ * refCount to it before freeing the list.
+ *
* Results:
* Returns object with refCount of zero, (or if non-zero, it has
* references elsewhere in Tcl). Either way, the caller must
@@ -420,8 +645,8 @@ TclFSGetPathType(pathObjPtr, filesystemPtrPtr, driveNameLengthPtr)
*/
Tcl_Obj*
Tcl_FSJoinPath(listObj, elements)
- Tcl_Obj *listObj;
- int elements;
+ Tcl_Obj *listObj; /* Path elements to join, may have refCount 0 */
+ int elements; /* Number of elements to use (-1 = all) */
{
Tcl_Obj *res;
int i;
@@ -446,7 +671,7 @@ Tcl_FSJoinPath(listObj, elements)
}
}
- res = Tcl_NewObj();
+ res = NULL;
for (i = 0; i < elements; i++) {
Tcl_Obj *elt;
@@ -485,7 +710,7 @@ Tcl_FSJoinPath(listObj, elements)
* '/'. There's no need to return a special path
* object, when the base itself is just fine!
*/
- Tcl_DecrRefCount(res);
+ if (res != NULL) Tcl_DecrRefCount(res);
return elt;
}
/*
@@ -499,7 +724,7 @@ Tcl_FSJoinPath(listObj, elements)
*/
if (str[0] != '.' && ((tclPlatform != TCL_PLATFORM_WINDOWS)
|| (strchr(str, '\\') == NULL))) {
- Tcl_DecrRefCount(res);
+ if (res != NULL) Tcl_DecrRefCount(res);
return TclNewFSPathObj(elt, str, len);
}
/*
@@ -509,7 +734,7 @@ Tcl_FSJoinPath(listObj, elements)
*/
} else {
if (tclPlatform == TCL_PLATFORM_UNIX) {
- Tcl_DecrRefCount(res);
+ if (res != NULL) Tcl_DecrRefCount(res);
return tail;
} else {
CONST char *str;
@@ -517,12 +742,12 @@ Tcl_FSJoinPath(listObj, elements)
str = Tcl_GetStringFromObj(tail,&len);
if (tclPlatform == TCL_PLATFORM_WINDOWS) {
if (strchr(str, '\\') == NULL) {
- Tcl_DecrRefCount(res);
+ if (res != NULL) Tcl_DecrRefCount(res);
return tail;
}
} else if (tclPlatform == TCL_PLATFORM_MAC) {
if (strchr(str, '/') == NULL) {
- Tcl_DecrRefCount(res);
+ if (res != NULL) Tcl_DecrRefCount(res);
return tail;
}
}
@@ -533,27 +758,101 @@ Tcl_FSJoinPath(listObj, elements)
type = TclGetPathType(elt, &fsPtr, &driveNameLength, &driveName);
if (type != TCL_PATH_RELATIVE) {
/* Zero out the current result */
- Tcl_DecrRefCount(res);
+ if (res != NULL) Tcl_DecrRefCount(res);
+
if (driveName != NULL) {
+ /*
+ * We've been given a separate drive-name object,
+ * because the prefix in 'elt' is not in a suitable
+ * format for us (e.g. it may contain irrelevant
+ * multiple separators, like C://///foo).
+ */
res = Tcl_DuplicateObj(driveName);
Tcl_DecrRefCount(driveName);
+ /*
+ * Do not set driveName to NULL, because we will check
+ * its value below (but we won't access the contents,
+ * since those have been cleaned-up).
+ */
} else {
res = Tcl_NewStringObj(strElt, driveNameLength);
}
strElt += driveNameLength;
}
- ptr = Tcl_GetStringFromObj(res, &length);
+ /*
+ * Optimisation block: if this is the last element to be
+ * examined, and it is absolute or the only element, and the
+ * drive-prefix was ok (if there is one), it might be that the
+ * path is already in a suitable form to be returned. Then we
+ * can short-cut the rest of this procedure.
+ */
+ if ((driveName == NULL) && (i == (elements - 1))
+ && (type != TCL_PATH_RELATIVE || res == NULL)) {
+ /*
+ * It's the last path segment. Perform a quick check if
+ * the path is already in a suitable form.
+ */
+ int equal = 1;
+
+ if (tclPlatform == TCL_PLATFORM_WINDOWS) {
+ if (strchr(strElt, '\\') != NULL) {
+ equal = 0;
+ }
+ }
+ if (equal && (tclPlatform != TCL_PLATFORM_MAC)) {
+ ptr = strElt;
+ while (*ptr != '\0') {
+ if (*ptr == '/' && (ptr[1] == '/' || ptr[1] == '\0')) {
+ equal = 0;
+ break;
+ }
+ ptr++;
+ }
+ }
+ if (equal && (tclPlatform == TCL_PLATFORM_MAC)) {
+ /*
+ * If it contains any colons, then it mustn't contain
+ * any duplicates. Otherwise, the path is in unix-form
+ * and is no good.
+ */
+ if (strchr(strElt, ':') != NULL) {
+ ptr = strElt;
+ while (*ptr != '\0') {
+ if (*ptr == ':' && (ptr[1] == ':' || ptr[1] == '\0')) {
+ equal = 0;
+ break;
+ }
+ ptr++;
+ }
+ } else {
+ equal = 0;
+ }
+ }
+ if (equal) {
+ if (res != NULL) Tcl_DecrRefCount(res);
+ /*
+ * This element is just what we want to return already -
+ * no further manipulation is requred.
+ */
+ return elt;
+ }
+ }
+
+ if (res == NULL) {
+ res = Tcl_NewObj();
+ ptr = Tcl_GetStringFromObj(res, &length);
+ } else {
+ ptr = Tcl_GetStringFromObj(res, &length);
+ }
/*
* Strip off any './' before a tilde, unless this is the
* beginning of the path.
*/
- if (length > 0 && strEltLen > 0) {
- if ((strElt[0] == '.') && (strElt[1] == '/')
- && (strElt[2] == '~')) {
- strElt += 2;
- }
+ if (length > 0 && strEltLen > 0
+ && (strElt[0] == '.') && (strElt[1] == '/') && (strElt[2] == '~')) {
+ strElt += 2;
}
/*
@@ -629,10 +928,10 @@ Tcl_FSJoinPath(listObj, elements)
*---------------------------------------------------------------------------
*/
int
-Tcl_FSConvertToPathType(interp, objPtr)
+Tcl_FSConvertToPathType(interp, pathPtr)
Tcl_Interp *interp; /* Interpreter in which to store error
* message (if necessary). */
- Tcl_Obj *objPtr; /* Object to convert to a valid, current
+ Tcl_Obj *pathPtr; /* Object to convert to a valid, current
* path type. */
{
ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&tclFsDataKey);
@@ -646,39 +945,39 @@ Tcl_FSConvertToPathType(interp, objPtr)
* and is a relative path, we do have to worry about the cwd.
* If the cwd has changed, we must recompute the path.
*/
- if (objPtr->typePtr == &tclFsPathType) {
- FsPath *fsPathPtr = (FsPath*) PATHOBJ(objPtr);
+ if (pathPtr->typePtr == &tclFsPathType) {
+ FsPath *fsPathPtr = (FsPath*) PATHOBJ(pathPtr);
if (fsPathPtr->filesystemEpoch != tsdPtr->filesystemEpoch) {
- if (objPtr->bytes == NULL) {
- UpdateStringOfFsPath(objPtr);
+ if (pathPtr->bytes == NULL) {
+ UpdateStringOfFsPath(pathPtr);
}
- FreeFsPathInternalRep(objPtr);
- objPtr->typePtr = NULL;
- return Tcl_ConvertToType(interp, objPtr, &tclFsPathType);
+ FreeFsPathInternalRep(pathPtr);
+ pathPtr->typePtr = NULL;
+ return Tcl_ConvertToType(interp, pathPtr, &tclFsPathType);
}
return TCL_OK;
/*
- * This code is intentionally never reached. Once fs-optimisation
- * is complete, it will be removed/replaced
+ * We used to have more complex code here:
+ *
+ * if (fsPathPtr->cwdPtr == NULL || PATHFLAGS(pathPtr) != 0) {
+ * return TCL_OK;
+ * } else {
+ * if (TclFSCwdPointerEquals(&fsPathPtr->cwdPtr)) {
+ * return TCL_OK;
+ * } else {
+ * if (pathPtr->bytes == NULL) {
+ * UpdateStringOfFsPath(pathPtr);
+ * }
+ * FreeFsPathInternalRep(pathPtr);
+ * pathPtr->typePtr = NULL;
+ * return Tcl_ConvertToType(interp, pathPtr, &tclFsPathType);
+ * }
+ * }
+ *
+ * But we no longer believe this is necessary.
*/
-#if 0
- if (fsPathPtr->cwdPtr == NULL) {
- return TCL_OK;
- } else {
- if (TclFSCwdPointerEquals(fsPathPtr->cwdPtr)) {
- return TCL_OK;
- } else {
- if (objPtr->bytes == NULL) {
- UpdateStringOfFsPath(objPtr);
- }
- FreeFsPathInternalRep(objPtr);
- objPtr->typePtr = NULL;
- return Tcl_ConvertToType(interp, objPtr, &tclFsPathType);
- }
- }
-#endif
} else {
- return Tcl_ConvertToType(interp, objPtr, &tclFsPathType);
+ return Tcl_ConvertToType(interp, pathPtr, &tclFsPathType);
}
}
@@ -745,9 +1044,10 @@ FindSplitPos(path, separator)
*
* TclNewFSPathObj --
*
- * Creates a path object whose string representation is
- * '[file join dirPtr addStrRep]', but does so in a way that
- * allows for more efficient caching of normalized paths.
+ * Creates a path object whose string representation is '[file join
+ * dirPtr addStrRep]', but does so in a way that allows for more
+ * efficient creation and caching of normalized paths, and more
+ * efficient 'file dirname', 'file tail', etc.
*
* Assumptions:
* 'dirPtr' must be an absolute path.
@@ -766,10 +1066,12 @@ Tcl_Obj*
TclNewFSPathObj(Tcl_Obj *dirPtr, CONST char *addStrRep, int len)
{
FsPath *fsPathPtr;
- Tcl_Obj *objPtr;
- ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&tclFsDataKey);
+ Tcl_Obj *pathPtr;
+ ThreadSpecificData *tsdPtr;
- objPtr = Tcl_NewObj();
+ tsdPtr = TCL_TSD_INIT(&tclFsDataKey);
+
+ pathPtr = Tcl_NewObj();
fsPathPtr = (FsPath*)ckalloc((unsigned)sizeof(FsPath));
if (tclPlatform == TCL_PLATFORM_MAC) {
@@ -783,7 +1085,7 @@ TclNewFSPathObj(Tcl_Obj *dirPtr, CONST char *addStrRep, int len)
addStrRep++;
len--;
}
- }
+ }
/* Setup the path */
fsPathPtr->translatedPathPtr = NULL;
fsPathPtr->normPathPtr = Tcl_NewStringObj(addStrRep, len);
@@ -794,13 +1096,13 @@ TclNewFSPathObj(Tcl_Obj *dirPtr, CONST char *addStrRep, int len)
fsPathPtr->fsRecPtr = NULL;
fsPathPtr->filesystemEpoch = tsdPtr->filesystemEpoch;
- PATHOBJ(objPtr) = (VOID *) fsPathPtr;
- PATHFLAGS(objPtr) = TCLPATH_RELATIVE | TCLPATH_APPENDED;
- objPtr->typePtr = &tclFsPathType;
- objPtr->bytes = NULL;
- objPtr->length = 0;
+ PATHOBJ(pathPtr) = (VOID *) fsPathPtr;
+ PATHFLAGS(pathPtr) = TCLPATH_APPENDED;
+ pathPtr->typePtr = &tclFsPathType;
+ pathPtr->bytes = NULL;
+ pathPtr->length = 0;
- return objPtr;
+ return pathPtr;
}
/*
@@ -808,11 +1110,17 @@ TclNewFSPathObj(Tcl_Obj *dirPtr, CONST char *addStrRep, int len)
*
* TclFSMakePathRelative --
*
- * Like SetFsPathFromAny, but assumes the given object is an
- * absolute normalized path. Only for internal use.
+ * Only for internal use.
+ *
+ * Takes a path and a directory, where we _assume_ both path and
+ * directory are absolute, normalized and that the path lies
+ * inside the directory. Returns a Tcl_Obj representing filename
+ * of the path relative to the directory.
*
* Results:
- * Standard Tcl error code.
+ * NULL on error, otherwise a valid object, typically with
+ * refCount of zero, which it is assumed the caller will
+ * increment.
*
* Side effects:
* The old representation may be freed, and new memory allocated.
@@ -821,24 +1129,24 @@ TclNewFSPathObj(Tcl_Obj *dirPtr, CONST char *addStrRep, int len)
*/
Tcl_Obj*
-TclFSMakePathRelative(interp, objPtr, cwdPtr)
+TclFSMakePathRelative(interp, pathPtr, cwdPtr)
Tcl_Interp *interp; /* Used for error reporting if not NULL. */
- Tcl_Obj *objPtr; /* The object we have. */
+ Tcl_Obj *pathPtr; /* The object we have. */
Tcl_Obj *cwdPtr; /* Make it relative to this. */
{
int cwdLen, len;
CONST char *tempStr;
ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&tclFsDataKey);
- if (objPtr->typePtr == &tclFsPathType) {
- FsPath* fsPathPtr = (FsPath*) PATHOBJ(objPtr);
- if (PATHFLAGS(objPtr) != 0
+ if (pathPtr->typePtr == &tclFsPathType) {
+ FsPath* fsPathPtr = (FsPath*) PATHOBJ(pathPtr);
+ if (PATHFLAGS(pathPtr) != 0
&& fsPathPtr->cwdPtr == cwdPtr) {
- objPtr = fsPathPtr->normPathPtr;
+ pathPtr = fsPathPtr->normPathPtr;
/* Free old representation */
- if (objPtr->typePtr != NULL) {
- if (objPtr->bytes == NULL) {
- if (objPtr->typePtr->updateStringProc == NULL) {
+ if (pathPtr->typePtr != NULL) {
+ if (pathPtr->bytes == NULL) {
+ if (pathPtr->typePtr->updateStringProc == NULL) {
if (interp != NULL) {
Tcl_ResetResult(interp);
Tcl_AppendResult(interp, "can't find object",
@@ -846,17 +1154,17 @@ TclFSMakePathRelative(interp, objPtr, cwdPtr)
}
return NULL;
}
- objPtr->typePtr->updateStringProc(objPtr);
+ pathPtr->typePtr->updateStringProc(pathPtr);
}
- if ((objPtr->typePtr->freeIntRepProc) != NULL) {
- (*objPtr->typePtr->freeIntRepProc)(objPtr);
+ if ((pathPtr->typePtr->freeIntRepProc) != NULL) {
+ (*pathPtr->typePtr->freeIntRepProc)(pathPtr);
}
}
fsPathPtr = (FsPath*)ckalloc((unsigned)sizeof(FsPath));
/* Circular reference, by design */
- fsPathPtr->translatedPathPtr = objPtr;
+ fsPathPtr->translatedPathPtr = pathPtr;
fsPathPtr->normPathPtr = NULL;
fsPathPtr->cwdPtr = cwdPtr;
Tcl_IncrRefCount(cwdPtr);
@@ -864,11 +1172,11 @@ TclFSMakePathRelative(interp, objPtr, cwdPtr)
fsPathPtr->fsRecPtr = NULL;
fsPathPtr->filesystemEpoch = tsdPtr->filesystemEpoch;
- PATHOBJ(objPtr) = (VOID *) fsPathPtr;
- PATHFLAGS(objPtr) = 0;
- objPtr->typePtr = &tclFsPathType;
+ PATHOBJ(pathPtr) = (VOID *) fsPathPtr;
+ PATHFLAGS(pathPtr) = 0;
+ pathPtr->typePtr = &tclFsPathType;
- return objPtr;
+ return pathPtr;
}
}
/*
@@ -908,7 +1216,7 @@ TclFSMakePathRelative(interp, objPtr, cwdPtr)
}
break;
}
- tempStr = Tcl_GetStringFromObj(objPtr, &len);
+ tempStr = Tcl_GetStringFromObj(pathPtr, &len);
return Tcl_NewStringObj(tempStr + cwdLen, len - cwdLen);
}
@@ -931,23 +1239,23 @@ TclFSMakePathRelative(interp, objPtr, cwdPtr)
*/
int
-TclFSMakePathFromNormalized(interp, objPtr, nativeRep)
+TclFSMakePathFromNormalized(interp, pathPtr, nativeRep)
Tcl_Interp *interp; /* Used for error reporting if not NULL. */
- Tcl_Obj *objPtr; /* The object to convert. */
+ Tcl_Obj *pathPtr; /* The object to convert. */
ClientData nativeRep; /* The native rep for the object, if known
* else NULL. */
{
FsPath *fsPathPtr;
ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&tclFsDataKey);
- if (objPtr->typePtr == &tclFsPathType) {
+ if (pathPtr->typePtr == &tclFsPathType) {
return TCL_OK;
}
/* Free old representation */
- if (objPtr->typePtr != NULL) {
- if (objPtr->bytes == NULL) {
- if (objPtr->typePtr->updateStringProc == NULL) {
+ if (pathPtr->typePtr != NULL) {
+ if (pathPtr->bytes == NULL) {
+ if (pathPtr->typePtr->updateStringProc == NULL) {
if (interp != NULL) {
Tcl_ResetResult(interp);
Tcl_AppendResult(interp, "can't find object",
@@ -955,25 +1263,26 @@ TclFSMakePathFromNormalized(interp, objPtr, nativeRep)
}
return TCL_ERROR;
}
- objPtr->typePtr->updateStringProc(objPtr);
+ pathPtr->typePtr->updateStringProc(pathPtr);
}
- if ((objPtr->typePtr->freeIntRepProc) != NULL) {
- (*objPtr->typePtr->freeIntRepProc)(objPtr);
+ if ((pathPtr->typePtr->freeIntRepProc) != NULL) {
+ (*pathPtr->typePtr->freeIntRepProc)(pathPtr);
}
}
fsPathPtr = (FsPath*)ckalloc((unsigned)sizeof(FsPath));
/* It's a pure normalized absolute path */
fsPathPtr->translatedPathPtr = NULL;
- fsPathPtr->normPathPtr = objPtr;
+ /* Circular reference by design */
+ fsPathPtr->normPathPtr = pathPtr;
fsPathPtr->cwdPtr = NULL;
fsPathPtr->nativePathPtr = nativeRep;
fsPathPtr->fsRecPtr = NULL;
fsPathPtr->filesystemEpoch = tsdPtr->filesystemEpoch;
- PATHOBJ(objPtr) = (VOID *) fsPathPtr;
- PATHFLAGS(objPtr) = 0;
- objPtr->typePtr = &tclFsPathType;
+ PATHOBJ(pathPtr) = (VOID *) fsPathPtr;
+ PATHFLAGS(pathPtr) = 0;
+ pathPtr->typePtr = &tclFsPathType;
return TCL_OK;
}
@@ -1009,15 +1318,15 @@ Tcl_FSNewNativePath(fromFilesystem, clientData)
Tcl_Filesystem* fromFilesystem;
ClientData clientData;
{
- Tcl_Obj *objPtr;
+ Tcl_Obj *pathPtr;
FsPath *fsPathPtr;
FilesystemRecord *fsFromPtr;
ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&tclFsDataKey);
- objPtr = TclFSInternalToNormalized(fromFilesystem, clientData,
+ pathPtr = TclFSInternalToNormalized(fromFilesystem, clientData,
&fsFromPtr);
- if (objPtr == NULL) {
+ if (pathPtr == NULL) {
return NULL;
}
@@ -1025,15 +1334,15 @@ Tcl_FSNewNativePath(fromFilesystem, clientData)
* Free old representation; shouldn't normally be any,
* but best to be safe.
*/
- if (objPtr->typePtr != NULL) {
- if (objPtr->bytes == NULL) {
- if (objPtr->typePtr->updateStringProc == NULL) {
+ if (pathPtr->typePtr != NULL) {
+ if (pathPtr->bytes == NULL) {
+ if (pathPtr->typePtr->updateStringProc == NULL) {
return NULL;
}
- objPtr->typePtr->updateStringProc(objPtr);
+ pathPtr->typePtr->updateStringProc(pathPtr);
}
- if ((objPtr->typePtr->freeIntRepProc) != NULL) {
- (*objPtr->typePtr->freeIntRepProc)(objPtr);
+ if ((pathPtr->typePtr->freeIntRepProc) != NULL) {
+ (*pathPtr->typePtr->freeIntRepProc)(pathPtr);
}
}
@@ -1041,18 +1350,18 @@ Tcl_FSNewNativePath(fromFilesystem, clientData)
fsPathPtr->translatedPathPtr = NULL;
/* Circular reference, by design */
- fsPathPtr->normPathPtr = objPtr;
+ fsPathPtr->normPathPtr = pathPtr;
fsPathPtr->cwdPtr = NULL;
fsPathPtr->nativePathPtr = clientData;
fsPathPtr->fsRecPtr = fsFromPtr;
fsPathPtr->fsRecPtr->fileRefCount++;
fsPathPtr->filesystemEpoch = tsdPtr->filesystemEpoch;
- PATHOBJ(objPtr) = (VOID *) fsPathPtr;
- PATHFLAGS(objPtr) = 0;
- objPtr->typePtr = &tclFsPathType;
+ PATHOBJ(pathPtr) = (VOID *) fsPathPtr;
+ PATHFLAGS(pathPtr) = 0;
+ pathPtr->typePtr = &tclFsPathType;
- return objPtr;
+ return pathPtr;
}
/*
@@ -1167,19 +1476,19 @@ Tcl_FSGetTranslatedStringPath(interp, pathPtr)
*/
Tcl_Obj*
-Tcl_FSGetNormalizedPath(interp, pathObjPtr)
+Tcl_FSGetNormalizedPath(interp, pathPtr)
Tcl_Interp *interp;
- Tcl_Obj* pathObjPtr;
+ Tcl_Obj* pathPtr;
{
FsPath *fsPathPtr;
- if (Tcl_FSConvertToPathType(interp, pathObjPtr) != TCL_OK) {
+ if (Tcl_FSConvertToPathType(interp, pathPtr) != TCL_OK) {
return NULL;
}
- fsPathPtr = (FsPath*) PATHOBJ(pathObjPtr);
+ fsPathPtr = (FsPath*) PATHOBJ(pathPtr);
- if (PATHFLAGS(pathObjPtr) != 0) {
+ if (PATHFLAGS(pathPtr) != 0) {
/*
* This is a special path object which is the result of
* something like 'file join'
@@ -1195,8 +1504,8 @@ Tcl_FSGetNormalizedPath(interp, pathObjPtr)
if (dir == NULL) {
return NULL;
}
- if (pathObjPtr->bytes == NULL) {
- UpdateStringOfFsPath(pathObjPtr);
+ if (pathPtr->bytes == NULL) {
+ UpdateStringOfFsPath(pathPtr);
}
copy = Tcl_DuplicateObj(dir);
Tcl_IncrRefCount(copy);
@@ -1268,21 +1577,21 @@ Tcl_FSGetNormalizedPath(interp, pathObjPtr)
if (clientData != NULL) {
fsPathPtr->nativePathPtr = clientData;
}
- PATHFLAGS(pathObjPtr) = 0;
+ PATHFLAGS(pathPtr) = 0;
}
/* Ensure cwd hasn't changed */
if (fsPathPtr->cwdPtr != NULL) {
- if (!TclFSCwdPointerEquals(fsPathPtr->cwdPtr)) {
- if (pathObjPtr->bytes == NULL) {
- UpdateStringOfFsPath(pathObjPtr);
+ if (!TclFSCwdPointerEquals(&fsPathPtr->cwdPtr)) {
+ if (pathPtr->bytes == NULL) {
+ UpdateStringOfFsPath(pathPtr);
}
- FreeFsPathInternalRep(pathObjPtr);
- pathObjPtr->typePtr = NULL;
- if (Tcl_ConvertToType(interp, pathObjPtr,
+ FreeFsPathInternalRep(pathPtr);
+ pathPtr->typePtr = NULL;
+ if (Tcl_ConvertToType(interp, pathPtr,
&tclFsPathType) != TCL_OK) {
return NULL;
}
- fsPathPtr = (FsPath*) PATHOBJ(pathObjPtr);
+ fsPathPtr = (FsPath*) PATHOBJ(pathPtr);
} else if (fsPathPtr->normPathPtr == NULL) {
int cwdLen;
Tcl_Obj *copy;
@@ -1319,7 +1628,7 @@ Tcl_FSGetNormalizedPath(interp, pathObjPtr)
}
break;
}
- Tcl_AppendObjToObj(copy, pathObjPtr);
+ Tcl_AppendObjToObj(copy, pathPtr);
/*
* Normalize the combined string, but only starting after
* the end of the previously normalized 'dir'. This should
@@ -1350,7 +1659,7 @@ Tcl_FSGetNormalizedPath(interp, pathObjPtr)
* action, which might loop back through here.
*/
if (path[0] != '\0') {
- Tcl_PathType type = Tcl_FSGetPathType(pathObjPtr);
+ Tcl_PathType type = Tcl_FSGetPathType(pathPtr);
if (type == TCL_PATH_RELATIVE) {
useThisCwd = Tcl_FSGetCwd(interp);
@@ -1432,21 +1741,30 @@ Tcl_FSGetNormalizedPath(interp, pathObjPtr)
fsPathPtr->nativePathPtr =
(*fsPathPtr->fsRecPtr->fsPtr->dupInternalRepProc)(clientData);
}
- if (!strcmp(Tcl_GetString(fsPathPtr->normPathPtr),
- Tcl_GetString(pathObjPtr))) {
- /*
- * The path was already normalized.
- * Get rid of the duplicate.
- */
- Tcl_DecrRefCount(fsPathPtr->normPathPtr);
+ /*
+ * Check if path is pure normalized (this can only be the case
+ * if it is an absolute path).
+ */
+ if (useThisCwd == NULL) {
+ if (!strcmp(Tcl_GetString(fsPathPtr->normPathPtr),
+ Tcl_GetString(pathPtr))) {
+ /*
+ * The path was already normalized.
+ * Get rid of the duplicate.
+ */
+ Tcl_DecrRefCount(fsPathPtr->normPathPtr);
+ /*
+ * We do *not* increment the refCount for
+ * this circular reference
+ */
+ fsPathPtr->normPathPtr = pathPtr;
+ }
+ } else {
/*
- * We do *not* increment the refCount for
- * this circular reference
+ * We just need to free an object we allocated above for
+ * relative paths (this was returned by Tcl_FSJoinToPath
+ * above), and then of course store the cwd.
*/
- fsPathPtr->normPathPtr = pathObjPtr;
- }
- if (useThisCwd != NULL) {
- /* This was returned by Tcl_FSJoinToPath above */
Tcl_DecrRefCount(absolutePath);
fsPathPtr->cwdPtr = useThisCwd;
}
@@ -1478,16 +1796,16 @@ Tcl_FSGetNormalizedPath(interp, pathObjPtr)
*/
ClientData
-Tcl_FSGetInternalRep(pathObjPtr, fsPtr)
- Tcl_Obj* pathObjPtr;
+Tcl_FSGetInternalRep(pathPtr, fsPtr)
+ Tcl_Obj* pathPtr;
Tcl_Filesystem *fsPtr;
{
FsPath* srcFsPathPtr;
- if (Tcl_FSConvertToPathType(NULL, pathObjPtr) != TCL_OK) {
+ if (Tcl_FSConvertToPathType(NULL, pathPtr) != TCL_OK) {
return NULL;
}
- srcFsPathPtr = (FsPath*) PATHOBJ(pathObjPtr);
+ srcFsPathPtr = (FsPath*) PATHOBJ(pathPtr);
/*
* We will only return the native representation for the caller's
@@ -1514,7 +1832,7 @@ Tcl_FSGetInternalRep(pathObjPtr, fsPtr)
* call the native filesystem directly. It is at least safer
* to allow this sub-optimal routing.
*/
- Tcl_FSGetFileSystemForPath(pathObjPtr);
+ Tcl_FSGetFileSystemForPath(pathPtr);
/*
* If we fail through here, then the path is probably not a
@@ -1522,7 +1840,7 @@ Tcl_FSGetInternalRep(pathObjPtr, fsPtr)
* use of the empty path "" via a direct call to one of the
* objectified interfaces (e.g. from the Tcl testsuite).
*/
- srcFsPathPtr = (FsPath*) PATHOBJ(pathObjPtr);
+ srcFsPathPtr = (FsPath*) PATHOBJ(pathPtr);
if (srcFsPathPtr->fsRecPtr == NULL) {
return NULL;
}
@@ -1536,9 +1854,9 @@ Tcl_FSGetInternalRep(pathObjPtr, fsPtr)
* which we do care about. The way we can check for this
* is we ask what filesystem this path belongs to.
*/
- Tcl_Filesystem *actualFs = Tcl_FSGetFileSystemForPath(pathObjPtr);
+ Tcl_Filesystem *actualFs = Tcl_FSGetFileSystemForPath(pathPtr);
if (actualFs == fsPtr) {
- return Tcl_FSGetInternalRep(pathObjPtr, fsPtr);
+ return Tcl_FSGetInternalRep(pathPtr, fsPtr);
}
return NULL;
}
@@ -1550,7 +1868,7 @@ Tcl_FSGetInternalRep(pathObjPtr, fsPtr)
if (proc == NULL) {
return NULL;
}
- srcFsPathPtr->nativePathPtr = (*proc)(pathObjPtr);
+ srcFsPathPtr->nativePathPtr = (*proc)(pathPtr);
}
return srcFsPathPtr->nativePathPtr;
@@ -1561,7 +1879,7 @@ Tcl_FSGetInternalRep(pathObjPtr, fsPtr)
*
* TclFSEnsureEpochOk --
*
- * This will ensure the pathObjPtr is up to date and can be
+ * This will ensure the pathPtr is up to date and can be
* converted into a "path" type, and that we are able to generate a
* complete normalized path which is used to determine the
* filesystem match.
@@ -1576,22 +1894,18 @@ Tcl_FSGetInternalRep(pathObjPtr, fsPtr)
*/
int
-TclFSEnsureEpochOk(pathObjPtr, fsPtrPtr)
- Tcl_Obj* pathObjPtr;
+TclFSEnsureEpochOk(pathPtr, fsPtrPtr)
+ Tcl_Obj* pathPtr;
Tcl_Filesystem **fsPtrPtr;
{
FsPath* srcFsPathPtr;
ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&tclFsDataKey);
- /*
- * SHOULD BE ABLE TO IMPROVE EFFICIENCY HERE.
- */
-
- if (Tcl_FSGetNormalizedPath(NULL, pathObjPtr) == NULL) {
- return TCL_ERROR;
+ if (pathPtr->typePtr != &tclFsPathType) {
+ return TCL_OK;
}
- srcFsPathPtr = (FsPath*) PATHOBJ(pathObjPtr);
+ srcFsPathPtr = (FsPath*) PATHOBJ(pathPtr);
/*
* Check if the filesystem has changed in some way since
@@ -1602,15 +1916,15 @@ TclFSEnsureEpochOk(pathObjPtr, fsPtrPtr)
* We have to discard the stale representation and
* recalculate it
*/
- if (pathObjPtr->bytes == NULL) {
- UpdateStringOfFsPath(pathObjPtr);
+ if (pathPtr->bytes == NULL) {
+ UpdateStringOfFsPath(pathPtr);
}
- FreeFsPathInternalRep(pathObjPtr);
- pathObjPtr->typePtr = NULL;
- if (SetFsPathFromAny(NULL, pathObjPtr) != TCL_OK) {
+ FreeFsPathInternalRep(pathPtr);
+ pathPtr->typePtr = NULL;
+ if (SetFsPathFromAny(NULL, pathPtr) != TCL_OK) {
return TCL_ERROR;
}
- srcFsPathPtr = (FsPath*) PATHOBJ(pathObjPtr);
+ srcFsPathPtr = (FsPath*) PATHOBJ(pathPtr);
}
/* Check whether the object is already assigned to a fs */
if (srcFsPathPtr->fsRecPtr != NULL) {
@@ -1621,16 +1935,22 @@ TclFSEnsureEpochOk(pathObjPtr, fsPtrPtr)
}
void
-TclFSSetPathDetails(pathObjPtr, fsRecPtr, clientData)
- Tcl_Obj *pathObjPtr;
+TclFSSetPathDetails(pathPtr, fsRecPtr, clientData)
+ Tcl_Obj *pathPtr;
FilesystemRecord *fsRecPtr;
ClientData clientData;
{
ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&tclFsDataKey);
- /* We assume pathObjPtr is already of the correct type */
FsPath* srcFsPathPtr;
- srcFsPathPtr = (FsPath*) PATHOBJ(pathObjPtr);
+ /* Make sure pathPtr is of the correct type */
+ if (pathPtr->typePtr != &tclFsPathType) {
+ if (SetFsPathFromAny(NULL, pathPtr) != TCL_OK) {
+ return;
+ }
+ }
+
+ srcFsPathPtr = (FsPath*) PATHOBJ(pathPtr);
srcFsPathPtr->fsRecPtr = fsRecPtr;
srcFsPathPtr->nativePathPtr = clientData;
srcFsPathPtr->filesystemEpoch = tsdPtr->filesystemEpoch;
@@ -1718,9 +2038,9 @@ Tcl_FSEqualPaths(firstPtr, secondPtr)
*/
static int
-SetFsPathFromAny(interp, objPtr)
+SetFsPathFromAny(interp, pathPtr)
Tcl_Interp *interp; /* Used for error reporting if not NULL. */
- Tcl_Obj *objPtr; /* The object to convert. */
+ Tcl_Obj *pathPtr; /* The object to convert. */
{
int len;
FsPath *fsPathPtr;
@@ -1728,7 +2048,7 @@ SetFsPathFromAny(interp, objPtr)
char *name;
ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&tclFsDataKey);
- if (objPtr->typePtr == &tclFsPathType) {
+ if (pathPtr->typePtr == &tclFsPathType) {
return TCL_OK;
}
@@ -1747,7 +2067,7 @@ SetFsPathFromAny(interp, objPtr)
* or MacOS (fCmd.test, fileName.test and cmdAH.test exercise
* most of the code).
*/
- name = Tcl_GetStringFromObj(objPtr,&len);
+ name = Tcl_GetStringFromObj(pathPtr,&len);
/*
* Handle tilde substitutions, if needed.
@@ -1818,7 +2138,7 @@ SetFsPathFromAny(interp, objPtr)
int objc;
Tcl_Obj **objv;
- Tcl_Obj *parts = TclpNativeSplitPath(objPtr, NULL);
+ Tcl_Obj *parts = TclpNativeSplitPath(pathPtr, NULL);
Tcl_ListObjGetElements(NULL, parts, &objc, &objv);
/* Skip '~'. It's replaced by its expansion */
objc--; objv++;
@@ -1827,14 +2147,23 @@ SetFsPathFromAny(interp, objPtr)
}
Tcl_DecrRefCount(parts);
} else {
- /* Simple case. "rest" is relative path. Just join it. */
+ /*
+ * Simple case. "rest" is relative path. Just join it.
+ * The "rest" object will be freed when
+ * Tcl_FSJoinToPath returns (unless something else
+ * claims a refCount on it).
+ */
+ Tcl_Obj *joined;
Tcl_Obj *rest = Tcl_NewStringObj(name+split+1,-1);
- transPtr = Tcl_FSJoinToPath(transPtr, 1, &rest);
+ Tcl_IncrRefCount(transPtr);
+ joined = Tcl_FSJoinToPath(transPtr, 1, &rest);
+ Tcl_DecrRefCount(transPtr);
+ transPtr = joined;
}
}
Tcl_DStringFree(&temp);
} else {
- transPtr = Tcl_FSJoinToPath(objPtr,0,NULL);
+ transPtr = Tcl_FSJoinToPath(pathPtr,0,NULL);
}
#if defined(__CYGWIN__) && defined(__WIN32__)
@@ -1866,7 +2195,9 @@ SetFsPathFromAny(interp, objPtr)
fsPathPtr = (FsPath*)ckalloc((unsigned)sizeof(FsPath));
fsPathPtr->translatedPathPtr = transPtr;
- Tcl_IncrRefCount(fsPathPtr->translatedPathPtr);
+ if (transPtr != pathPtr) {
+ Tcl_IncrRefCount(fsPathPtr->translatedPathPtr);
+ }
fsPathPtr->normPathPtr = NULL;
fsPathPtr->cwdPtr = NULL;
fsPathPtr->nativePathPtr = NULL;
@@ -1876,29 +2207,29 @@ SetFsPathFromAny(interp, objPtr)
/*
* Free old representation before installing our new one.
*/
- if (objPtr->typePtr != NULL && objPtr->typePtr->freeIntRepProc != NULL) {
- (objPtr->typePtr->freeIntRepProc)(objPtr);
+ if (pathPtr->typePtr != NULL && pathPtr->typePtr->freeIntRepProc != NULL) {
+ (pathPtr->typePtr->freeIntRepProc)(pathPtr);
}
- PATHOBJ(objPtr) = (VOID *) fsPathPtr;
- PATHFLAGS(objPtr) = 0;
- objPtr->typePtr = &tclFsPathType;
+ PATHOBJ(pathPtr) = (VOID *) fsPathPtr;
+ PATHFLAGS(pathPtr) = 0;
+ pathPtr->typePtr = &tclFsPathType;
return TCL_OK;
}
static void
-FreeFsPathInternalRep(pathObjPtr)
- Tcl_Obj *pathObjPtr; /* Path object with internal rep to free. */
+FreeFsPathInternalRep(pathPtr)
+ Tcl_Obj *pathPtr; /* Path object with internal rep to free. */
{
- FsPath* fsPathPtr = (FsPath*) PATHOBJ(pathObjPtr);
+ FsPath* fsPathPtr = (FsPath*) PATHOBJ(pathPtr);
if (fsPathPtr->translatedPathPtr != NULL) {
- if (fsPathPtr->translatedPathPtr != pathObjPtr) {
+ if (fsPathPtr->translatedPathPtr != pathPtr) {
Tcl_DecrRefCount(fsPathPtr->translatedPathPtr);
}
}
if (fsPathPtr->normPathPtr != NULL) {
- if (fsPathPtr->normPathPtr != pathObjPtr) {
+ if (fsPathPtr->normPathPtr != pathPtr) {
Tcl_DecrRefCount(fsPathPtr->normPathPtr);
}
fsPathPtr->normPathPtr = NULL;
@@ -1926,7 +2257,6 @@ FreeFsPathInternalRep(pathObjPtr)
ckfree((char*) fsPathPtr);
}
-
static void
DupFsPathInternalRep(srcPtr, copyPtr)
Tcl_Obj *srcPtr; /* Path obj with internal rep to copy. */
@@ -2004,15 +2334,15 @@ DupFsPathInternalRep(srcPtr, copyPtr)
*/
static void
-UpdateStringOfFsPath(objPtr)
- register Tcl_Obj *objPtr; /* path obj with string rep to update. */
+UpdateStringOfFsPath(pathPtr)
+ register Tcl_Obj *pathPtr; /* path obj with string rep to update. */
{
- FsPath* fsPathPtr = (FsPath*) PATHOBJ(objPtr);
+ FsPath* fsPathPtr = (FsPath*) PATHOBJ(pathPtr);
CONST char *cwdStr;
int cwdLen;
Tcl_Obj *copy;
- if (PATHFLAGS(objPtr) == 0 || fsPathPtr->cwdPtr == NULL) {
+ if (PATHFLAGS(pathPtr) == 0 || fsPathPtr->cwdPtr == NULL) {
Tcl_Panic("Called UpdateStringOfFsPath with invalid object");
}
@@ -2055,8 +2385,8 @@ UpdateStringOfFsPath(objPtr)
break;
}
Tcl_AppendObjToObj(copy, fsPathPtr->normPathPtr);
- objPtr->bytes = Tcl_GetStringFromObj(copy, &cwdLen);
- objPtr->length = cwdLen;
+ pathPtr->bytes = Tcl_GetStringFromObj(copy, &cwdLen);
+ pathPtr->length = cwdLen;
copy->bytes = tclEmptyStringRep;
copy->length = 0;
Tcl_DecrRefCount(copy);
diff --git a/generic/tclStubInit.c b/generic/tclStubInit.c
index 737ab3b..098a44c 100644
--- a/generic/tclStubInit.c
+++ b/generic/tclStubInit.c
@@ -8,7 +8,7 @@
* See the file "license.terms" for information on usage and redistribution
* of this file, and for a DISCLAIMER OF ALL WARRANTIES.
*
- * RCS: @(#) $Id: tclStubInit.c,v 1.91 2003/12/15 00:49:38 davygrvy Exp $
+ * RCS: @(#) $Id: tclStubInit.c,v 1.92 2004/01/21 19:59:33 vincentdarley Exp $
*/
#include "tclInt.h"
@@ -99,7 +99,7 @@ TclIntStubs tclIntStubs = {
TclCreateProc, /* 10 */
TclDeleteCompiledLocalVars, /* 11 */
TclDeleteVars, /* 12 */
- TclDoGlob, /* 13 */
+ NULL, /* 13 */
TclDumpMemoryInfo, /* 14 */
NULL, /* 15 */
TclExprFloatError, /* 16 */
diff --git a/generic/tclTest.c b/generic/tclTest.c
index 71c08a5..7c9361d 100644
--- a/generic/tclTest.c
+++ b/generic/tclTest.c
@@ -14,7 +14,7 @@
* See the file "license.terms" for information on usage and redistribution
* of this file, and for a DISCLAIMER OF ALL WARRANTIES.
*
- * RCS: @(#) $Id: tclTest.c,v 1.74 2003/12/24 04:18:20 davygrvy Exp $
+ * RCS: @(#) $Id: tclTest.c,v 1.75 2004/01/21 19:59:33 vincentdarley Exp $
*/
#define TCL_TEST
@@ -365,7 +365,7 @@ static void TestReport _ANSI_ARGS_ ((CONST char* cmd, Tcl_Obj* arg1,
Tcl_Obj* arg2));
static Tcl_Obj* TestReportGetNativePath _ANSI_ARGS_ ((
- Tcl_Obj* pathObjPtr));
+ Tcl_Obj* pathPtr));
static int TestReportStat _ANSI_ARGS_ ((Tcl_Obj *path,
Tcl_StatBuf *buf));
@@ -6054,8 +6054,8 @@ TestReportInFilesystem(Tcl_Obj *pathPtr, ClientData *clientDataPtr)
* path object, or NULL if no such representation exists.
*/
static Tcl_Obj*
-TestReportGetNativePath(Tcl_Obj* pathObjPtr) {
- return (Tcl_Obj*) Tcl_FSGetInternalRep(pathObjPtr, &testReportingFilesystem);
+TestReportGetNativePath(Tcl_Obj* pathPtr) {
+ return (Tcl_Obj*) Tcl_FSGetInternalRep(pathPtr, &testReportingFilesystem);
}
static void
diff --git a/mac/tclMacFile.c b/mac/tclMacFile.c
index be89237..1c1279d 100644
--- a/mac/tclMacFile.c
+++ b/mac/tclMacFile.c
@@ -10,7 +10,7 @@
* See the file "license.terms" for information on usage and redistribution
* of this file, and for a DISCLAIMER OF ALL WARRANTIES.
*
- * RCS: @(#) $Id: tclMacFile.c,v 1.28 2003/10/13 16:48:07 vincentdarley Exp $
+ * RCS: @(#) $Id: tclMacFile.c,v 1.29 2004/01/21 19:59:33 vincentdarley Exp $
*/
/*
@@ -583,11 +583,73 @@ TclpObjChdir(pathPtr)
}
/*
+ *---------------------------------------------------------------------------
+ *
+ * TclpGetNativeCwd --
+ *
+ * This function replaces the library version of getcwd().
+ *
+ * Results:
+ * The input and output are filesystem paths in native form. The
+ * result is either the given clientData, if the working directory
+ * hasn't changed, or a new clientData (owned by our caller),
+ * giving the new native path, or NULL if the current directory
+ * could not be determined. If NULL is returned, the caller can
+ * examine the standard posix error codes to determine the cause of
+ * the problem.
+ *
+ * Side effects:
+ * None.
+ *
+ *----------------------------------------------------------------------
+ */
+
+ClientData
+TclpGetNativeCwd(clientData)
+ ClientData clientData;
+{
+ FSSpec theSpec;
+ int length;
+ Handle pathHandle = NULL;
+ OSErr err;
+
+ err = FSpGetDefaultDir(&theSpec);
+ if (err != noErr) {
+ errno = TclMacOSErrorToPosixError(err);
+ return NULL;
+ }
+ err = FSpPathFromLocation(&theSpec, &length, &pathHandle);
+ if (err != noErr) {
+ errno = TclMacOSErrorToPosixError(err);
+ return NULL;
+ }
+
+ if ((clientData != NULL)
+ && strcmp((CONST char*)(*pathHandle), (CONST char*)clientData) == 0) {
+ /* No change to pwd */
+ DisposeHandle(pathHandle);
+ return clientData;
+ } else {
+ char *newCd;
+
+ HLock(pathHandle);
+ newCd = (char *) ckalloc((unsigned)
+ (strlen((CONST char*)(*pathHandle)) + 1));
+ strcpy(newCd, (CONST char*)(*pathHandle));
+ HUnlock(pathHandle);
+ DisposeHandle(pathHandle);
+ return (ClientData) newCd;
+ }
+}
+
+/*
*----------------------------------------------------------------------
*
- * TclpObjGetCwd --
+ * TclpGetCwd --
*
* This function replaces the library version of getcwd().
+ * (Obsolete function, only retained for old extensions which
+ * may call it directly).
*
* Results:
* The result is a pointer to a string specifying the current
@@ -603,21 +665,6 @@ TclpObjChdir(pathPtr)
*----------------------------------------------------------------------
*/
-Tcl_Obj*
-TclpObjGetCwd(interp)
- Tcl_Interp *interp;
-{
- Tcl_DString ds;
- if (TclpGetCwd(interp, &ds) != NULL) {
- Tcl_Obj *cwdPtr = Tcl_NewStringObj(Tcl_DStringValue(&ds), -1);
- Tcl_IncrRefCount(cwdPtr);
- Tcl_DStringFree(&ds);
- return cwdPtr;
- } else {
- return NULL;
- }
-}
-
CONST char *
TclpGetCwd(
Tcl_Interp *interp, /* If non-NULL, used for error reporting. */
@@ -1242,8 +1289,8 @@ TclpObjLink(pathPtr, toPtr, linkAction)
*---------------------------------------------------------------------------
*/
Tcl_Obj*
-TclpFilesystemPathType(pathObjPtr)
- Tcl_Obj* pathObjPtr;
+TclpFilesystemPathType(pathPtr)
+ Tcl_Obj* pathPtr;
{
/* All native paths are of the same type */
return NULL;
diff --git a/tests/fCmd.test b/tests/fCmd.test
index c0f6948..79050a6 100644
--- a/tests/fCmd.test
+++ b/tests/fCmd.test
@@ -10,7 +10,7 @@
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
#
-# RCS: @(#) $Id: fCmd.test,v 1.35 2003/12/17 17:47:28 vincentdarley Exp $
+# RCS: @(#) $Id: fCmd.test,v 1.36 2004/01/21 19:59:33 vincentdarley Exp $
#
if {[lsearch [namespace children] ::tcltest] == -1} {
@@ -513,7 +513,7 @@ test fCmd-6.19 {CopyRenameOneFile: errno == EXDEV} {unixOnly notRoot} {
cleanup /tmp
createfile tf1
file rename tf1 /tmp
- glob tf* /tmp/tf1
+ glob -nocomplain tf* /tmp/tf1
} {/tmp/tf1}
test fCmd-6.20 {CopyRenameOneFile: errno == EXDEV} {pcOnly} {
catch {file delete -force c:/tcl8975@ d:/tcl8975@}
@@ -532,14 +532,14 @@ test fCmd-6.21 {CopyRenameOneFile: copy/rename: S_ISDIR(source)} \
cleanup /tmp
file mkdir td1
file rename td1 /tmp
- glob td* /tmp/td*
+ glob -nocomplain td* /tmp/td*
} {/tmp/td1}
test fCmd-6.22 {CopyRenameOneFile: copy/rename: !S_ISDIR(source)} \
{unixOnly notRoot} {
cleanup /tmp
createfile tf1
file rename tf1 /tmp
- glob tf* /tmp/tf*
+ glob -nocomplain tf* /tmp/tf*
} {/tmp/tf1}
test fCmd-6.23 {CopyRenameOneFile: TclpCopyDirectory failed} \
{unixOnly notRoot xdev} {
diff --git a/tests/fileName.test b/tests/fileName.test
index 1a636c6..ea9f294 100644
--- a/tests/fileName.test
+++ b/tests/fileName.test
@@ -10,7 +10,7 @@
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
#
-# RCS: @(#) $Id: fileName.test,v 1.34 2003/12/12 17:02:51 vincentdarley Exp $
+# RCS: @(#) $Id: fileName.test,v 1.35 2004/01/21 19:59:33 vincentdarley Exp $
if {[lsearch [namespace children] ::tcltest] == -1} {
package require tcltest
@@ -1001,6 +1001,10 @@ test filename-10.3 {Tcl_TranslateFileName} {testsetplatform} {
testsetplatform windows
list [catch {testtranslatefilename {c:/\\foo/}} msg] $msg
} {0 {c:\foo}}
+test filename-10.3.1 {Tcl_TranslateFileName} {testsetplatform} {
+ testsetplatform windows
+ list [catch {testtranslatefilename {c://///}} msg] $msg
+} {0 c:\\}
test filename-10.4 {Tcl_TranslateFileName} {testsetplatform} {
testsetplatform mac
list [catch {testtranslatefilename foo} msg] $msg
@@ -1584,7 +1588,11 @@ test filename-11.45 {Tcl_GlobCmd on root volume} {
set res2 [glob *]
cd $tmpd
}
- expr {$res1 == $res2}
+ set res [expr {$res1 == $res2}]
+ if {!$res} {
+ lappend res $res1 $res2
+ }
+ set res
} {1}
test filename-11.46 {Tcl_GlobCmd} {
list [catch {glob -types abcde -dir foo *} msg] $msg
@@ -1873,7 +1881,7 @@ test filename-15.4.1 {no complain: no errors, good result} {
test filename-15.5 {unix specific globbing} {unixOnly nonPortable} {
glob ~ouster/.csh*
} "/home/ouster/.cshrc"
-catch {close [open globTest/odd\\\[\]*?\{\}name w]}
+catch {close [open globTest/odd\\\[\]*?\{\}name w]}
test filename-15.6 {unix specific globbing} {unixOnly} {
global env
set temp $env(HOME)
@@ -1883,6 +1891,23 @@ test filename-15.6 {unix specific globbing} {unixOnly} {
set result
} [list 0 [list [lindex [glob ~] 0]/globTest/odd\\\[\]*?\{\}name]]
catch {file delete -force globTest/odd\\\[\]*?\{\}name}
+test filename-15.7 {win specific globbing} {winOnly} {
+ if {[string index [glob ~] end] == "/"} {
+ set res "glob ~ is [glob ~] but shouldn't end in a separator"
+ } else {
+ set res "ok"
+ }
+} {ok}
+test filename-15.8 {win and unix specific globbing} {unixOrWin} {
+ global env
+ set temp $env(HOME)
+ catch {close [open $env(HOME)/globTest/anyname w]} err
+ set env(HOME) $env(HOME)/globTest/anyname
+ set result [list [catch {glob ~} msg] $msg]
+ set env(HOME) $temp
+ catch {file delete -force $env(HOME)/globTest/anyname}
+ set result
+} [list 0 [list [lindex [glob ~] 0]/globTest/anyname]]
# The following tests are only valid for Windows systems.
set oldDir [pwd]
@@ -1909,31 +1934,31 @@ test filename-16.2.1 {windows specific globbing} {pcOnly} {
set res
} {0 c:}
test filename-16.3 {windows specific globbing} {pcOnly} {
- glob c:\\\\
+ glob -nocomplain c:\\\\
} c:/
test filename-16.4 {windows specific globbing} {pcOnly} {
- glob c:/
+ glob -nocomplain c:/
} c:/
test filename-16.5 {windows specific globbing} {pcOnly} {
- glob c:*bTest
+ glob -nocomplain c:*bTest
} c:globTest
test filename-16.6 {windows specific globbing} {pcOnly} {
- glob c:\\\\*bTest
+ glob -nocomplain c:\\\\*bTest
} c:/globTest
test filename-16.7 {windows specific globbing} {pcOnly} {
- glob c:/*bTest
+ glob -nocomplain c:/*bTest
} c:/globTest
test filename-16.8 {windows specific globbing} {pcOnly} {
- lsort [glob c:globTest/*.bat]
+ lsort [glob -nocomplain c:globTest/*.bat]
} {c:globTest/x1.BAT c:globTest/y1.Bat c:globTest/z1.bat}
test filename-16.9 {windows specific globbing} {pcOnly} {
- lsort [glob c:/globTest/*.bat]
+ lsort [glob -nocomplain c:/globTest/*.bat]
} {c:/globTest/x1.BAT c:/globTest/y1.Bat c:/globTest/z1.bat}
test filename-16.10 {windows specific globbing} {pcOnly} {
- lsort [glob c:globTest\\\\*.bat]
+ lsort [glob -nocomplain c:globTest\\\\*.bat]
} {c:globTest/x1.BAT c:globTest/y1.Bat c:globTest/z1.bat}
test filename-16.11 {windows specific globbing} {pcOnly} {
- lsort [glob c:\\\\globTest\\\\*.bat]
+ lsort [glob -nocomplain c:\\\\globTest\\\\*.bat]
} {c:/globTest/x1.BAT c:/globTest/y1.Bat c:/globTest/z1.bat}
# some tests require a shared C drive
@@ -1961,7 +1986,7 @@ test filename-16.15 {windows specific globbing} {pcOnly} {
glob ..
} {..}
test filename-16.16 {windows specific globbing} {pcOnly} {
- file tail [lindex [glob "[lindex [glob -types d -dir C:/ *] 0]/.."] 0]
+ file tail [lindex [glob -nocomplain "[lindex [glob -types d -dir C:/ *] 0]/.."] 0]
} {..}
test filename-17.1 {windows specific special files} {testsetplatform} {
diff --git a/tests/fileSystem.test b/tests/fileSystem.test
index 91a468f..69db7f6 100644
--- a/tests/fileSystem.test
+++ b/tests/fileSystem.test
@@ -358,7 +358,7 @@ test filesystem-4.0 {testfilesystem} {
testfilesystem 0
set filesystemReport
}
- -result {* {access foo}}
+ -result {*{access foo}}
}
test filesystem-4.1 {testfilesystem} {
@@ -371,7 +371,7 @@ test filesystem-4.1 {testfilesystem} {
testfilesystem 0
set filesystemReport
}
- -result {* {stat foo}}
+ -result {*{stat foo}}
}
test filesystem-4.2 {testfilesystem} {
@@ -384,7 +384,7 @@ test filesystem-4.2 {testfilesystem} {
testfilesystem 0
set filesystemReport
}
- -result {* {lstat foo}}
+ -result {*{lstat foo}}
}
test filesystem-4.3 {testfilesystem} {
@@ -397,7 +397,7 @@ test filesystem-4.3 {testfilesystem} {
testfilesystem 0
set filesystemReport
}
- -result {* {matchindirectory *}*}
+ -result {*{matchindirectory *}*}
}
test filesystem-5.1 {cache and ~} {
diff --git a/tests/winFCmd.test b/tests/winFCmd.test
index 5f0ff6a..6fc58a8 100644
--- a/tests/winFCmd.test
+++ b/tests/winFCmd.test
@@ -10,7 +10,7 @@
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
#
-# RCS: @(#) $Id: winFCmd.test,v 1.25 2003/12/09 14:57:18 vincentdarley Exp $
+# RCS: @(#) $Id: winFCmd.test,v 1.26 2004/01/21 19:59:34 vincentdarley Exp $
#
if {[lsearch [namespace children] ::tcltest] == -1} {
@@ -610,7 +610,7 @@ test winFCmd-6.11 {TclpRemoveDirectory: attr == -1} {pcOnly nt} {
# WinXP returns EEXIST, WinNT seems to return EACCES. No policy
# decision has been made as to which is correct.
regsub {E(ACCES|EXIST)} $res "EACCES or EEXIST"
-} [list 1 [list [file norm /] EACCES or EEXIST]]
+} [list 1 [list / EACCES or EEXIST]]
test winFCmd-6.12 {TclpRemoveDirectory: errno == EACCES} {pcOnly 95} {
cleanup
createfile tf1
diff --git a/unix/tclUnixFile.c b/unix/tclUnixFile.c
index 96d2fda..23837a0 100644
--- a/unix/tclUnixFile.c
+++ b/unix/tclUnixFile.c
@@ -9,7 +9,7 @@
* See the file "license.terms" for information on usage and redistribution
* of this file, and for a DISCLAIMER OF ALL WARRANTIES.
*
- * RCS: @(#) $Id: tclUnixFile.c,v 1.36 2003/12/17 17:47:28 vincentdarley Exp $
+ * RCS: @(#) $Id: tclUnixFile.c,v 1.37 2004/01/21 19:59:34 vincentdarley Exp $
*/
#include "tclInt.h"
@@ -571,11 +571,59 @@ TclpObjLstat(pathPtr, bufPtr)
/*
*---------------------------------------------------------------------------
*
- * TclpObjGetCwd --
+ * TclpGetNativeCwd --
*
* This function replaces the library version of getcwd().
*
* Results:
+ * The input and output are filesystem paths in native form. The
+ * result is either the given clientData, if the working directory
+ * hasn't changed, or a new clientData (owned by our caller),
+ * giving the new native path, or NULL if the current directory
+ * could not be determined. If NULL is returned, the caller can
+ * examine the standard posix error codes to determine the cause of
+ * the problem.
+ *
+ * Side effects:
+ * None.
+ *
+ *----------------------------------------------------------------------
+ */
+
+ClientData
+TclpGetNativeCwd(clientData)
+ ClientData clientData;
+{
+ char buffer[MAXPATHLEN+1];
+
+#ifdef USEGETWD
+ if (getwd(buffer) == NULL) { /* INTL: Native. */
+#else
+ if (getcwd(buffer, MAXPATHLEN + 1) == NULL) { /* INTL: Native. */
+#endif
+ return NULL;
+ }
+ if ((clientData != NULL) && strcmp(buffer, (CONST char*)clientData) == 0) {
+ /* No change to pwd */
+ return clientData;
+ } else {
+ char *newCd = (char *) ckalloc((unsigned)
+ (strlen(buffer) + 1));
+ strcpy(newCd, buffer);
+ return (ClientData) newCd;
+ }
+}
+
+/*
+ *---------------------------------------------------------------------------
+ *
+ * TclpGetCwd --
+ *
+ * This function replaces the library version of getcwd().
+ * (Obsolete function, only retained for old extensions which
+ * may call it directly).
+ *
+ * Results:
* The result is a pointer to a string specifying the current
* directory, or NULL if the current directory could not be
* determined. If NULL is returned, an error message is left in the
@@ -589,22 +637,6 @@ TclpObjLstat(pathPtr, bufPtr)
*----------------------------------------------------------------------
*/
-Tcl_Obj*
-TclpObjGetCwd(interp)
- Tcl_Interp *interp;
-{
- Tcl_DString ds;
- if (TclpGetCwd(interp, &ds) != NULL) {
- Tcl_Obj *cwdPtr = Tcl_NewStringObj(Tcl_DStringValue(&ds), -1);
- Tcl_IncrRefCount(cwdPtr);
- Tcl_DStringFree(&ds);
- return cwdPtr;
- } else {
- return NULL;
- }
-}
-
-/* Older string based version */
CONST char *
TclpGetCwd(interp, bufferPtr)
Tcl_Interp *interp; /* If non-NULL, used for error reporting. */
@@ -730,7 +762,7 @@ TclpObjLink(pathPtr, toPtr, linkAction)
if ((linkAction & TCL_CREATE_SYMBOLIC_LINK)
&& (Tcl_FSGetPathType(toPtr) == TCL_PATH_RELATIVE)) {
Tcl_Obj *dirPtr, *absPtr;
- dirPtr = TclFileDirname(NULL, pathPtr);
+ dirPtr = TclPathPart(NULL, pathPtr, TCL_PATH_DIRNAME);
if (dirPtr == NULL) {
return NULL;
}
@@ -852,8 +884,8 @@ TclpObjLink(pathPtr, toPtr, linkAction)
*---------------------------------------------------------------------------
*/
Tcl_Obj*
-TclpFilesystemPathType(pathObjPtr)
- Tcl_Obj* pathObjPtr;
+TclpFilesystemPathType(pathPtr)
+ Tcl_Obj* pathPtr;
{
/* All native paths are of the same type */
return NULL;
diff --git a/win/tclWin32Dll.c b/win/tclWin32Dll.c
index 2bccd07..4a5aefd 100644
--- a/win/tclWin32Dll.c
+++ b/win/tclWin32Dll.c
@@ -9,7 +9,7 @@
* See the file "license.terms" for information on usage and redistribution
* of this file, and for a DISCLAIMER OF ALL WARRANTIES.
*
- * RCS: @(#) $Id: tclWin32Dll.c,v 1.31 2003/12/26 04:12:16 mdejong Exp $
+ * RCS: @(#) $Id: tclWin32Dll.c,v 1.32 2004/01/21 19:59:34 vincentdarley Exp $
*/
#include "tclWinInt.h"
@@ -648,6 +648,10 @@ TclWinSetInterfaces(
(BOOL (WINAPI *)(CONST TCHAR*, TCHAR*,
DWORD)) GetProcAddress(hInstance,
"GetVolumeNameForVolumeMountPointW");
+ tclWinProcs->getLongPathNameProc =
+ (DWORD (WINAPI *)(CONST TCHAR*, TCHAR*,
+ DWORD)) GetProcAddress(hInstance,
+ "GetLongPathNameW");
FreeLibrary(hInstance);
}
hInstance = LoadLibraryA("advapi32");
@@ -696,6 +700,7 @@ TclWinSetInterfaces(
LPSECURITY_ATTRIBUTES)) GetProcAddress(hInstance,
"CreateHardLinkA");
tclWinProcs->findFirstFileExProc = NULL;
+ tclWinProcs->getLongPathNameProc = NULL;
/*
* The 'findFirstFileExProc' function exists on some
* of 95/98/ME, but it seems not to work as anticipated.
diff --git a/win/tclWinFCmd.c b/win/tclWinFCmd.c
index 1062a3f..f78f053 100644
--- a/win/tclWinFCmd.c
+++ b/win/tclWinFCmd.c
@@ -9,7 +9,7 @@
* See the file "license.terms" for information on usage and redistribution
* of this file, and for a DISCLAIMER OF ALL WARRANTIES.
*
- * RCS: @(#) $Id: tclWinFCmd.c,v 1.39 2003/12/24 04:18:22 davygrvy Exp $
+ * RCS: @(#) $Id: tclWinFCmd.c,v 1.40 2004/01/21 19:59:34 vincentdarley Exp $
*/
#include "tclWinInt.h"
@@ -1593,10 +1593,9 @@ ConvertFileNameFormat(
{
int pathc, i;
Tcl_Obj *splitPath;
- int result = TCL_OK;
splitPath = Tcl_FSSplitPath(fileName, &pathc);
-
+
if (splitPath == NULL || pathc == 0) {
if (interp != NULL) {
Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
@@ -1604,10 +1603,16 @@ ConvertFileNameFormat(
"\": no such file or directory",
(char *) NULL);
}
- result = TCL_ERROR;
goto cleanup;
}
+ /*
+ * We will decrement this again at the end. It is safer to
+ * do this in case any of the calls below retain a reference
+ * to splitPath.
+ */
+ Tcl_IncrRefCount(splitPath);
+
for (i = 0; i < pathc; i++) {
Tcl_Obj *elt;
char *pathv;
@@ -1672,7 +1677,6 @@ ConvertFileNameFormat(
if (interp != NULL) {
StatError(interp, fileName);
}
- result = TCL_ERROR;
goto cleanup;
}
if (tclWinProcs->useWide) {
@@ -1730,13 +1734,27 @@ ConvertFileNameFormat(
}
*attributePtrPtr = Tcl_FSJoinPath(splitPath, -1);
+
+ if (splitPath != NULL) {
+ /*
+ * Unfortunately, the object we will return may have its only
+ * refCount as part of the list splitPath. This means if
+ * we free splitPath, the object will disappear. So, we
+ * have to be very careful here. Unfortunately this means
+ * we must manipulate the object's refCount directly.
+ */
+ Tcl_IncrRefCount(*attributePtrPtr);
+ Tcl_DecrRefCount(splitPath);
+ --(*attributePtrPtr)->refCount;
+ }
+ return TCL_OK;
-cleanup:
+ cleanup:
if (splitPath != NULL) {
Tcl_DecrRefCount(splitPath);
}
- return result;
+ return TCL_ERROR;
}
/*
diff --git a/win/tclWinFile.c b/win/tclWinFile.c
index a000802..12fad95 100644
--- a/win/tclWinFile.c
+++ b/win/tclWinFile.c
@@ -11,7 +11,7 @@
* See the file "license.terms" for information on usage and redistribution
* of this file, and for a DISCLAIMER OF ALL WARRANTIES.
*
- * RCS: @(#) $Id: tclWinFile.c,v 1.58 2003/12/16 02:55:38 davygrvy Exp $
+ * RCS: @(#) $Id: tclWinFile.c,v 1.59 2004/01/21 19:59:34 vincentdarley Exp $
*/
//#define _WIN32_WINNT 0x0500
@@ -1626,6 +1626,8 @@ TclpReadlink(path, linkPtr)
* TclpGetCwd --
*
* This function replaces the library version of getcwd().
+ * (Obsolete function, only retained for old extensions which
+ * may call it directly).
*
* Results:
* The result is a pointer to a string specifying the current
@@ -2090,19 +2092,56 @@ TclWinResolveShortcut(bufferPtr)
}
#endif
-Tcl_Obj*
-TclpObjGetCwd(interp)
- Tcl_Interp *interp;
+/*
+ *---------------------------------------------------------------------------
+ *
+ * TclpGetNativeCwd --
+ *
+ * This function replaces the library version of getcwd().
+ *
+ * Results:
+ * The input and output are filesystem paths in native form. The
+ * result is either the given clientData, if the working directory
+ * hasn't changed, or a new clientData (owned by our caller),
+ * giving the new native path, or NULL if the current directory
+ * could not be determined. If NULL is returned, the caller can
+ * examine the standard posix error codes to determine the cause of
+ * the problem.
+ *
+ * Side effects:
+ * None.
+ *
+ *----------------------------------------------------------------------
+ */
+
+ClientData
+TclpGetNativeCwd(clientData)
+ ClientData clientData;
{
- Tcl_DString ds;
- if (TclpGetCwd(interp, &ds) != NULL) {
- Tcl_Obj *cwdPtr = Tcl_NewStringObj(Tcl_DStringValue(&ds), -1);
- Tcl_IncrRefCount(cwdPtr);
- Tcl_DStringFree(&ds);
- return cwdPtr;
- } else {
+ WCHAR buffer[MAX_PATH];
+
+ if ((*tclWinProcs->getCurrentDirectoryProc)(MAX_PATH, buffer) == 0) {
+ TclWinConvertError(GetLastError());
return NULL;
}
+
+ if (clientData != NULL) {
+ if (tclWinProcs->useWide) {
+ /* unicode representation when running on NT/2K/XP */
+ if (wcscmp((CONST WCHAR*)clientData,
+ (CONST WCHAR*)buffer) == 0) {
+ return clientData;
+ }
+ } else {
+ /* ansi representation when running on 95/98/ME */
+ if (strcmp((CONST char*)clientData,
+ (CONST char*)buffer) == 0) {
+ return clientData;
+ }
+ }
+ }
+
+ return TclNativeDupInternalRep((ClientData)buffer);
}
int
@@ -2139,7 +2178,11 @@ TclpObjLink(pathPtr, toPtr, linkAction)
{
if (toPtr != NULL) {
int res;
+#if 0
TCHAR* LinkTarget = (TCHAR*)Tcl_FSGetNativePath(toPtr);
+#else
+ TCHAR* LinkTarget = (TCHAR*)Tcl_FSGetNativePath(Tcl_FSGetNormalizedPath(NULL,toPtr));
+#endif
TCHAR* LinkSource = (TCHAR*)Tcl_FSGetNativePath(pathPtr);
if (LinkSource == NULL || LinkTarget == NULL) {
return NULL;
@@ -2180,8 +2223,8 @@ TclpObjLink(pathPtr, toPtr, linkAction)
*---------------------------------------------------------------------------
*/
Tcl_Obj*
-TclpFilesystemPathType(pathObjPtr)
- Tcl_Obj* pathObjPtr;
+TclpFilesystemPathType(pathPtr)
+ Tcl_Obj* pathPtr;
{
#define VOL_BUF_SIZE 32
int found;
@@ -2189,7 +2232,7 @@ TclpFilesystemPathType(pathObjPtr)
char* firstSeparator;
CONST char *path;
- Tcl_Obj *normPath = Tcl_FSGetNormalizedPath(NULL, pathObjPtr);
+ Tcl_Obj *normPath = Tcl_FSGetNormalizedPath(NULL, pathPtr);
if (normPath == NULL) return NULL;
path = Tcl_GetString(normPath);
if (path == NULL) return NULL;
@@ -2197,7 +2240,7 @@ TclpFilesystemPathType(pathObjPtr)
firstSeparator = strchr(path, '/');
if (firstSeparator == NULL) {
found = tclWinProcs->getVolumeInformationProc(
- Tcl_FSGetNativePath(pathObjPtr), NULL, 0, NULL, NULL,
+ Tcl_FSGetNativePath(pathPtr), NULL, 0, NULL, NULL,
NULL, (WCHAR *)volType, VOL_BUF_SIZE);
} else {
Tcl_Obj *driveName = Tcl_NewStringObj(path, firstSeparator - path+1);
@@ -2221,7 +2264,20 @@ TclpFilesystemPathType(pathObjPtr)
}
#undef VOL_BUF_SIZE
}
-
+/*
+ * This define can be turned on to experiment with a different way of
+ * normalizing paths (using a different Windows API). Unfortunately the
+ * new path seems to take almost exactly the same amount of time as the
+ * old path! The primary time taken by normalization is in
+ * GetFileAttributesEx/FindFirstFile or
+ * GetFileAttributesEx/GetLongPathName. Conversion to/from native is
+ * not a significant factor at all.
+ *
+ * Also, since we have to check for symbolic links (reparse points)
+ * then we have to call GetFileAttributes on each path segment anyway,
+ * so there's no benefit to doing anything clever there.
+ */
+/* #define TclNORM_LONG_PATH */
/*
*---------------------------------------------------------------------------
@@ -2243,7 +2299,6 @@ TclpFilesystemPathType(pathObjPtr)
*
*---------------------------------------------------------------------------
*/
-
int
TclpObjNormalizePath(interp, pathPtr, nextCheckpoint)
Tcl_Interp *interp;
@@ -2341,7 +2396,7 @@ TclpObjNormalizePath(interp, pathPtr, nextCheckpoint)
Tcl_Obj *temp = NULL;
int isDrive = 1;
Tcl_DString ds;
-
+
currentPathEndPosition = path + nextCheckpoint;
if (*currentPathEndPosition == '/') {
currentPathEndPosition++;
@@ -2374,8 +2429,8 @@ TclpObjNormalizePath(interp, pathPtr, nextCheckpoint)
* understand. We therefore don't perform this
* check for drives.
*/
- if (cur != 0 && !isDrive && (data.dwFileAttributes
- & FILE_ATTRIBUTE_REPARSE_POINT)) {
+ if (cur != 0 && !isDrive
+ && (data.dwFileAttributes & FILE_ATTRIBUTE_REPARSE_POINT)) {
Tcl_Obj *to = WinReadLinkDirectory(nativePath);
if (to != NULL) {
/* Read the reparse point ok */
@@ -2400,6 +2455,7 @@ TclpObjNormalizePath(interp, pathPtr, nextCheckpoint)
continue;
}
}
+#ifndef TclNORM_LONG_PATH
/*
* Now we convert the tail of the current path to its
* 'long form', and append it to 'dsNorm' which holds
@@ -2435,6 +2491,7 @@ TclpObjNormalizePath(interp, pathPtr, nextCheckpoint)
(int) (wcslen(nativeName)*sizeof(WCHAR)));
}
}
+#endif
Tcl_DStringFree(&ds);
lastValidPathEnd = currentPathEndPosition;
if (cur == 0) {
@@ -2448,6 +2505,26 @@ TclpObjNormalizePath(interp, pathPtr, nextCheckpoint)
}
currentPathEndPosition++;
}
+#ifdef TclNORM_LONG_PATH
+ /*
+ * Convert the entire known path to long form.
+ */
+ if (1) {
+ WCHAR wpath[MAX_PATH];
+ DWORD wpathlen;
+ CONST char *nativePath = Tcl_WinUtfToTChar(path,
+ lastValidPathEnd - path, &ds);
+ wpathlen = (*tclWinProcs->getLongPathNameProc)(nativePath,
+ (TCHAR*)wpath,
+ MAX_PATH);
+ /* We have to make the drive letter uppercase */
+ if (wpath[0] >= L'a') {
+ wpath[0] -= (L'a' - L'A');
+ }
+ Tcl_DStringAppend(&dsNorm, (TCHAR*)wpath, wpathlen*sizeof(WCHAR));
+ Tcl_DStringFree(&ds);
+ }
+#endif
}
/* Common code path for all Windows platforms */
nextCheckpoint = currentPathEndPosition - path;
diff --git a/win/tclWinInt.h b/win/tclWinInt.h
index b2cb74e..5c9ce70 100644
--- a/win/tclWinInt.h
+++ b/win/tclWinInt.h
@@ -8,7 +8,7 @@
* See the file "license.terms" for information on usage and redistribution
* of this file, and for a DISCLAIMER OF ALL WARRANTIES.
*
- * RCS: @(#) $Id: tclWinInt.h,v 1.23 2003/10/13 16:48:07 vincentdarley Exp $
+ * RCS: @(#) $Id: tclWinInt.h,v 1.24 2004/01/21 19:59:34 vincentdarley Exp $
*/
#ifndef _TCLWININT
@@ -111,6 +111,7 @@ typedef struct TclWinProcs {
LPVOID, UINT,
LPVOID, DWORD);
BOOL (WINAPI *getVolumeNameForVMPProc)(CONST TCHAR*, TCHAR*, DWORD);
+ DWORD (WINAPI *getLongPathNameProc)(CONST TCHAR*, TCHAR*, DWORD);
/*
* These six are for the security sdk to get correct file
* permissions on NT, 2000, XP, etc. On 95,98,ME they are
generated by cgit v0.12 at 2024-11-15 04:20:10 (GMT)