Merge 9.0

doc/FileSystem.3

@@ -9,7 +9,7 @@
 .so man.macros
 .BS
 .SH NAME
-Tcl_FSRegister, Tcl_FSUnregister, Tcl_FSData, Tcl_FSMountsChanged, Tcl_FSGetFileSystemForPath, Tcl_FSGetPathType, Tcl_FSCopyFile, Tcl_FSCopyDirectory, Tcl_FSCreateDirectory, Tcl_FSDeleteFile, Tcl_FSRemoveDirectory, Tcl_FSRenameFile, Tcl_FSListVolumes, Tcl_FSEvalFile, Tcl_FSEvalFileEx, Tcl_FSLoadFile, Tcl_FSUnloadFile, Tcl_FSMatchInDirectory, Tcl_FSLink, Tcl_FSLstat, Tcl_FSUtime, Tcl_FSFileAttrsGet, Tcl_FSFileAttrsSet, Tcl_FSFileAttrStrings, Tcl_FSStat, Tcl_FSAccess, Tcl_FSOpenFileChannel, Tcl_FSGetCwd, Tcl_FSChdir, Tcl_FSPathSeparator, Tcl_FSJoinPath, Tcl_FSSplitPath, Tcl_FSEqualPaths, Tcl_FSGetNormalizedPath, Tcl_FSJoinToPath, Tcl_FSConvertToPathType, Tcl_FSGetInternalRep, Tcl_FSGetTranslatedPath, Tcl_FSGetTranslatedStringPath, Tcl_FSNewNativePath, Tcl_FSGetNativePath, Tcl_FSFileSystemInfo, Tcl_GetAccessTimeFromStat, Tcl_GetBlockSizeFromStat, Tcl_GetBlocksFromStat, Tcl_GetChangeTimeFromStat, Tcl_GetDeviceTypeFromStat, Tcl_GetFSDeviceFromStat, Tcl_GetFSInodeFromStat, Tcl_GetGroupIdFromStat, Tcl_GetLinkCountFromStat, Tcl_GetModeFromStat, Tcl_GetModificationTimeFromStat, Tcl_GetSizeFromStat, Tcl_GetUserIdFromStat, Tcl_AllocStatBuf \- procedures to interact with any filesystem
+Tcl_FSRegister, Tcl_FSUnregister, Tcl_FSData, Tcl_FSMountsChanged, Tcl_FSGetFileSystemForPath, Tcl_FSGetPathType, Tcl_FSCopyFile, Tcl_FSCopyDirectory, Tcl_FSCreateDirectory, Tcl_FSDeleteFile, Tcl_FSRemoveDirectory, Tcl_FSRenameFile, Tcl_FSListVolumes, Tcl_FSEvalFile, Tcl_FSEvalFileEx, Tcl_FSLoadFile, Tcl_FSUnloadFile, Tcl_FSMatchInDirectory, Tcl_FSLink, Tcl_FSLstat, Tcl_FSUtime, Tcl_FSFileAttrsGet, Tcl_FSFileAttrsSet, Tcl_FSFileAttrStrings, Tcl_FSStat, Tcl_FSAccess, Tcl_FSOpenFileChannel, Tcl_FSGetCwd, Tcl_FSChdir, Tcl_FSPathSeparator, Tcl_FSJoinPath, Tcl_FSSplitPath, Tcl_FSEqualPaths, Tcl_FSGetNormalizedPath, Tcl_FSJoinToPath, Tcl_FSConvertToPathType, Tcl_FSGetInternalRep, Tcl_FSGetTranslatedPath, Tcl_FSGetTranslatedStringPath, Tcl_FSNewNativePath, Tcl_FSGetNativePath, Tcl_FSFileSystemInfo, Tcl_GetAccessTimeFromStat, Tcl_GetBlockSizeFromStat, Tcl_GetBlocksFromStat, Tcl_GetChangeTimeFromStat, Tcl_GetDeviceTypeFromStat, Tcl_GetFSDeviceFromStat, Tcl_GetFSInodeFromStat, Tcl_GetGroupIdFromStat, Tcl_GetLinkCountFromStat, Tcl_GetModeFromStat, Tcl_GetModificationTimeFromStat, Tcl_GetSizeFromStat, Tcl_GetUserIdFromStat, Tcl_AllocStatBuf, Tcl_FSTildeExpand \- procedures to interact with any filesystem
 .SH SYNOPSIS
 .nf
 \fB#include <tcl.h>\fR
