blob: 6bc92049777366a391aa4127a975bcb911752e4e (
plain)
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
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
|
#!/usr/bin/tclsh
# ------------------------------------------------------------------------
#
# chan.perf.tcl --
#
# This file provides performance tests for comparison of tcl-speed
# of channel 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-Chan {
namespace path {::tclTestPerf}
proc _get_test_chan {{bufSize 4096}} {
lassign [chan pipe] ch wch;
fconfigure $ch -translation lf -encoding utf-8 -buffersize $bufSize -buffering full
fconfigure $wch -translation lf -encoding utf-8 -buffersize $bufSize -buffering full
exec [info nameofexecutable] -- $bufSize >@$wch << {
set bufSize [lindex $::argv end]
fconfigure stdout -translation lf -encoding utf-8 -buffersize $bufSize -buffering full
set buf [string repeat test 1000]; # 4K
# write ~ 10*1M + 10*2M + 10*10M + 1*20M:
set i 0; while {$i < int((10*1e6 + 10*2e6 + 10*10e6 + 1*20e6)/4e3)} {
#puts -nonewline stdout $i\t
puts stdout $buf
#flush stdout; # don't flush to use full buffer
incr i
}
} &
close $wch
return $ch
}
# regression tests for [bug-da16d15574] (fix for [db4f2843cd]):
proc test-read-regress {{reptime {50000 10}}} {
_test_run -no-result $reptime {
# with 4KB buffersize:
setup { set ch [::tclTestPerf-Chan::_get_test_chan 4096]; fconfigure $ch -buffersize }
# 10 * 1M:
{read $ch [expr {int(1e6)}]}
# 10 * 2M:
{read $ch [expr {int(2e6)}]}
# 10 * 10M:
{read $ch [expr {int(10e6)}]}
# 1 * 20M:
{read $ch; break}
cleanup { close $ch }
# with 1MB buffersize:
setup { set ch [::tclTestPerf-Chan::_get_test_chan 1048576]; fconfigure $ch -buffersize }
# 10 * 1M:
{read $ch [expr {int(1e6)}]}
# 10 * 2M:
{read $ch [expr {int(2e6)}]}
# 10 * 10M:
{read $ch [expr {int(10e6)}]}
# 1 * 20M:
{read $ch; break}
cleanup { close $ch }
}
}
proc test {{reptime 1000}} {
test-read-regress
puts \n**OK**
}
}; # end of ::tclTestPerf-Chan
# ------------------------------------------------------------------------
# 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-Chan::test $in(-time)
}
|
