summaryrefslogtreecommitdiffstats
diff options
context:
space:
mode:
Diffstat
-rw-r--r--generic/tclIOUtil.c2
-rw-r--r--generic/tclInt.h2
-rw-r--r--generic/tclPathObj.c154
-rw-r--r--library/auto.tcl4
4 files changed, 74 insertions, 88 deletions
diff --git a/generic/tclIOUtil.c b/generic/tclIOUtil.c
index e1c5709..6465931 100644
--- a/generic/tclIOUtil.c
+++ b/generic/tclIOUtil.c
@@ -1805,7 +1805,7 @@ Tcl_FSEvalFileEx(
* this cross-platform to allow for scripted documents. [Bug: 2040]
*/
- Tcl_SetChannelOption(interp, chan, "-eofchar", "\32");
+ Tcl_SetChannelOption(interp, chan, "-eofchar", "\32 {}");
/*
* If the encoding is specified, set it for the channel. Else don't touch
diff --git a/generic/tclInt.h b/generic/tclInt.h
index 6113f23..25bec6a 100644
--- a/generic/tclInt.h
+++ b/generic/tclInt.h
@@ -3670,7 +3670,7 @@ MODULE_SCOPE void TclDbInitNewObj(Tcl_Obj *objPtr, CONST char *file,
#define TclUtfToUniChar(str, chPtr) \
((((unsigned char) *(str)) < 0xC0) ? \
- ((*(chPtr) = (Tcl_UniChar) *(str)), 1) \
+ ((*(chPtr) = (unsigned char) *(str)), 1) \
: Tcl_UtfToUniChar(str, chPtr))
/*
diff --git a/generic/tclPathObj.c b/generic/tclPathObj.c
index 88e49b5..a306853 100644
--- a/generic/tclPathObj.c
+++ b/generic/tclPathObj.c
@@ -821,50 +821,47 @@ GetExtension(
*---------------------------------------------------------------------------
*/
+Tcl_Obj * TclJoinPath(int elements, Tcl_Obj * const objv[]);
+
Tcl_Obj *
Tcl_FSJoinPath(
Tcl_Obj *listObj, /* Path elements to join, may have a zero
* reference count. */
int elements) /* Number of elements to use (-1 = all) */
{
- Tcl_Obj *res;
- int i;
- Tcl_Filesystem *fsPtr = NULL;
+ Tcl_Obj *copy, *res;
+ int objc;
+ Tcl_Obj **objv;
- if (elements < 0) {
- if (Tcl_ListObjLength(NULL, listObj, &elements) != TCL_OK) {
- return NULL;
- }
- } else {
- /*
- * Just make sure it is a valid list.
- */
-
- int listTest;
-
- if (Tcl_ListObjLength(NULL, listObj, &listTest) != TCL_OK) {
- return NULL;
- }
-
- /*
- * Correct this if it is too large, otherwise we will waste our time
- * joining null elements to the path.
- */
-
- if (elements > listTest) {
- elements = listTest;
- }
+ if (Tcl_ListObjLength(NULL, listObj, &objc) != TCL_OK) {
+ return NULL;
}
- res = NULL;
+ elements = ((elements >= 0) && (elements <= objc)) ? elements : objc;
+ copy = TclListObjCopy(NULL, listObj);
+ Tcl_ListObjGetElements(NULL, listObj, &objc, &objv);
+ res = TclJoinPath(elements, objv);
+ Tcl_DecrRefCount(copy);
+ return res;
+}
+
+Tcl_Obj *
+TclJoinPath(
+ int elements,
+ Tcl_Obj * const objv[])
+{
+ Tcl_Obj *res = NULL; /* Resulting path object (container of join) */
+ Tcl_Obj *elt; /* Path part (result if returns part of path) */
+ int i;
+ Tcl_Filesystem *fsPtr = NULL;
for (i = 0; i < elements; i++) {
- Tcl_Obj *elt, *driveName = NULL;
int driveNameLength, strEltLen, length;
Tcl_PathType type;
char *strElt, *ptr;
-
- Tcl_ListObjIndex(NULL, listObj, i, &elt);
+ Tcl_Obj *driveName = NULL;
+
+ elt = objv[i];
/*
* This is a special case where we can be much more efficient, where
@@ -873,19 +870,23 @@ Tcl_FSJoinPath(
* object which can be normalized more efficiently. Currently we only
* use the special case when we have exactly two elements, but we
* could expand that in the future.
+ *
+ * Bugfix [a47641a0]. TclNewFSPathObj requires first argument
+ * to be an absolute path. Added a check for that elt is absolute.
*/
- if ((i == (elements-2)) && (i == 0) && (elt->typePtr == &tclFsPathType)
- && !(elt->bytes != NULL && (elt->bytes[0] == '\0'))) {
- Tcl_Obj *tail;
+ if ((i == (elements-2)) && (i == 0)
+ && (elt->typePtr == &tclFsPathType)
+ && !((elt->bytes != NULL) && (elt->bytes[0] == '\0'))
+ && TclGetPathType(elt, NULL, NULL, NULL) == TCL_PATH_ABSOLUTE) {
+ Tcl_Obj *tailObj = objv[i+1];
- Tcl_ListObjIndex(NULL, listObj, i+1, &tail);
- type = TclGetPathType(tail, NULL, NULL, NULL);
+ type = TclGetPathType(tailObj, NULL, NULL, NULL);
if (type == TCL_PATH_RELATIVE) {
const char *str;
int len;
- str = Tcl_GetStringFromObj(tail, &len);
+ str = Tcl_GetStringFromObj(tailObj, &len);
if (len == 0) {
/*
* This happens if we try to handle the root volume '/'.
@@ -893,10 +894,7 @@ Tcl_FSJoinPath(
* the base itself is just fine!
*/
- if (res != NULL) {
- TclDecrRefCount(res);
- }
- return elt;
+ goto partReturn; /* return elt; */
}
/*
@@ -917,20 +915,20 @@ Tcl_FSJoinPath(
*/
if ((tclPlatform != TCL_PLATFORM_WINDOWS)
- || (strchr(Tcl_GetString(elt), '\\') == NULL)) {
- if (res != NULL) {
- TclDecrRefCount(res);
- }
-
+ || (strchr(Tcl_GetString(elt), '\\') == NULL)
+ ) {
if (PATHFLAGS(elt)) {
- return TclNewFSPathObj(elt, str, len);
+ elt = TclNewFSPathObj(elt, str, len);
+ goto partReturn; /* return elt; */
}
if (TCL_PATH_ABSOLUTE != Tcl_FSGetPathType(elt)) {
- return TclNewFSPathObj(elt, str, len);
+ elt = TclNewFSPathObj(elt, str, len);
+ goto partReturn; /* return elt; */
}
(void) Tcl_FSGetNormalizedPath(NULL, elt);
if (elt == PATHOBJ(elt)->normPathPtr) {
- return TclNewFSPathObj(elt, str, len);
+ elt = TclNewFSPathObj(elt, str, len);
+ goto partReturn; /* return elt; */
}
}
}
@@ -940,19 +938,15 @@ Tcl_FSJoinPath(
* more general code below handle things.
*/
} else if (tclPlatform == TCL_PLATFORM_UNIX) {
- if (res != NULL) {
- TclDecrRefCount(res);
- }
- return tail;
+ elt = tailObj;
+ goto partReturn; /* return elt; */
} else {
- const char *str = TclGetString(tail);
+ const char *str = TclGetString(tailObj);
if (tclPlatform == TCL_PLATFORM_WINDOWS) {
if (strchr(str, '\\') == NULL) {
- if (res != NULL) {
- TclDecrRefCount(res);
- }
- return tail;
+ elt = tailObj;
+ goto partReturn; /* return elt; */
}
}
}
@@ -1031,16 +1025,12 @@ Tcl_FSJoinPath(
}
ptr++;
}
- if (res != NULL) {
- TclDecrRefCount(res);
- }
-
/*
- * This element is just what we want to return already - no
- * further manipulation is requred.
+ * This element is just what we want to return already; no further
+ * manipulation is requred.
*/
- return elt;
+ goto partReturn; /* return elt; */
}
/*
@@ -1051,10 +1041,8 @@ Tcl_FSJoinPath(
noQuickReturn:
if (res == NULL) {
res = Tcl_NewObj();
- ptr = Tcl_GetStringFromObj(res, &length);
- } else {
- ptr = Tcl_GetStringFromObj(res, &length);
}
+ ptr = Tcl_GetStringFromObj(res, &length);
/*
* Strip off any './' before a tilde, unless this is the beginning of
@@ -1083,10 +1071,11 @@ Tcl_FSJoinPath(
int needsSep = 0;
if (fsPtr->filesystemSeparatorProc != NULL) {
- Tcl_Obj *sep = (*fsPtr->filesystemSeparatorProc)(res);
+ Tcl_Obj *sep = fsPtr->filesystemSeparatorProc(res);
if (sep != NULL) {
separator = TclGetString(sep)[0];
+ TclDecrRefCount(sep);
}
/* Safety check in case the VFS driver caused sharing */
if (Tcl_IsShared(res)) {
@@ -1126,6 +1115,12 @@ Tcl_FSJoinPath(
res = Tcl_NewObj();
}
return res;
+
+partReturn:
+ if (res != NULL) {
+ TclDecrRefCount(res);
+ }
+ return elt;
}
/*
@@ -2516,27 +2511,18 @@ SetFsPathFromAny(
}
TclDecrRefCount(parts);
} else {
- /*
- * 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);
+ Tcl_Obj *pair[2];
- Tcl_IncrRefCount(transPtr);
- joined = Tcl_FSJoinToPath(transPtr, 1, &rest);
- TclDecrRefCount(transPtr);
- transPtr = joined;
+ pair[0] = transPtr;
+ pair[1] = Tcl_NewStringObj(name+split+1, -1);
+ transPtr = TclJoinPath(2, pair);
+ TclDecrRefCount(pair[0]);
+ TclDecrRefCount(pair[1]);
}
}
Tcl_DStringFree(&temp);
} else {
- /* Bug 3479689: protect 0-refcount pathPth from getting freed */
- pathPtr->refCount++;
- transPtr = Tcl_FSJoinToPath(pathPtr, 0, NULL);
- pathPtr->refCount--;
+ transPtr = TclJoinPath(1, &pathPtr);
}
/*
diff --git a/library/auto.tcl b/library/auto.tcl
index ec680de..6cb09b6 100644
--- a/library/auto.tcl
+++ b/library/auto.tcl
@@ -211,7 +211,7 @@ proc auto_mkindex {dir args} {
}
auto_mkindex_parser::init
- foreach file [glob -- {*}$args] {
+ foreach file [lsort [glob -- {*}$args]] {
if {[catch {auto_mkindex_parser::mkindex $file} msg opts] == 0} {
append index $msg
} else {
@@ -244,7 +244,7 @@ proc auto_mkindex_old {dir args} {
if {[llength $args] == 0} {
set args *.tcl
}
- foreach file [glob -- {*}$args] {
+ foreach file [lsort [glob -- {*}$args]] {
set f ""
set error [catch {
set f [open $file]
generated by cgit v0.12 at 2024-11-21 15:25:56 (GMT)