@@ -140,6 +140,9 @@ const void *
 Tcl_Obj *
 \fBTcl_FSFileSystemInfo\fR(\fIpathPtr\fR)
 .sp
+int
+\fBTcl_FSTildeExpand\fR(\fIinterp, pathStr, dsPtr\fR)
+.sp
 Tcl_StatBuf *
 \fBTcl_AllocStatBuf\fR()
 .sp
@@ -187,6 +190,8 @@ int
 .AP "const Tcl_Filesystem" *fsPtr in
 Points to a structure containing the addresses of procedures that
 can be called to perform the various filesystem operations.
+.AP "const char" *pathStr in
+Pointer to a NUL terminated string representing a file system path.
 .AP Tcl_Obj *pathPtr in
 The path represented by this value is used for the operation in
 question. If the value does not already have an internal \fBpath\fR
@@ -293,6 +298,8 @@ created (will be ignored if \fItoPtr\fR is NULL). Valid bits to set
 are \fBTCL_CREATE_SYMBOLIC_LINK\fR and \fBTCL_CREATE_HARD_LINK\fR.
 When both flags are set and the underlying filesystem can do either,
 symbolic links are preferred.
+.AP Tcl_DString *dsPtr out
+Pointer to a \fBTcl_DString\fR to hold an output string result.
 .BE
 .SH DESCRIPTION
 .PP
@@ -779,6 +786,17 @@ absolute.
 .PP
 It returns one of \fBTCL_PATH_ABSOLUTE\fR, \fBTCL_PATH_RELATIVE\fR, or
 \fBTCL_PATH_VOLUME_RELATIVE\fR
