1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
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)
}
|
