From 6428e3e32a4f28750bb6396f7ad9b8b7acf25655 Mon Sep 17 00:00:00 2001 From: sebres Date: Fri, 13 Sep 2024 11:51:24 +0000 Subject: added performance regression tests illustrating [02d5d65d70adab97] --- tests-perf/file.perf.tcl | 77 ++++++++++++++++++++++++++++++++++++++++++++++++ 1 file changed, 77 insertions(+) create mode 100644 tests-perf/file.perf.tcl diff --git a/tests-perf/file.perf.tcl b/tests-perf/file.perf.tcl new file mode 100644 index 0000000..53dd4cc --- /dev/null +++ b/tests-perf/file.perf.tcl @@ -0,0 +1,77 @@ +#!/usr/bin/tclsh + +# ------------------------------------------------------------------------ +# +# file.perf.tcl -- +# +# This file provides performance tests for comparison of tcl-speed +# of file commands and subsystem. +# +# ------------------------------------------------------------------------ +# +# Copyright (c) 2024 Serg G. Brester (aka sebres) +# +# See the file "license.terms" for information on usage and redistribution +# of this file. +# + + +if {![namespace exists ::tclTestPerf]} { + source -encoding utf-8 [file join [file dirname [info script]] test-performance.tcl] +} + + +namespace eval ::tclTestPerf-File { + +namespace path {::tclTestPerf} + +proc _get_new_file_path_obj [list [list p [info script]]] { + # always generate new string object here (ensure it is not a "cached" object of type path): + string trimright "$p "; # costs of object "creation" smaller than 1 microsecond +} + +# regression tests for bug-02d5d65d70adab97 (fix for [02d5d65d70adab97]): +proc test-file-access-regress {{reptime 1000}} { + _test_run -no-result $reptime { + setup { set fn [::tclTestPerf-File::_get_new_file_path_obj] } + # file exists on "cached" file path: + { file exists $fn } + # file exists on not "cached" (fresh generated) file path: + { set fn [::tclTestPerf-File::_get_new_file_path_obj]; file exists $fn } + + setup { set fn [::tclTestPerf-File::_get_new_file_path_obj] } + # file attributes on "cached" file path: + { file attributes $fn -readonly } + # file attributes on not "cached" (fresh generated) file path: + { set fn [::tclTestPerf-File::_get_new_file_path_obj]; file attributes $fn -readonly } + + setup { set fn [::tclTestPerf-File::_get_new_file_path_obj] } + # file stat on "cached" file path: + { file stat $fn st } + # file stat on not "cached" (fresh generated) file path: + { set fn [::tclTestPerf-File::_get_new_file_path_obj]; file stat $fn st } + + setup { set fn [::tclTestPerf-File::_get_new_file_path_obj] } + # touch on "cached" file path: + { close [open $fn rb] } + # touch on not "cached" (fresh generated) file path: + { set fn [::tclTestPerf-File::_get_new_file_path_obj]; close [open $fn rb] } + } +} + +proc test {{reptime 1000}} { + test-file-access-regress $reptime + + puts \n**OK** +} + +}; # end of ::tclTestPerf-File + +# ------------------------------------------------------------------------ + +# if calling direct: +if {[info exists ::argv0] && [file tail $::argv0] eq [file tail [info script]]} { + array set in {-time 500} + array set in $argv + ::tclTestPerf-File::test $in(-time) +} -- cgit v0.12 From 2474f2092fe30282bc4413e4ea29182b9f37c849 Mon Sep 17 00:00:00 2001 From: sebres Date: Fri, 13 Sep 2024 11:57:41 +0000 Subject: TclFSCwdIsNative may return wrong result when cwd is not initialized in TSD (if pwd/cd never called for this thread) --- generic/tclIOUtil.c | 5 +++++ 1 file changed, 5 insertions(+) diff --git a/generic/tclIOUtil.c b/generic/tclIOUtil.c index e630702..67ee48b 100644 --- a/generic/tclIOUtil.c +++ b/generic/tclIOUtil.c @@ -469,6 +469,11 @@ TclFSCwdIsNative(void) { ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&fsDataKey); + /* if not yet initialized - ensure we'll once obtain cwd */ + if (!tsdPtr->cwdPathEpoch) { + Tcl_FSGetCwd(NULL); + } + if (tsdPtr->cwdClientData != NULL) { return 1; } else { -- cgit v0.12 From fea5ae7451b1d841acd6266b003389aca6093b1a Mon Sep 17 00:00:00 2001 From: sebres Date: Fri, 13 Sep 2024 12:02:53 +0000 Subject: even if cwd is non native, but path is not relative we can safely use translated path instead of normalized path; fixes file access regression [02d5d65d70adab97] --- unix/tclUnixFile.c | 4 ++-- win/tclWinFile.c | 4 ++-- 2 files changed, 4 insertions(+), 4 deletions(-) diff --git a/unix/tclUnixFile.c b/unix/tclUnixFile.c index c39e7b6..9769b13 100644 --- a/unix/tclUnixFile.c +++ b/unix/tclUnixFile.c @@ -1076,9 +1076,9 @@ TclNativeCreateNativeRep( Tcl_Obj *validPathPtr; int len; - if (TclFSCwdIsNative()) { + if (TclFSCwdIsNative() || Tcl_FSGetPathType(pathPtr) == TCL_PATH_ABSOLUTE) { /* - * The cwd is native, which means we can use the translated path + * The cwd is native (or path is absolute), use the translated path * without worrying about normalization (this will also usually be * shorter so the utf-to-external conversion will be somewhat faster). */ diff --git a/win/tclWinFile.c b/win/tclWinFile.c index 633e2ce..b8e2e30 100644 --- a/win/tclWinFile.c +++ b/win/tclWinFile.c @@ -3036,9 +3036,9 @@ TclNativeCreateNativeRep( Tcl_DString ds; Tcl_Encoding utf8; - if (TclFSCwdIsNative()) { + if (TclFSCwdIsNative() || Tcl_FSGetPathType(pathPtr) == TCL_PATH_ABSOLUTE) { /* - * The cwd is native, which means we can use the translated path + * The cwd is native (or path is absolute), use the translated path * without worrying about normalization (this will also usually be * shorter so the utf-to-external conversion will be somewhat faster). */ -- cgit v0.12 From 1dab1b639f04dd5e46745e32cddba2475ae9a1d3 Mon Sep 17 00:00:00 2001 From: sebres Date: Fri, 13 Sep 2024 12:07:55 +0000 Subject: because the normalization is very expensive (see [02d5d65d70adab97]), don't invoke it for native or absolute paths, so aviod normalization "just to ensure we return the correct error messages under some circumstances" --- generic/tclIOUtil.c | 9 +++++++-- 1 file changed, 7 insertions(+), 2 deletions(-) diff --git a/generic/tclIOUtil.c b/generic/tclIOUtil.c index 67ee48b..807c664 100644 --- a/generic/tclIOUtil.c +++ b/generic/tclIOUtil.c @@ -2237,10 +2237,15 @@ Tcl_FSOpenFileChannel( /* * We need this just to ensure we return the correct error messages under - * some circumstances. + * some circumstances (relative paths only), so because the normalization + * is very expensive, don't invoke it for native or absolute paths. */ - if (Tcl_FSGetNormalizedPath(interp, pathPtr) == NULL) { + if ( + !TclFSCwdIsNative() && + Tcl_FSGetPathType(pathPtr) != TCL_PATH_ABSOLUTE && + Tcl_FSGetNormalizedPath(interp, pathPtr) == NULL + ) { return NULL; } -- cgit v0.12 From bddda240611ea5ba0974d4e6d424c29f29f7057c Mon Sep 17 00:00:00 2001 From: sebres Date: Fri, 13 Sep 2024 12:37:53 +0000 Subject: amend considering possible tilde expansion in absolute paths starting with ~, so proper error message by tests *io-40.17 "tilde substitution in open" --- generic/tclIOUtil.c | 11 +++++++++-- 1 file changed, 9 insertions(+), 2 deletions(-) diff --git a/generic/tclIOUtil.c b/generic/tclIOUtil.c index 807c664..c553ef3 100644 --- a/generic/tclIOUtil.c +++ b/generic/tclIOUtil.c @@ -2239,11 +2239,18 @@ Tcl_FSOpenFileChannel( * We need this just to ensure we return the correct error messages under * some circumstances (relative paths only), so because the normalization * is very expensive, don't invoke it for native or absolute paths. + * Note: TODO - check one needs consider tilde expansion after TIP#602, + * (proper error message of tests *io-40.17 "tilde substitution in open") */ if ( - !TclFSCwdIsNative() && - Tcl_FSGetPathType(pathPtr) != TCL_PATH_ABSOLUTE && + ( + ( + !TclFSCwdIsNative() && + (Tcl_FSGetPathType(pathPtr) != TCL_PATH_ABSOLUTE) + ) || + (*TclGetString(pathPtr) == '~') /* possible tilde expansion */ + ) && Tcl_FSGetNormalizedPath(interp, pathPtr) == NULL ) { return NULL; -- cgit v0.12 From f2b14cb7f00034cf7c9ee3e5681e4c912ca7ff9c Mon Sep 17 00:00:00 2001 From: sebres Date: Fri, 13 Sep 2024 14:26:26 +0000 Subject: small amend: move the normalization to the block where the error message really needed --- generic/tclIOUtil.c | 21 --------------------- unix/tclUnixChan.c | 19 +++++++++++++++++++ win/tclWinChan.c | 21 +++++++++++++++++++++ 3 files changed, 40 insertions(+), 21 deletions(-) diff --git a/generic/tclIOUtil.c b/generic/tclIOUtil.c index c553ef3..847d191 100644 --- a/generic/tclIOUtil.c +++ b/generic/tclIOUtil.c @@ -2235,27 +2235,6 @@ Tcl_FSOpenFileChannel( const Tcl_Filesystem *fsPtr; Tcl_Channel retVal = NULL; - /* - * We need this just to ensure we return the correct error messages under - * some circumstances (relative paths only), so because the normalization - * is very expensive, don't invoke it for native or absolute paths. - * Note: TODO - check one needs consider tilde expansion after TIP#602, - * (proper error message of tests *io-40.17 "tilde substitution in open") - */ - - if ( - ( - ( - !TclFSCwdIsNative() && - (Tcl_FSGetPathType(pathPtr) != TCL_PATH_ABSOLUTE) - ) || - (*TclGetString(pathPtr) == '~') /* possible tilde expansion */ - ) && - Tcl_FSGetNormalizedPath(interp, pathPtr) == NULL - ) { - return NULL; - } - fsPtr = Tcl_FSGetFileSystemForPath(pathPtr); if (fsPtr != NULL && fsPtr->openFileChannelProc != NULL) { int mode, seekFlag, binary; diff --git a/unix/tclUnixChan.c b/unix/tclUnixChan.c index 1844a23..e072cd7 100644 --- a/unix/tclUnixChan.c +++ b/unix/tclUnixChan.c @@ -12,6 +12,7 @@ */ #include "tclInt.h" /* Internal definitions for Tcl. */ +#include "tclFileSystem.h" #include "tclIO.h" /* To get Channel type declaration. */ #undef SUPPORTS_TTY @@ -1418,6 +1419,24 @@ TclpOpenFileChannel( native = (const char *)Tcl_FSGetNativePath(pathPtr); if (native == NULL) { if (interp != (Tcl_Interp *) NULL) { + /* + * We need this just to ensure we return the correct error messages under + * some circumstances (relative paths only), so because the normalization + * is very expensive, don't invoke it for native or absolute paths. + */ + if ( + ( + ( + !TclFSCwdIsNative() && + (Tcl_FSGetPathType(pathPtr) != TCL_PATH_ABSOLUTE) + ) || + (*TclGetString(pathPtr) == '~') /* possible tilde expansion */ + ) && + Tcl_FSGetNormalizedPath(interp, pathPtr) == NULL + ) { + return NULL; + } + Tcl_AppendResult(interp, "couldn't open \"", TclGetString(pathPtr), "\": filename is invalid on this platform", (char *)NULL); diff --git a/win/tclWinChan.c b/win/tclWinChan.c index 666a0b1..0199a37 100644 --- a/win/tclWinChan.c +++ b/win/tclWinChan.c @@ -11,6 +11,7 @@ */ #include "tclWinInt.h" +#include "tclFileSystem.h" #include "tclIO.h" /* @@ -866,6 +867,26 @@ TclpOpenFileChannel( nativeName = (const WCHAR *)Tcl_FSGetNativePath(pathPtr); if (nativeName == NULL) { if (interp != (Tcl_Interp *) NULL) { + /* + * We need this just to ensure we return the correct error messages under + * some circumstances (relative paths only), so because the normalization + * is very expensive, don't invoke it for native or absolute paths. + * Note: TODO - check one needs consider tilde expansion after TIP#602, + * (proper error message of tests *io-40.17 "tilde substitution in open") + */ + if ( + ( + ( + !TclFSCwdIsNative() && + (Tcl_FSGetPathType(pathPtr) != TCL_PATH_ABSOLUTE) + ) || + (*TclGetString(pathPtr) == '~') /* possible tilde expansion */ + ) && + Tcl_FSGetNormalizedPath(interp, pathPtr) == NULL + ) { + return NULL; + } + Tcl_AppendResult(interp, "couldn't open \"", TclGetString(pathPtr), "\": filename is invalid on this platform", NULL); -- cgit v0.12 From a680486042c9cb4f65899abb15dbc6bdcec5ec0a Mon Sep 17 00:00:00 2001 From: sebres Date: Tue, 17 Sep 2024 14:19:53 +0000 Subject: improve comments (no functional changes) --- unix/tclUnixChan.c | 2 ++ win/tclWinChan.c | 2 +- 2 files changed, 3 insertions(+), 1 deletion(-) diff --git a/unix/tclUnixChan.c b/unix/tclUnixChan.c index e072cd7..7ec0770 100644 --- a/unix/tclUnixChan.c +++ b/unix/tclUnixChan.c @@ -1423,6 +1423,8 @@ TclpOpenFileChannel( * We need this just to ensure we return the correct error messages under * some circumstances (relative paths only), so because the normalization * is very expensive, don't invoke it for native or absolute paths. + * Note: since paths starting with ~ are absolute, it also considers tilde expansion, + * (proper error message of tests *io-40.17 "tilde substitution in open") */ if ( ( diff --git a/win/tclWinChan.c b/win/tclWinChan.c index 0199a37..98cba33 100644 --- a/win/tclWinChan.c +++ b/win/tclWinChan.c @@ -871,7 +871,7 @@ TclpOpenFileChannel( * We need this just to ensure we return the correct error messages under * some circumstances (relative paths only), so because the normalization * is very expensive, don't invoke it for native or absolute paths. - * Note: TODO - check one needs consider tilde expansion after TIP#602, + * Note: since paths starting with ~ are absolute, it also considers tilde expansion, * (proper error message of tests *io-40.17 "tilde substitution in open") */ if ( -- cgit v0.12 From 906c3058eab5d871756de4de703f2d75d7363574 Mon Sep 17 00:00:00 2001 From: sebres Date: Tue, 17 Sep 2024 15:17:44 +0000 Subject: fixes further normalization bottleneck of 8.7+ [02d5d65d70adab97], guess [411f52ed87e313dd49e2] too (zipfs now) --- generic/tclZipfs.c | 23 ++++++++++++++++++++--- 1 file changed, 20 insertions(+), 3 deletions(-) diff --git a/generic/tclZipfs.c b/generic/tclZipfs.c index ee280ee..d8ac050 100644 --- a/generic/tclZipfs.c +++ b/generic/tclZipfs.c @@ -5858,9 +5858,26 @@ ZipFSPathInFilesystemProc( Tcl_Size len; char *path; - pathPtr = Tcl_FSGetNormalizedPath(NULL, pathPtr); - if (!pathPtr) { - return -1; + if (TclFSCwdIsNative() || Tcl_FSGetPathType(pathPtr) == TCL_PATH_ABSOLUTE) { + /* + * The cwd is native (or path is absolute), use the translated path + * without worrying about normalization (this will also usually be + * shorter so the utf-to-external conversion will be somewhat faster). + */ + + pathPtr = Tcl_FSGetTranslatedPath(NULL, pathPtr); + if (pathPtr == NULL) { + return -1; + } + } else { + /* + * Make sure the normalized path is set. + */ + + pathPtr = Tcl_FSGetNormalizedPath(NULL, pathPtr); + if (!pathPtr) { + return -1; + } } path = TclGetStringFromObj(pathPtr, &len); -- cgit v0.12 From 617e81d982e512223c456a95df28eab0141a4f21 Mon Sep 17 00:00:00 2001 From: sebres Date: Tue, 17 Sep 2024 15:25:38 +0000 Subject: small amend improving (path in zipfs) lookup --- generic/tclZipfs.c | 5 ++++- 1 file changed, 4 insertions(+), 1 deletion(-) diff --git a/generic/tclZipfs.c b/generic/tclZipfs.c index d8ac050..84e4d34 100644 --- a/generic/tclZipfs.c +++ b/generic/tclZipfs.c @@ -5886,7 +5886,10 @@ ZipFSPathInFilesystemProc( * and sufficient condition as zipfs mounts at arbitrary paths are * not permitted (unlike Androwish). */ - return strncmp(path, ZIPFS_VOLUME, ZIPFS_VOLUME_LEN) ? -1 : TCL_OK; + return ( + (len < ZIPFS_VOLUME_LEN) || + strncmp(path, ZIPFS_VOLUME, ZIPFS_VOLUME_LEN) + ) ? -1 : TCL_OK; } /* -- cgit v0.12