Add Tcl_FSTildeExpand and tests

6 files changed, 212 insertions, 39 deletions

diff --git a/generic/tcl.decls b/generic/tcl.decls
index 0b23f59..870a754 100644
--- a/generic/tcl.decls
+++ b/generic/tcl.decls
@@ -2517,6 +2517,11 @@ declare 689 {
 # ----- BASELINE -- FOR -- 8.7.0 / 9.0.0 ----- #
 
 declare 690 {
+    int Tcl_FSTildeExpand(Tcl_Interp *interp, const char *path,
+        Tcl_DString *dsPtr)
+}
+
+declare 691 {
     void TclUnusedStubEntry(void)
 }
 
diff --git a/generic/tclDecls.h b/generic/tclDecls.h
index ddca33a..c23b433 100644
--- a/generic/tclDecls.h
+++ b/generic/tclDecls.h
@@ -2023,6 +2023,9 @@ EXTERN Tcl_Obj *	Tcl_NewWideUIntObj(Tcl_WideUInt wideValue);
 EXTERN void		Tcl_SetWideUIntObj(Tcl_Obj *objPtr,
 				Tcl_WideUInt uwideValue);
 /* 690 */
+EXTERN int		Tcl_FSTildeExpand(Tcl_Interp *interp,
+				const char *path, Tcl_DString *dsPtr);
+/* 691 */
 EXTERN void		TclUnusedStubEntry(void);
 
 typedef struct {
@@ -2749,7 +2752,8 @@ typedef struct TclStubs {
     int (*tclUtfNcasecmp) (const char *s1, const char *s2, size_t n); /* 687 */
     Tcl_Obj * (*tcl_NewWideUIntObj) (Tcl_WideUInt wideValue); /* 688 */
     void (*tcl_SetWideUIntObj) (Tcl_Obj *objPtr, Tcl_WideUInt uwideValue); /* 689 */
-    void (*tclUnusedStubEntry) (void); /* 690 */
+    int (*tcl_FSTildeExpand) (Tcl_Interp *interp, const char *path, Tcl_DString *dsPtr); /* 690 */
+    void (*tclUnusedStubEntry) (void); /* 691 */
 } TclStubs;
 
 extern const TclStubs *tclStubsPtr;
@@ -4144,8 +4148,10 @@ extern const TclStubs *tclStubsPtr;
 	(tclStubsPtr->tcl_NewWideUIntObj) /* 688 */
 #define Tcl_SetWideUIntObj \
 	(tclStubsPtr->tcl_SetWideUIntObj) /* 689 */
+#define Tcl_FSTildeExpand \
+	(tclStubsPtr->tcl_FSTildeExpand) /* 690 */
 #define TclUnusedStubEntry \
-	(tclStubsPtr->tclUnusedStubEntry) /* 690 */
+	(tclStubsPtr->tclUnusedStubEntry) /* 691 */
 
 #endif /* defined(USE_TCL_STUBS) */
 
diff --git a/generic/tclPathObj.c b/generic/tclPathObj.c
index 258c288..0d876b1 100644
--- a/generic/tclPathObj.c
+++ b/generic/tclPathObj.c
@@ -2690,6 +2690,71 @@ TclGetHomeDirObj(
 /*
  *----------------------------------------------------------------------
  *
+ * 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 will be initialized irrespective of result
+ *	and 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;
+
+    assert(path);
+    assert(dsPtr);
+
+    if (path[0] != '~') {
+	Tcl_DStringInit(dsPtr);
+	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 */
+	return MakeTildeRelativePath(interp, NULL, path[1] ? 2 + path : NULL, dsPtr);
+    } else {
+        /* User name specified - ~user, ~user/... */
+        const char *user;
+        Tcl_DString dsUser;
+	int ret;
+
+	Tcl_DStringInit(&dsUser);
+        Tcl_DStringAppend(&dsUser, path+1, split-1);
+        user = Tcl_DStringValue(&dsUser);
+
+	/* path[split] is / for ~user/... or \0 for ~user */
+	ret = MakeTildeRelativePath(interp, user,
+		  path[split] ? &path[split + 1] : NULL, dsPtr);
+	Tcl_DStringFree(&dsUser);
+	return ret;
+    }
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
  * TclResolveTildePath --
  *
  *	If the passed path is begins with a tilde, does tilde resolution
@@ -2712,50 +2777,19 @@ TclResolveTildePath(
     Tcl_Obj *pathObj)
 {
     const char *path;
-    int len;
-    int split;
+    Tcl_Size len;
     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);
 }
 
diff --git a/generic/tclStubInit.c b/generic/tclStubInit.c
index 1ac6801..135b71c 100644
--- a/generic/tclStubInit.c
+++ b/generic/tclStubInit.c
@@ -1986,7 +1986,8 @@ const TclStubs tclStubs = {
     TclUtfNcasecmp, /* 687 */
     Tcl_NewWideUIntObj, /* 688 */
     Tcl_SetWideUIntObj, /* 689 */
-    TclUnusedStubEntry, /* 690 */
+    Tcl_FSTildeExpand, /* 690 */
+    TclUnusedStubEntry, /* 691 */
 };
 
 /* !END!: Do not edit above this line. */
diff --git a/generic/tclTest.c b/generic/tclTest.c
index d995046..79f7952 100644
--- a/generic/tclTest.c
+++ b/generic/tclTest.c
@@ -308,6 +308,7 @@ static Tcl_CmdProc	TestsetplatformCmd;
 static Tcl_ObjCmdProc	TestSizeCmd;
 static Tcl_CmdProc	TeststaticlibraryCmd;
 static Tcl_CmdProc	TesttranslatefilenameCmd;
+static Tcl_ObjCmdProc	TestfstildeexpandCmd;
 static Tcl_CmdProc	TestupvarCmd;
 static Tcl_ObjCmdProc2	TestWrongNumArgsObjCmd;
 static Tcl_ObjCmdProc	TestGetIndexFromObjStructObjCmd;
@@ -726,6 +727,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);
@@ -4943,6 +4946,45 @@ TesttranslatefilenameCmd(
 /*
  *----------------------------------------------------------------------
  *
+ * 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;
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
  * TestupvarCmd --
  *
  *	This procedure implements the "testupvar" command.  It is used
diff --git a/tests/fCmd.test b/tests/fCmd.test
index 2469762..2fd26c5 100644
--- a/tests/fCmd.test
+++ b/tests/fCmd.test
@@ -86,6 +86,7 @@ testConstraint fileSharing 0
 testConstraint notFileSharing 1
 testConstraint linkFile 1
 testConstraint linkDirectory 1
+testConstraint testfstildeexpand [llength [info commands testfstildeexpand]]
 
 # Several tests require need to match results against the Unix username
 set user {}
@@ -2669,9 +2670,15 @@ test fCmd-31.9 {file home USER does not follow env(HOME)} -setup {
     string tolower [file home $::tcl_platform(user)]
 } -match glob -result [gethomedirglob $::tcl_platform(user)]
 
+# file tildeexpand and testfstildexpand are identical in behavior
+# but tested separately as the former is a script wrapper that does some
+# sanitization/optimization while the latter is a raw call to Tcl_FSTildeExpand.
 test fCmd-32.1 {file tildeexpand ~} -body {
     file tildeexpand ~
 } -result [file join $::env(HOME)]
+test fCmd-32.1.1 {Tcl_FSTildeExpand ~} -constraints testfstildeexpand -body {
+    testfstildeexpand ~
+} -result [file join $::env(HOME)]
 test fCmd-32.2 {file tildeexpand ~ - obeys env} -setup {
     set ::env(HOME) $::env(HOME)/xxx
 } -cleanup {
@@ -2679,6 +2686,13 @@ test fCmd-32.2 {file tildeexpand ~ - obeys env} -setup {
 } -body {
     file tildeexpand ~
 } -result [file join $::env(HOME) xxx]
+test fCmd-32.2.1 {Tcl_FSTildeExpand ~ - obeys env} -setup {
+    set ::env(HOME) $::env(HOME)/xxx
+} -cleanup {
+    set ::env(HOME) [file dirname $::env(HOME)]
+} -constraints testfstildeexpand -body {
+    testfstildeexpand ~
+} -result [file join $::env(HOME) xxx]
 test fCmd-32.3 {file tildeexpand ~ - error} -setup {
     set saved $::env(HOME)
     unset ::env(HOME)
@@ -2687,6 +2701,14 @@ test fCmd-32.3 {file tildeexpand ~ - error} -setup {
 } -body {
     file tildeexpand ~
 } -returnCodes error -result {couldn't find HOME environment variable to expand path}
+test fCmd-32.3.1 {Tcl_FSTildeExpand ~ - error} -setup {
+    set saved $::env(HOME)
+    unset ::env(HOME)
+} -cleanup {
+    set ::env(HOME) $saved
+} -constraints testfstildeexpand -body {
+    testfstildeexpand ~
+} -returnCodes error -result {couldn't find HOME environment variable to expand path}
 test fCmd-32.4 {
     file tildeexpand ~ - relative path. Following 8.x ~ expansion behavior, relative
     paths are not made absolute
@@ -2698,51 +2720,107 @@ test fCmd-32.4 {
 } -body {
     file tildeexpand ~
 } -result relative/path
+test fCmd-32.4.1 {
+    Tcl_FSTildeExpand ~ - relative path. Following 8.x ~ expansion behavior, relative
+    paths are not made absolute
+} -setup {
+    set saved $::env(HOME)
+    set ::env(HOME) relative/path
+} -cleanup {
+    set ::env(HOME) $saved
+} -constraints testfstildeexpand -body {
+    testfstildeexpand ~
+} -result relative/path
 test fCmd-32.5 {file tildeexpand ~USER} -body {
     # Note - as in 8.x this form does NOT necessarily give same result as
     # env(HOME) even when user is current user. Assume result contains user
     # name, else not sure how to check
     string tolower [file tildeexpand ~$::tcl_platform(user)]
 } -match glob -result [gethomedirglob $::tcl_platform(user)]
+test fCmd-32.5.1 {Tcl_FSTildeExpand ~USER} -constraints testfstildeexpand -body {
+    # Note - as in 8.x this form does NOT necessarily give same result as
+    # env(HOME) even when user is current user. Assume result contains user
+    # name, else not sure how to check
+    string tolower [testfstildeexpand ~$::tcl_platform(user)]
+} -match glob -result [gethomedirglob $::tcl_platform(user)]
 test fCmd-32.6 {file tildeexpand ~UNKNOWNUSER} -body {
     file tildeexpand ~nosuchuser
 } -returnCodes error -result {user "nosuchuser" doesn't exist}
+test fCmd-32.6.1 {Tcl_FSTildeExpand ~UNKNOWNUSER} -constraints testfstildeexpand -body {
+    testfstildeexpand ~nosuchuser
+} -returnCodes error -result {user "nosuchuser" doesn't exist}
 test fCmd-32.7 {file tildeexpand ~extra arg} -body {
     file tildeexpand ~ arg
 } -returnCodes error -result {wrong # args: should be "file tildeexpand path"}
+test fCmd-32.7.1 {Tcl_FSTildeExpand ~extra arg} -constraints testfstildeexpand -body {
+    testfstildeexpand ~ arg
+} -returnCodes error -result {wrong # args: should be "testfstildeexpand PATH"}
 test fCmd-32.8 {file tildeexpand ~/path} -body {
     file tildeexpand ~/foo
 } -result [file join $::env(HOME)/foo]
+test fCmd-32.8.1 {Tcl_FSTildeExpand ~/path} -constraints testfstildeexpand -body {
+    testfstildeexpand ~/foo
+} -result [file join $::env(HOME)/foo]
 test fCmd-32.9 {file tildeexpand ~USER/bar} -body {
     # Note - as in 8.x this form does NOT necessarily give same result as
     # env(HOME) even when user is current user. Assume result contains user
     # name, else not sure how to check
     string tolower [file tildeexpand ~$::tcl_platform(user)/bar]
 } -match glob -result [file join [gethomedirglob $::tcl_platform(user)] bar]
+test fCmd-32.9.1 {Tcl_FSTildeExpand ~USER/bar} -constraints testfstildeexpand -body {
+    # Note - as in 8.x this form does NOT necessarily give same result as
+    # env(HOME) even when user is current user. Assume result contains user
+    # name, else not sure how to check
+    string tolower [testfstildeexpand ~$::tcl_platform(user)/bar]
+} -match glob -result [file join [gethomedirglob $::tcl_platform(user)] bar]
 test fCmd-32.10 {file tildeexpand ~UNKNOWNUSER} -body {
     file tildeexpand ~nosuchuser/foo
 } -returnCodes error -result {user "nosuchuser" doesn't exist}
+test fCmd-32.10.1 {Tcl_FSTildeExpand ~UNKNOWNUSER} -constraints testfstildeexpand -body {
+    testfstildeexpand ~nosuchuser/foo
+} -returnCodes error -result {user "nosuchuser" doesn't exist}
 test fCmd-32.11 {file tildeexpand /~/path} -body {
     file tildeexpand /~/foo
 } -result /~/foo
+test fCmd-32.11.1 {Tcl_FSTildeExpand /~/path} -constraints testfstildeexpand -body {
+    testfstildeexpand /~/foo
+} -result /~/foo
 test fCmd-32.12 {file tildeexpand /~user/path} -body {
     file tildeexpand /~$::tcl_platform(user)/foo
 } -result /~$::tcl_platform(user)/foo
+test fCmd-32.12.1 {Tcl_FSTildeExpand /~user/path} -constraints testfstildeexpand -body {
+    testfstildeexpand /~$::tcl_platform(user)/foo
+} -result /~$::tcl_platform(user)/foo
 test fCmd-32.13 {file tildeexpand ./~} -body {
     file tildeexpand ./~
 } -result ./~
+test fCmd-32.13.1 {Tcl_FSTildeExpand ./~} -constraints testfstildeexpand -body {
+    testfstildeexpand ./~
+} -result ./~
 test fCmd-32.14 {file tildeexpand relative/path} -body {
     file tildeexpand relative/path
 } -result relative/path
+test fCmd-32.14.1 {Tcl_FSTildeExpand relative/path} -constraints testfstildeexpand -body {
+    testfstildeexpand relative/path
+} -result relative/path
 test fCmd-32.15 {file tildeexpand ~\\path} -body {
     file tildeexpand ~\\foo
 } -constraints win -result [file join $::env(HOME)/foo]
+test fCmd-32.15.1 {Tcl_FSTildeExpand ~\\path} -constraints testfstildeexpand -body {
+    testfstildeexpand ~\\foo
+} -constraints win -result [file join $::env(HOME)/foo]
 test fCmd-32.16 {file tildeexpand ~USER\\bar} -body {
     # Note - as in 8.x this form does NOT necessarily give same result as
     # env(HOME) even when user is current user. Assume result contains user
     # name, else not sure how to check
     string tolower [file tildeexpand ~$::tcl_platform(user)\\bar]
 } -constraints win -match glob -result [file join [gethomedirglob $::tcl_platform(user)] bar]
+test fCmd-32.16.1 {Tcl_FSTildeExpand ~USER\\bar} -constraints testfstildeexpand -body {
+    # Note - as in 8.x this form does NOT necessarily give same result as
+    # env(HOME) even when user is current user. Assume result contains user
+    # name, else not sure how to check
+    string tolower [testfstildeexpand ~$::tcl_platform(user)\\bar]
+} -constraints win -match glob -result [file join [gethomedirglob $::tcl_platform(user)] bar]
 test fCmd-32.17 {file tildeexpand ~USER does not mirror HOME} -setup {
     set ::env(HOME) [file join $::env(HOME) foo]
 } -cleanup {
@@ -2750,6 +2828,13 @@ test fCmd-32.17 {file tildeexpand ~USER does not mirror HOME} -setup {
 } -body {
     string tolower [file tildeexpand ~$::tcl_platform(user)]
 } -match glob -result [gethomedirglob $::tcl_platform(user)]
+test fCmd-32.17.1 {Tcl_FSTildeExpand ~USER does not mirror HOME} -setup {
+    set ::env(HOME) [file join $::env(HOME) foo]
+} -cleanup {
+    set ::env(HOME) [file dirname $::env(HOME)]
+} -constraints testfstildeexpand -body {
+    string tolower [testfstildeexpand ~$::tcl_platform(user)]
+} -match glob -result [gethomedirglob $::tcl_platform(user)]
 
 
 # cleanup