added performance regression tests illustrating [02d5d65d70adab97]

1 files changed, 77 insertions, 0 deletions

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)
+}