+.PP
+\fBTcl_FSTildeExpand\fR performs tilde substitution on the input path passed via
+\fBpathStr\fR as described in the documentation for the \fBfile tildeexpand\fR
+Tcl command. On success, the function returns \fBTCL_OK\fR with the result of
+the substitution in \fBdsPtr\fR which must be subsequently freed by the caller.
+The \fBdsPtr\fR structure is initialized by the function. No guarantees are made
+about the form of the returned path such as the path separators used. The
+returned result should be passed to other Tcl C API functions such as
+\fBTcl_FSGetNormalizedPath\fR or \fBTcl_FSGetNativePath\fR if necessary. On
+error, the function returns \fBTCL_ERROR\fR with an error message in
+\fBinterp\fR which may be passed as NULL if error messages are not of interest.
 .SS "PORTABLE STAT RESULT API"
 .PP
 \fBTcl_AllocStatBuf\fR allocates a \fITcl_StatBuf\fR on the system heap (which

generic/tcl.decls

@@ -2214,6 +2214,12 @@ declare 656 {
     const char *Tcl_UtfPrev(const char *src, const char *start)
 }
 
+# TIP 701
+declare 657 {
+    int Tcl_FSTildeExpand(Tcl_Interp *interp, const char *path,
+        Tcl_DString *dsPtr)
+}
+
 # TIP 656
 declare 658 {
     int Tcl_ExternalToUtfDStringEx(Tcl_Interp *interp, Tcl_Encoding encoding,

generic/tclDecls.h

@@ -1761,7 +1761,9 @@ EXTERN int		Tcl_UtfCharComplete(const char *src, Tcl_Size length);
 EXTERN const char *	Tcl_UtfNext(const char *src);
 /* 656 */
 EXTERN const char *	Tcl_UtfPrev(const char *src, const char *start);
-/* Slot 657 is reserved */
+/* 657 */
+EXTERN int		Tcl_FSTildeExpand(Tcl_Interp *interp,
+				const char *path, Tcl_DString *dsPtr);
 /* 658 */
 EXTERN int		Tcl_ExternalToUtfDStringEx(Tcl_Interp *interp,
 				Tcl_Encoding encoding, const char *src,
@@ -2538,7 +2540,7 @@ typedef struct TclStubs {
     int (*tcl_UtfCharComplete) (const char *src, Tcl_Size length); /* 654 */
     const char * (*tcl_UtfNext) (const char *src); /* 655 */
     const char * (*tcl_UtfPrev) (const char *src, const char *start); /* 656 */
-    void (*reserved657)(void);
+    int (*tcl_FSTildeExpand) (Tcl_Interp *interp, const char *path, Tcl_DString *dsPtr); /* 657 */
     int (*tcl_ExternalToUtfDStringEx) (Tcl_Interp *interp, Tcl_Encoding encoding, const char *src, Tcl_Size srcLen, int flags, Tcl_DString *dsPtr, Tcl_Size *errorLocationPtr); /* 658 */
     int (*tcl_UtfToExternalDStringEx) (Tcl_Interp *interp, Tcl_Encoding encoding, const char *src, Tcl_Size srcLen, int flags, Tcl_DString *dsPtr, Tcl_Size *errorLocationPtr); /* 659 */
     int (*tcl_AsyncMarkFromSignal) (Tcl_AsyncHandler async, int sigNumber); /* 660 */
@@ -3834,7 +3836,8 @@ extern const TclStubs *tclStubsPtr;
 	(tclStubsPtr->tcl_UtfNext) /* 655 */
 #define Tcl_UtfPrev \
 	(tclStubsPtr->tcl_UtfPrev) /* 656 */
-/* Slot 657 is reserved */
+#define Tcl_FSTildeExpand \
+	(tclStubsPtr->tcl_FSTildeExpand) /* 657 */
 #define Tcl_ExternalToUtfDStringEx \
 	(tclStubsPtr->tcl_ExternalToUtfDStringEx) /* 658 */
 #define Tcl_UtfToExternalDStringEx \

generic/tclPathObj.c

@@ -2548,6 +2548,74 @@ TclGetHomeDirObj(
     return Tcl_DStringToObj(&dirString);
 }
 
+/*
+ *----------------------------------------------------------------------
+ *
+ * Tcl_FSTildeExpand --
+ *
+ *	Copies the path passed in to the output Tcl_DString dsPtr,
+ *	resolving leading ~ and ~user components in the path if present.
+ *      An error is returned if such a component IS present AND cannot
+ *      be resolved.
+ *
+ *	The output dsPtr must be cleared by caller on success.
+ *
+ * Results:
+ *      TCL_OK - path did not contain leading ~ or it was successful resolved
+ *      TCL_ERROR - ~ component could not be resolved.
+ *
+ *----------------------------------------------------------------------
+ */
+int Tcl_FSTildeExpand(
+    Tcl_Interp *interp,	/* May be NULL. Only used for error messages */
+    const char *path,	/* Path to resolve tilde */
+    Tcl_DString *dsPtr) /* Output DString for resolved path. */
+
+{
+    Tcl_Size split;
+    int result;
+
+    assert(path);
+    assert(dsPtr);
+
+    Tcl_DStringInit(dsPtr);
+    if (path[0] != '~') {
+	Tcl_DStringAppend(dsPtr, path, -1);
+	return TCL_OK;
+    }
+
+    /*
+     * We have multiple cases '~', '~user', '~/foo/bar...', '~user/foo...'
+     * FindSplitPos returns 1 for '~/...' as well as for '~'. Note on
+     * Windows FindSplitPos implicitly checks for '\' as separator
+     * in addition to what is passed.
+     */
+    split = FindSplitPos(path, '/');
+
+    if (split == 1) {
+        /* No user name specified '~' or '~/...' -> current user */
+	result = MakeTildeRelativePath(interp, NULL, path[1] ? 2 + path : NULL, dsPtr);
+    } else {
+        /* User name specified - ~user, ~user/... */
+        const char *user;
+        Tcl_DString dsUser;
+
+	Tcl_DStringInit(&dsUser);
+        Tcl_DStringAppend(&dsUser, path+1, split-1);
+        user = Tcl_DStringValue(&dsUser);
+
+	/* path[split] is / for ~user/... or \0 for ~user */
+	result = MakeTildeRelativePath(interp, user,
+		  path[split] ? &path[split + 1] : NULL, dsPtr);
+	Tcl_DStringFree(&dsUser);
+    }
+    if (result != TCL_OK) {
+        /* Do not rely on caller to free in case of errors */
+        Tcl_DStringFree(dsPtr);
+    }
+    return result;
+}
+
 /*
  *----------------------------------------------------------------------
  *
@@ -2574,46 +2642,18 @@ TclResolveTildePath(
 {
     const char *path;
     Tcl_Size len;
-    Tcl_Size split;
     Tcl_DString resolvedPath;
 
     path = TclGetStringFromObj(pathObj, &len);
+    /* Optimize to skip unnecessary calls below */
     if (path[0] != '~') {
 	return pathObj;
     }
 
-    /*
-     * We have multiple cases '~/foo/bar...', '~user/foo/bar...', etc.
-     * split becomes value 1 for '~/...' as well as for '~'. Note on
-     * Windows FindSplitPos will implicitly check for '\' as separator
-     * in addition to what is passed.
-     */
-    split = FindSplitPos(path, '/');
-
-    if (split == 1) {
-	/* No user name specified -> current user */
-	if (MakeTildeRelativePath(interp, NULL, path[1] ? 2 + path : NULL,
-		&resolvedPath) != TCL_OK) {
-	    return NULL;
-	}
-    } else {
-	/* User name specified - ~user */
-	const char *expandedUser;
-	Tcl_DString userName;
-
-	Tcl_DStringInit(&userName);
-	Tcl_DStringAppend(&userName, path+1, split-1);
-	expandedUser = Tcl_DStringValue(&userName);
-
-	/* path[split] is / or \0 */
-	if (MakeTildeRelativePath(interp, expandedUser,
-		path[split] ? &path[split+1] : NULL,
-		&resolvedPath) != TCL_OK) {
-	    Tcl_DStringFree(&userName);
-	    return NULL;
-	}
-	Tcl_DStringFree(&userName);
+    if (Tcl_FSTildeExpand(interp, path, &resolvedPath) != TCL_OK) {
+	return NULL;
     }
+
     return Tcl_DStringToObj(&resolvedPath);
 }
 

generic/tclStubInit.c

@@ -1480,7 +1480,7 @@ const TclStubs tclStubs = {
     Tcl_UtfCharComplete, /* 654 */
     Tcl_UtfNext, /* 655 */
     Tcl_UtfPrev, /* 656 */
-    0, /* 657 */
+    Tcl_FSTildeExpand, /* 657 */
     Tcl_ExternalToUtfDStringEx, /* 658 */
     Tcl_UtfToExternalDStringEx, /* 659 */
     Tcl_AsyncMarkFromSignal, /* 660 */

generic/tclTest.c

@@ -293,6 +293,7 @@ static Tcl_CmdProc	TestsetplatformCmd;
 static Tcl_ObjCmdProc2	TestSizeCmd;
 static Tcl_CmdProc	TeststaticlibraryCmd;
 static Tcl_CmdProc	TesttranslatefilenameCmd;
+static Tcl_ObjCmdProc	TestfstildeexpandCmd;
 static Tcl_CmdProc	TestupvarCmd;
 static Tcl_ObjCmdProc2	TestWrongNumArgsObjCmd;
 static Tcl_ObjCmdProc2	TestGetIndexFromObjStructObjCmd;
@@ -705,6 +706,8 @@ Tcltest_Init(
 	    NULL, NULL);
     Tcl_CreateCommand(interp, "testtranslatefilename",
 	    TesttranslatefilenameCmd, NULL, NULL);
+    Tcl_CreateObjCommand(interp, "testfstildeexpand",
+	    TestfstildeexpandCmd, NULL, NULL);
     Tcl_CreateCommand(interp, "testupvar", TestupvarCmd, NULL, NULL);
     Tcl_CreateCommand(interp, "testmainthread", TestmainthreadCmd, NULL,
 	    NULL);
@@ -4925,6 +4928,45 @@ TesttranslatefilenameCmd(
     return TCL_OK;
 }
 
+/*
+ *----------------------------------------------------------------------
+ *
+ * TestfstildeexpandCmd --
+ *
+ *	This procedure implements the "testfstildeexpand" command.
+ *	It is used to test the Tcl_FSTildeExpand command. It differs
+ *      from the script level "file tildeexpand" tests because of a
+ *	slightly different code path.
+ *
+ * Results:
+ *	A standard Tcl result.
+ *
+ * Side effects:
+ *	None.
+ *
+ *----------------------------------------------------------------------
+ */
+
+static int
+TestfstildeexpandCmd(
+    TCL_UNUSED(void *),
+    Tcl_Interp *interp,		/* Current interpreter. */
+    int objc,			/* Number of arguments. */
+    Tcl_Obj *const objv[])	/* The argument objects. */
+{
+    Tcl_DString buffer;
+
+    if (objc != 2) {
+	Tcl_WrongNumArgs(interp, 1, objv, "PATH");
+	return TCL_ERROR;
+    }
+    if (Tcl_FSTildeExpand(interp, Tcl_GetString(objv[1]), &buffer) != TCL_OK) {
+	return TCL_ERROR;
+    }
+    Tcl_SetObjResult(interp, Tcl_DStringToObj(&buffer));
+    return TCL_OK;
+}
+
 /*
  *----------------------------------------------------------------------
  *

library/clock.tcl

@@ -999,24 +999,29 @@ proc ::tcl::clock::SetupTimeZone { timezone {alias {}} } {
 		    LoadTimeZoneFile [string range $timezone 1 end]
 		}] && [catch {
 		    LoadZoneinfoFile [string range $timezone 1 end]
-		}]
+		} ret opts]
 	    } then {
+		dict unset opts -errorinfo
+		if {[lindex [dict get $opts -errorcode] 0] ne "CLOCK"} {
+		    dict set opts -errorcode [list CLOCK badTimeZone $timezone]
+		    set ret "time zone \"$timezone\" not found: $ret"
+		}
 		dict set TimeZoneBad $timezone 1
-		return -code error \
-		    -errorcode [list CLOCK badTimeZone $timezone] \
-		    "time zone \"$timezone\" not found"
+		return -options $opts $ret
 	    }
 	} elseif { ![catch {ParsePosixTimeZone $timezone} tzfields] } {
 	    # This looks like a POSIX time zone - try to process it
 
-	    if { [catch {ProcessPosixTimeZone $tzfields} data opts] } {
-		if { [lindex [dict get $opts -errorcode] 0] eq {CLOCK} } {
-		    dict unset opts -errorinfo
+	    if { [catch {ProcessPosixTimeZone $tzfields} ret opts] } {
+		dict unset opts -errorinfo
+		if {[lindex [dict get $opts -errorcode] 0] ne "CLOCK"} {
+		    dict set opts -errorcode [list CLOCK badTimeZone $timezone]
+		    set ret "time zone \"$timezone\" not found: $ret"
 		}
 		dict set TimeZoneBad $timezone 1
-		return -options $opts $data
+		return -options $opts $ret
 	    } else {
-		set TZData($timezone) $data
+		set TZData($timezone) $ret
 	    }
 
 	} else {
@@ -1027,7 +1032,7 @@ proc ::tcl::clock::SetupTimeZone { timezone {alias {}} } {
 	    # time zone file - this time without a colon
 
 	    if { [catch { LoadTimeZoneFile $timezone }]
-		 && [catch { LoadZoneinfoFile $timezone } - opts] } {
+		 && [catch { LoadZoneinfoFile $timezone } ret opts] } {
 
 		# Check may be a legacy zone:
 
@@ -1041,8 +1046,12 @@ proc ::tcl::clock::SetupTimeZone { timezone {alias {}} } {
 		}
 
 		dict unset opts -errorinfo
+		if {[lindex [dict get $opts -errorcode] 0] ne "CLOCK"} {
+		    dict set opts -errorcode [list CLOCK badTimeZone $timezone]
+		    set ret "time zone \"$timezone\" not found: $ret"
+		}
 		dict set TimeZoneBad $timezone 1
-		return -options $opts "time zone $timezone not found"
+		return -options $opts $ret
 	    }
 	    set TZData($timezone) $TZData(:$timezone)
 	}
@@ -1222,9 +1231,9 @@ proc ::tcl::clock::LoadTimeZoneFile { fileName } {
     # is security sensitive.  Make sure that the path name cannot escape the
     # given directory.
 
-    if { ![regexp {^[[.-.][:alpha:]_]+(?:/[[.-.][:alpha:]_]+)*$} $fileName] } {
+    if { [regexp {^[/\\]|^[a-zA-Z]+:|(?:^|[/\\])\.\.} $fileName] } {
 	return -code error \
-	    -errorcode [list CLOCK badTimeZone $:fileName] \
+	    -errorcode [list CLOCK badTimeZone :$fileName] \
 	    "time zone \":$fileName\" not valid"
     }
     try {
@@ -1262,17 +1271,23 @@ proc ::tcl::clock::LoadZoneinfoFile { fileName } {
     # is security sensitive.  Make sure that the path name cannot escape the
     # given directory.
 
-    if { ![regexp {^[[.-.][:alpha:]_]+(?:/[[.-.][:alpha:]_]+)*$} $fileName] } {
+    if { [regexp {^[/\\]|^[a-zA-Z]+:|(?:^|[/\\])\.\.} $fileName] } {
 	return -code error \
-	    -errorcode [list CLOCK badTimeZone $:fileName] \
+	    -errorcode [list CLOCK badTimeZone :$fileName] \
 	    "time zone \":$fileName\" not valid"
     }
+    set fname ""
     foreach d $ZoneinfoPaths {
 	set fname [file join $d $fileName]
 	if { [file readable $fname] && [file isfile $fname] } {
 	    break
 	}
-	unset fname
+	set fname ""
+    }
+    if {$fname eq ""} {
+	return -code error \
+	    -errorcode [list CLOCK badTimeZone :$fileName] \
+	    "time zone \":$fileName\" not found"
     }
     ReadZoneinfoFile $fileName $fname
 }