summaryrefslogtreecommitdiffstats
path: root/generic/tclFileName.c
diff options
context:
space:
mode:
Diffstat (limited to 'generic/tclFileName.c')
-rw-r--r--generic/tclFileName.c373
1 files changed, 235 insertions, 138 deletions
diff --git a/generic/tclFileName.c b/generic/tclFileName.c
index 1fca08b..b6b89dd 100644
--- a/generic/tclFileName.c
+++ b/generic/tclFileName.c
@@ -32,11 +32,21 @@ static const char * ExtractWinRoot(const char *path,
Tcl_DString *resultPtr, int offset,
Tcl_PathType *typePtr);
static int SkipToChar(char **stringPtr, int match);
-static Tcl_Obj* SplitWinPath(const char *path);
-static Tcl_Obj* SplitUnixPath(const char *path);
+static Tcl_Obj * SplitWinPath(const char *path);
+static Tcl_Obj * SplitUnixPath(const char *path);
static int DoGlob(Tcl_Interp *interp, Tcl_Obj *resultPtr,
const char *separators, Tcl_Obj *pathPtr, int flags,
char *pattern, Tcl_GlobTypeData *types);
+
+/*
+ * When there is no support for getting the block size of a file in a stat()
+ * call, use this as a guess. Allow it to be overridden in the platform-
+ * specific files.
+ */
+
+#if (!defined(HAVE_STRUCT_STAT_ST_BLKSIZE) && !defined(GUESSED_BLOCK_SIZE))
+#define GUESSED_BLOCK_SIZE 1024
+#endif
/*
*----------------------------------------------------------------------
@@ -199,7 +209,7 @@ ExtractWinRoot(
Tcl_DStringAppend(resultPtr, path, 2);
return &path[2];
} else {
- char *tail = (char*)&path[3];
+ const char *tail = &path[3];
/*
* Skip separators.
@@ -377,7 +387,7 @@ TclpGetNativePathType(
{
Tcl_PathType type = TCL_PATH_ABSOLUTE;
int pathLen;
- char *path = Tcl_GetStringFromObj(pathPtr, &pathLen);
+ const char *path = Tcl_GetStringFromObj(pathPtr, &pathLen);
if (path[0] == '~') {
/*
@@ -386,7 +396,7 @@ TclpGetNativePathType(
*/
if (driveNameLengthPtr != NULL) {
- char *end = path + 1;
+ const char *end = path + 1;
while ((*end != '\0') && (*end != '/')) {
end++;
}
@@ -395,7 +405,7 @@ TclpGetNativePathType(
} else {
switch (tclPlatform) {
case TCL_PLATFORM_UNIX: {
- char *origPath = path;
+ const char *origPath = path;
/*
* Paths that begin with / are absolute.
@@ -409,7 +419,7 @@ TclpGetNativePathType(
&& (path[1] == '/') && isdigit(UCHAR(path[2]))) {
path += 3;
while (isdigit(UCHAR(*path))) {
- ++path;
+ path++;
}
}
#endif
@@ -538,7 +548,8 @@ Tcl_SplitPath(
Tcl_Obj *resultPtr = NULL; /* Needed only to prevent gcc warnings. */
Tcl_Obj *tmpPtr, *eltPtr;
int i, size, len;
- char *p, *str;
+ char *p;
+ const char *str;
/*
* Perform the splitting, using objectified, vfs-aware code.
@@ -566,8 +577,7 @@ Tcl_SplitPath(
* plus the argv pointers and the terminating NULL pointer.
*/
- *argvPtr = (const char **) ckalloc((unsigned)
- ((((*argcPtr) + 1) * sizeof(char *)) + size));
+ *argvPtr = ckalloc((((*argcPtr) + 1) * sizeof(char *)) + size);
/*
* Position p after the last argv pointer and copy the contents of the
@@ -634,11 +644,12 @@ SplitUnixPath(
/*
* Check for QNX //<node id> prefix
*/
+
if ((path[0] == '/') && (path[1] == '/')
&& isdigit(UCHAR(path[2]))) { /* INTL: digit */
path += 3;
while (isdigit(UCHAR(*path))) { /* INTL: digit */
- ++path;
+ path++;
}
}
#endif
@@ -776,32 +787,28 @@ Tcl_FSJoinToPath(
int objc, /* Number of array elements to join */
Tcl_Obj *const objv[]) /* Path elements to join. */
{
- int i;
- Tcl_Obj *lobj, *ret;
-
if (pathPtr == NULL) {
- lobj = Tcl_NewListObj(0, NULL);
- } else {
- lobj = Tcl_NewListObj(1, &pathPtr);
+ return TclJoinPath(objc, objv);
}
-
- for (i = 0; i<objc;i++) {
- Tcl_ListObjAppendElement(NULL, lobj, objv[i]);
+ if (objc == 0) {
+ return TclJoinPath(1, &pathPtr);
}
- ret = Tcl_FSJoinPath(lobj, -1);
+ if (objc == 1) {
+ Tcl_Obj *pair[2];
- /*
- * 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;
+ pair[0] = pathPtr;
+ pair[1] = objv[0];
+ return TclJoinPath(2, pair);
+ } else {
+ int elemc = objc + 1;
+ Tcl_Obj *ret, **elemv = ckalloc(elemc*sizeof(Tcl_Obj **));
+
+ elemv[0] = pathPtr;
+ memcpy(elemv+1, objv, objc*sizeof(Tcl_Obj **));
+ ret = TclJoinPath(elemc, elemv);
+ ckfree(elemv);
+ return ret;
+ }
}
/*
@@ -826,8 +833,9 @@ TclpNativeJoinPath(
const char *joining)
{
int length, needsSep;
+ char *dest;
const char *p;
- char *dest, *start;
+ const char *start;
start = Tcl_GetStringFromObj(prefix, &length);
@@ -951,7 +959,7 @@ Tcl_JoinPath(
int i, len;
Tcl_Obj *listObj = Tcl_NewObj();
Tcl_Obj *resultObj;
- char *resultStr;
+ const char *resultStr;
/*
* Build the list of paths.
@@ -1198,10 +1206,10 @@ Tcl_GlobObjCmd(
int index, i, globFlags, length, join, dir, result;
char *string;
const char *separators;
- Tcl_Obj *typePtr, *resultPtr, *look;
+ Tcl_Obj *typePtr, *look;
Tcl_Obj *pathOrDir = NULL;
Tcl_DString prefix;
- static const char *options[] = {
+ static const char *const options[] = {
"-directory", "-join", "-nocomplain", "-path", "-tails",
"-types", "--", NULL
};
@@ -1246,11 +1254,14 @@ Tcl_GlobObjCmd(
if (i == (objc-1)) {
Tcl_SetObjResult(interp, Tcl_NewStringObj(
"missing argument to \"-directory\"", -1));
+ Tcl_SetErrorCode(interp, "TCL", "ARGUMENT", "MISSING", NULL);
return TCL_ERROR;
}
if (dir != PATH_NONE) {
Tcl_SetObjResult(interp, Tcl_NewStringObj(
"\"-directory\" cannot be used with \"-path\"", -1));
+ Tcl_SetErrorCode(interp, "TCL", "OPERATION", "GLOB",
+ "BADOPTIONCOMBINATION", NULL);
return TCL_ERROR;
}
dir = PATH_DIR;
@@ -1268,11 +1279,14 @@ Tcl_GlobObjCmd(
if (i == (objc-1)) {
Tcl_SetObjResult(interp, Tcl_NewStringObj(
"missing argument to \"-path\"", -1));
+ Tcl_SetErrorCode(interp, "TCL", "ARGUMENT", "MISSING", NULL);
return TCL_ERROR;
}
if (dir != PATH_NONE) {
Tcl_SetObjResult(interp, Tcl_NewStringObj(
"\"-path\" cannot be used with \"-directory\"", -1));
+ Tcl_SetErrorCode(interp, "TCL", "OPERATION", "GLOB",
+ "BADOPTIONCOMBINATION", NULL);
return TCL_ERROR;
}
dir = PATH_GENERAL;
@@ -1283,6 +1297,7 @@ Tcl_GlobObjCmd(
if (i == (objc-1)) {
Tcl_SetObjResult(interp, Tcl_NewStringObj(
"missing argument to \"-types\"", -1));
+ Tcl_SetErrorCode(interp, "TCL", "ARGUMENT", "MISSING", NULL);
return TCL_ERROR;
}
typePtr = objv[i+1];
@@ -1298,14 +1313,12 @@ Tcl_GlobObjCmd(
}
endOfForLoop:
- if (objc - i < 1) {
- Tcl_WrongNumArgs(interp, 1, objv, "?switches? name ?name ...?");
- return TCL_ERROR;
- }
if ((globFlags & TCL_GLOBMODE_TAILS) && (pathOrDir == NULL)) {
Tcl_AppendResult(interp,
"\"-tails\" must be used with either "
"\"-directory\" or \"-path\"", NULL);
+ Tcl_SetErrorCode(interp, "TCL", "OPERATION", "GLOB",
+ "BADOPTIONCOMBINATION", NULL);
return TCL_ERROR;
}
@@ -1321,8 +1334,8 @@ Tcl_GlobObjCmd(
if (dir == PATH_GENERAL) {
int pathlength;
- char *last;
- char *first = Tcl_GetStringFromObj(pathOrDir,&pathlength);
+ const char *last;
+ const char *first = Tcl_GetStringFromObj(pathOrDir,&pathlength);
/*
* Find the last path separator in the path
@@ -1414,8 +1427,7 @@ Tcl_GlobObjCmd(
if (length <= 0) {
goto skipTypes;
}
- globTypes = (Tcl_GlobTypeData*)
- TclStackAlloc(interp,sizeof(Tcl_GlobTypeData));
+ globTypes = TclStackAlloc(interp, sizeof(Tcl_GlobTypeData));
globTypes->type = 0;
globTypes->perm = 0;
globTypes->macType = NULL;
@@ -1423,7 +1435,7 @@ Tcl_GlobObjCmd(
while (--length >= 0) {
int len;
- char *str;
+ const char *str;
Tcl_ListObjIndex(interp, typePtr, length, &look);
str = Tcl_GetStringFromObj(look, &len);
@@ -1479,10 +1491,10 @@ Tcl_GlobObjCmd(
Tcl_IncrRefCount(look);
} else {
- Tcl_Obj* item;
+ Tcl_Obj *item;
- if ((Tcl_ListObjLength(NULL, look, &len) == TCL_OK) &&
- (len == 3)) {
+ if ((Tcl_ListObjLength(NULL, look, &len) == TCL_OK)
+ && (len == 3)) {
Tcl_ListObjIndex(interp, look, 0, &item);
if (!strcmp("macintosh", Tcl_GetString(item))) {
Tcl_ListObjIndex(interp, look, 1, &item);
@@ -1512,10 +1524,10 @@ Tcl_GlobObjCmd(
*/
badTypesArg:
- TclNewObj(resultPtr);
- Tcl_AppendToObj(resultPtr, "bad argument to \"-types\": ", -1);
- Tcl_AppendObjToObj(resultPtr, look);
- Tcl_SetObjResult(interp, resultPtr);
+ Tcl_SetObjResult(interp, Tcl_ObjPrintf(
+ "bad argument to \"-types\": %s",
+ Tcl_GetString(look)));
+ Tcl_SetErrorCode(interp, "TCL", "ARGUMENT", "BAD", NULL);
result = TCL_ERROR;
join = 0;
goto endOfGlob;
@@ -1525,6 +1537,7 @@ Tcl_GlobObjCmd(
"only one MacOS type or creator argument"
" to \"-types\" allowed", -1));
result = TCL_ERROR;
+ Tcl_SetErrorCode(interp, "TCL", "ARGUMENT", "BAD", NULL);
join = 0;
goto endOfGlob;
}
@@ -1606,6 +1619,7 @@ Tcl_GlobObjCmd(
Tcl_AppendResult(interp, Tcl_DStringValue(&prefix), NULL);
} else {
const char *sep = "";
+
for (i = 0; i < objc; i++) {
string = Tcl_GetString(objv[i]);
Tcl_AppendResult(interp, sep, string, NULL);
@@ -1613,6 +1627,8 @@ Tcl_GlobObjCmd(
}
}
Tcl_AppendResult(interp, "\"", NULL);
+ Tcl_SetErrorCode(interp, "TCL", "OPERATION", "GLOB", "NOMATCH",
+ NULL);
result = TCL_ERROR;
}
}
@@ -1814,7 +1830,7 @@ TclGlob(
if (tail[0] == '/') {
tail++;
} else {
- tail+=2;
+ tail += 2;
}
Tcl_IncrRefCount(pathPrefix);
break;
@@ -1885,27 +1901,29 @@ TclGlob(
if (*tail == '\0' && pathPrefix != NULL) {
/*
- * An empty pattern. This means 'pathPrefix' is actually
- * a full path of a file/directory we want to simply check
- * for existence and type.
+ * An empty pattern. This means 'pathPrefix' is actually a full path
+ * of a file/directory we want to simply check for existence and type.
*/
+
if (types == NULL) {
/*
- * We just want to check for existence. In this case we
- * make it easy on Tcl_FSMatchInDirectory and its
- * sub-implementations by not bothering them (even though
- * they should support this situation) and we just use the
- * simple existence check with Tcl_FSAccess.
+ * We just want to check for existence. In this case we make it
+ * easy on Tcl_FSMatchInDirectory and its sub-implementations by
+ * not bothering them (even though they should support this
+ * situation) and we just use the simple existence check with
+ * Tcl_FSAccess.
*/
+
if (Tcl_FSAccess(pathPrefix, F_OK) == 0) {
Tcl_ListObjAppendElement(interp, filenamesObj, pathPrefix);
}
result = TCL_OK;
} else {
/*
- * We want to check for the correct type. Tcl_FSMatchInDirectory
+ * We want to check for the correct type. Tcl_FSMatchInDirectory
* is documented to do this for us, if we give it a NULL pattern.
*/
+
result = Tcl_FSMatchInDirectory(interp, filenamesObj, pathPrefix,
NULL, types);
}
@@ -1970,20 +1988,20 @@ TclGlob(
Tcl_ListObjGetElements(NULL, filenamesObj, &objc, &objv);
for (i = 0; i< objc; i++) {
int len;
- char *oldStr = Tcl_GetStringFromObj(objv[i], &len);
- Tcl_Obj* elems[1];
+ const char *oldStr = Tcl_GetStringFromObj(objv[i], &len);
+ Tcl_Obj *elem;
if (len == prefixLen) {
if ((pattern[0] == '\0')
|| (strchr(separators, pattern[0]) == NULL)) {
- TclNewLiteralStringObj(elems[0], ".");
+ TclNewLiteralStringObj(elem, ".");
} else {
- TclNewLiteralStringObj(elems[0], "/");
+ TclNewLiteralStringObj(elem, "/");
}
} else {
- elems[0] = Tcl_NewStringObj(oldStr+prefixLen, len-prefixLen);
+ elem = Tcl_NewStringObj(oldStr+prefixLen, len-prefixLen);
}
- Tcl_ListObjReplace(interp, filenamesObj, i, 1, 1, elems);
+ Tcl_ListObjReplace(interp, filenamesObj, i, 1, 1, &elem);
}
}
@@ -2098,7 +2116,7 @@ DoGlob(
* resulting filenames. Caller allocates and
* deallocates; DoGlob must not touch the
* refCount of this object. */
- const char *separators, /* String containing separator characters that
+ const char *separators, /* String containing separator characters that
* should be used to identify globbing
* boundaries. */
Tcl_Obj *pathPtr, /* Completely expanded prefix. */
@@ -2142,67 +2160,6 @@ DoGlob(
}
/*
- * 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.
- */
-
-#if 0 /* PROBABLY_OBSOLETE */
- /*
- * Deal with path separators.
- */
-
- 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_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(&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.
- */
-
- if ((*pattern != '\0') && (((length > 0)
- && (strchr(separators, lastChar) == NULL))
- || ((length == 0) && (count > 0)))) {
- Tcl_DStringAppend(&append, "/", 1);
- }
- break;
- }
- }
-#endif /* PROBABLY_OBSOLETE */
-
- /*
* Look for the first matching pair of braces or the first directory
* separator that is not inside a pair of braces.
*/
@@ -2241,11 +2198,15 @@ DoGlob(
}
Tcl_SetResult(interp, "unmatched open-brace in file name",
TCL_STATIC);
+ Tcl_SetErrorCode(interp, "TCL", "OPERATION", "GLOB", "BALANCE",
+ NULL);
return TCL_ERROR;
} else if (*p == '}') {
Tcl_SetResult(interp, "unmatched close-brace in file name",
TCL_STATIC);
+ Tcl_SetErrorCode(interp, "TCL", "OPERATION", "GLOB", "BALANCE",
+ NULL);
return TCL_ERROR;
}
}
@@ -2256,8 +2217,8 @@ DoGlob(
if (openBrace != NULL) {
char *element;
-
Tcl_DString newName;
+
Tcl_DStringInit(&newName);
/*
@@ -2306,12 +2267,13 @@ DoGlob(
*/
if (*p != '\0') {
+ char savedChar = *p;
+
/*
* Note that we are modifying the string in place. This won't work if
* the string is a static.
*/
- char savedChar = *p;
*p = '\0';
firstSpecialChar = strpbrk(pattern, "*[]?\\");
*p = savedChar;
@@ -2330,7 +2292,7 @@ DoGlob(
TCL_GLOB_TYPE_DIR, 0, NULL, NULL
};
char save = *p;
- Tcl_Obj* subdirsPtr;
+ Tcl_Obj *subdirsPtr;
if (*p == '\0') {
return Tcl_FSMatchInDirectory(interp, matchesObj, pathPtr,
@@ -2376,6 +2338,7 @@ DoGlob(
const char *bytes;
int numBytes;
Tcl_Obj *fixme, *newObj;
+
Tcl_ListObjIndex(NULL, matchesObj, repair, &fixme);
bytes = Tcl_GetStringFromObj(fixme, &numBytes);
newObj = Tcl_NewStringObj(bytes+2, numBytes-2);
@@ -2396,6 +2359,9 @@ DoGlob(
*/
if (*p == '\0') {
+ int length;
+ Tcl_DString append;
+
/*
* This is the code path reached by a command like 'glob foo'.
*
@@ -2408,9 +2374,6 @@ DoGlob(
* approach).
*/
- int length;
- Tcl_DString append;
-
Tcl_DStringInit(&append);
Tcl_DStringAppend(&append, pattern, p-pattern);
@@ -2441,6 +2404,17 @@ DoGlob(
Tcl_DStringAppend(&append, ".", 1);
}
}
+#if defined(__CYGWIN__) && !defined(__WIN32__)
+ {
+ DLLIMPORT extern int cygwin_conv_to_posix_path(const char *,
+ char *);
+ char winbuf[MAXPATHLEN+1];
+
+ cygwin_conv_to_posix_path(Tcl_DStringValue(&append), winbuf);
+ Tcl_DStringFree(&append);
+ Tcl_DStringAppend(&append, winbuf, -1);
+ }
+#endif /* __CYGWIN__ && __WIN32__ */
break;
}
@@ -2539,7 +2513,130 @@ DoGlob(
Tcl_StatBuf *
Tcl_AllocStatBuf(void)
{
- return (Tcl_StatBuf *) ckalloc(sizeof(Tcl_StatBuf));
+ return ckalloc(sizeof(Tcl_StatBuf));
+}
+
+/*
+ *---------------------------------------------------------------------------
+ *
+ * Access functions for Tcl_StatBuf --
+ *
+ * These functions provide portable read-only access to the portable
+ * fields of the Tcl_StatBuf structure (really a 'struct stat', 'struct
+ * stat64' or something else related). [TIP #316]
+ *
+ * Results:
+ * The value from the field being retrieved.
+ *
+ * Side effects:
+ * None.
+ *
+ *---------------------------------------------------------------------------
+ */
+
+unsigned
+Tcl_GetFSDeviceFromStat(
+ const Tcl_StatBuf *statPtr)
+{
+ return (unsigned) statPtr->st_dev;
+}
+
+unsigned
+Tcl_GetFSInodeFromStat(
+ const Tcl_StatBuf *statPtr)
+{
+ return (unsigned) statPtr->st_ino;
+}
+
+unsigned
+Tcl_GetModeFromStat(
+ const Tcl_StatBuf *statPtr)
+{
+ return (unsigned) statPtr->st_mode;
+}
+
+int
+Tcl_GetLinkCountFromStat(
+ const Tcl_StatBuf *statPtr)
+{
+ return (int)statPtr->st_nlink;
+}
+
+int
+Tcl_GetUserIdFromStat(
+ const Tcl_StatBuf *statPtr)
+{
+ return (int) statPtr->st_uid;
+}
+
+int
+Tcl_GetGroupIdFromStat(
+ const Tcl_StatBuf *statPtr)
+{
+ return (int) statPtr->st_gid;
+}
+
+int
+Tcl_GetDeviceTypeFromStat(
+ const Tcl_StatBuf *statPtr)
+{
+ return (int) statPtr->st_rdev;
+}
+
+Tcl_WideInt
+Tcl_GetAccessTimeFromStat(
+ const Tcl_StatBuf *statPtr)
+{
+ return (Tcl_WideInt) statPtr->st_atime;
+}
+
+Tcl_WideInt
+Tcl_GetModificationTimeFromStat(
+ const Tcl_StatBuf *statPtr)
+{
+ return (Tcl_WideInt) statPtr->st_mtime;
+}
+
+Tcl_WideInt
+Tcl_GetChangeTimeFromStat(
+ const Tcl_StatBuf *statPtr)
+{
+ return (Tcl_WideInt) statPtr->st_ctime;
+}
+
+Tcl_WideUInt
+Tcl_GetSizeFromStat(
+ const Tcl_StatBuf *statPtr)
+{
+ return (Tcl_WideUInt) statPtr->st_size;
+}
+
+Tcl_WideUInt
+Tcl_GetBlocksFromStat(
+ const Tcl_StatBuf *statPtr)
+{
+#ifdef HAVE_STRUCT_STAT_ST_BLOCKS
+ return (Tcl_WideUInt) statPtr->st_blocks;
+#else
+ register unsigned blksize = Tcl_GetBlockSizeFromStat(statPtr);
+
+ return ((Tcl_WideUInt) statPtr->st_size + blksize - 1) / blksize;
+#endif
+}
+
+unsigned
+Tcl_GetBlockSizeFromStat(
+ const Tcl_StatBuf *statPtr)
+{
+#ifdef HAVE_STRUCT_STAT_ST_BLKSIZE
+ return (unsigned) statPtr->st_blksize;
+#else
+ /*
+ * Not a great guess, but will do...
+ */
+
+ return GUESSED_BLOCK_SIZE;
+#endif
}
/*
generated by cgit v0.12 at 2024-11-19 16:56:31 (GMT)