-- cgit v0.12 From bb8c0eb0333ac22c7bd5f1936a355c1bb232b345 Mon Sep 17 00:00:00 2001 From: apnadkarni Date: Wed, 11 Sep 2024 03:04:10 +0000 Subject: Add Tcl_FSTildeExpand and tests --- generic/tcl.decls | 5 +++ generic/tclDecls.h | 10 ++++- generic/tclPathObj.c | 106 +++++++++++++++++++++++++++++++++----------------- generic/tclStubInit.c | 3 +- generic/tclTest.c | 42 ++++++++++++++++++++ tests/fCmd.test | 85 ++++++++++++++++++++++++++++++++++++++++ 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 -- cgit v0.12 From 505cc6230f5c97a318bcaa858d673a961e36376c Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Sat, 5 Oct 2024 21:00:47 +0000 Subject: Move new stub entry to 657, which is slightly better --- generic/tcl.decls | 11 ++++++----- generic/tclDecls.h | 19 ++++++++----------- generic/tclStubInit.c | 5 ++--- 3 files changed, 16 insertions(+), 19 deletions(-) diff --git a/generic/tcl.decls b/generic/tcl.decls index 870a754..e490138 100644 --- a/generic/tcl.decls +++ b/generic/tcl.decls @@ -2423,6 +2423,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, @@ -2517,11 +2523,6 @@ 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 c23b433..e2149a8 100644 --- a/generic/tclDecls.h +++ b/generic/tclDecls.h @@ -1948,7 +1948,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, @@ -2023,9 +2025,6 @@ 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 { @@ -2719,7 +2718,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 */ @@ -2752,8 +2751,7 @@ 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 */ - int (*tcl_FSTildeExpand) (Tcl_Interp *interp, const char *path, Tcl_DString *dsPtr); /* 690 */ - void (*tclUnusedStubEntry) (void); /* 691 */ + void (*tclUnusedStubEntry) (void); /* 690 */ } TclStubs; extern const TclStubs *tclStubsPtr; @@ -4094,7 +4092,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 \ @@ -4148,10 +4147,8 @@ 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) /* 691 */ + (tclStubsPtr->tclUnusedStubEntry) /* 690 */ #endif /* defined(USE_TCL_STUBS) */ diff --git a/generic/tclStubInit.c b/generic/tclStubInit.c index 135b71c..032ed77 100644 --- a/generic/tclStubInit.c +++ b/generic/tclStubInit.c @@ -1953,7 +1953,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 */ @@ -1986,8 +1986,7 @@ const TclStubs tclStubs = { TclUtfNcasecmp, /* 687 */ Tcl_NewWideUIntObj, /* 688 */ Tcl_SetWideUIntObj, /* 689 */ - Tcl_FSTildeExpand, /* 690 */ - TclUnusedStubEntry, /* 691 */ + TclUnusedStubEntry, /* 690 */ }; /* !END!: Do not edit above this line. */ -- cgit v0.12 From 0921fce0d650541e582ea55ffdda9af3378f7806 Mon Sep 17 00:00:00 2001 From: apnadkarni Date: Wed, 30 Oct 2024 11:24:39 +0000 Subject: Add Tcl_FSTildeExpand manpage. Do not depend on caller to clean up output DString on error --- doc/FileSystem.3 | 20 +++++++++++++++++++- generic/tclPathObj.c | 17 ++++++++++------- 2 files changed, 29 insertions(+), 8 deletions(-) diff --git a/doc/FileSystem.3 b/doc/FileSystem.3 index b015133..123c4e4 100644 --- a/doc/FileSystem.3 +++ b/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 \fR @@ -141,6 +141,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 @@ -288,6 +293,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 @@ -786,6 +793,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 diff --git a/generic/tclPathObj.c b/generic/tclPathObj.c index 0d876b1..84efd27 100644 --- a/generic/tclPathObj.c +++ b/generic/tclPathObj.c @@ -2697,8 +2697,7 @@ TclGetHomeDirObj( * 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. + * The output dsPtr must be cleared by caller on success. * * Results: * TCL_OK - path did not contain leading ~ or it was successful resolved @@ -2713,12 +2712,13 @@ int Tcl_FSTildeExpand( { Tcl_Size split; + int result; assert(path); assert(dsPtr); + Tcl_DStringInit(dsPtr); if (path[0] != '~') { - Tcl_DStringInit(dsPtr); Tcl_DStringAppend(dsPtr, path, -1); return TCL_OK; } @@ -2733,23 +2733,26 @@ int Tcl_FSTildeExpand( if (split == 1) { /* No user name specified '~' or '~/...' -> current user */ - return MakeTildeRelativePath(interp, NULL, path[1] ? 2 + path : NULL, dsPtr); + result = 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, + result = MakeTildeRelativePath(interp, user, path[split] ? &path[split + 1] : NULL, dsPtr); Tcl_DStringFree(&dsUser); - return ret; } + if (result != TCL_OK) { + /* Do not rely on caller to free in case of errors */ + Tcl_DStringFree(dsPtr); + } + return result; } /* -- cgit v0.12