merge 8.6 (fix attempt for [02d5d65d70adab97], however the small bottleneck is still visible)

6 files changed, 128 insertions, 12 deletions

diff --git a/generic/tclIOUtil.c b/generic/tclIOUtil.c
index da21664..2282dac 100644
--- a/generic/tclIOUtil.c
+++ b/generic/tclIOUtil.c
@@ -452,6 +452,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 {
@@ -2202,14 +2207,6 @@ Tcl_FSOpenFileChannel(
     const Tcl_Filesystem *fsPtr;
     Tcl_Channel retVal = NULL;
 
-
-    if (Tcl_FSGetNormalizedPath(interp, pathPtr) == NULL) {
-	/*
-	 * Return the correct error message.
-	 */
-	return NULL;
-    }
-
     fsPtr = Tcl_FSGetFileSystemForPath(pathPtr);
     if (fsPtr != NULL && fsPtr->openFileChannelProc != NULL) {
 	int mode, modeFlags;
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)
+}
diff --git a/unix/tclUnixChan.c b/unix/tclUnixChan.c
index b9b04ef..55287cc 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
@@ -1844,6 +1845,26 @@ 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.
+	     * 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 (
+		(
+		  (
+		    !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/unix/tclUnixFile.c b/unix/tclUnixFile.c
index 2ddcfce..f3fd730 100644
--- a/unix/tclUnixFile.c
+++ b/unix/tclUnixFile.c
@@ -1082,9 +1082,9 @@ TclNativeCreateNativeRep(
     Tcl_Obj *validPathPtr;
     Tcl_Size 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/tclWinChan.c b/win/tclWinChan.c
index 7334f1b..f56ff38 100644
--- a/win/tclWinChan.c
+++ b/win/tclWinChan.c
@@ -11,6 +11,7 @@
  */
 
 #include "tclWinInt.h"
+#include "tclFileSystem.h"
 #include "tclIO.h"
 
 /*
@@ -1084,6 +1085,26 @@ TclpOpenFileChannel(
     nativeName = (const WCHAR *)Tcl_FSGetNativePath(pathPtr);
     if (nativeName == NULL) {
 	if (interp) {
+	    /*
+	     * 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 (
+		(
+		  (
+		    !TclFSCwdIsNative() &&
+		    (Tcl_FSGetPathType(pathPtr) != TCL_PATH_ABSOLUTE)
+		  ) ||
+		  (*TclGetString(pathPtr) == '~')  /* possible tilde expansion */
+		) &&
+		Tcl_FSGetNormalizedPath(interp, pathPtr) == NULL
+	    ) {
+		return NULL;
+	    }
+
 	    Tcl_SetObjResult(interp, Tcl_ObjPrintf(
 		    "couldn't open \"%s\": filename is invalid on this platform",
 		    TclGetString(pathPtr)));
diff --git a/win/tclWinFile.c b/win/tclWinFile.c
index 9cb795f..1335073 100644
--- a/win/tclWinFile.c
+++ b/win/tclWinFile.c
@@ -3037,9 +3037,9 @@ TclNativeCreateNativeRep(
     Tcl_Size len;
     WCHAR *wp;
 
-    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).
 	 */