merge 8.6

4 files changed, 134 insertions, 5 deletions

diff --git a/generic/tclIO.c b/generic/tclIO.c
index 3b36457..7e7d88c 100644
--- a/generic/tclIO.c
+++ b/generic/tclIO.c
@@ -6322,8 +6322,9 @@ ReadChars(
     int factor = *factorPtr;
     int dstLimit = TCL_UTF_MAX - 1 + toRead * factor / UTF_EXPANSION_FACTOR;
 
+    if (dstLimit <= 0) dstLimit = INT_MAX; /* avoid overflow */
     (void) TclGetStringFromObj(objPtr, &numBytes);
-    Tcl_AppendToObj(objPtr, NULL, dstLimit);
+    TclAppendUtfToUtf(objPtr, NULL, dstLimit);
     if (toRead == srcLen) {
 	unsigned int size;
 
diff --git a/generic/tclInt.h b/generic/tclInt.h
index d29ea37..73e1915 100644
--- a/generic/tclInt.h
+++ b/generic/tclInt.h
@@ -3085,12 +3085,14 @@ struct Tcl_LoadHandle_ {
  *----------------------------------------------------------------
  */
 
-MODULE_SCOPE void	TclAppendBytesToByteArray(Tcl_Obj *objPtr,
-			    const unsigned char *bytes, Tcl_Size len);
 MODULE_SCOPE void	TclAdvanceContinuations(Tcl_Size *line, Tcl_Size **next,
 			    int loc);
 MODULE_SCOPE void	TclAdvanceLines(Tcl_Size *line, const char *start,
 			    const char *end);
+MODULE_SCOPE void	TclAppendBytesToByteArray(Tcl_Obj *objPtr,
+			    const unsigned char *bytes, Tcl_Size len);
+MODULE_SCOPE void	TclAppendUtfToUtf(Tcl_Obj *objPtr,
+			    const char *bytes, int numBytes);
 MODULE_SCOPE void	TclArgumentEnter(Tcl_Interp *interp,
 			    Tcl_Obj *objv[], int objc, CmdFrame *cf);
 MODULE_SCOPE void	TclArgumentRelease(Tcl_Interp *interp,
diff --git a/generic/tclStringObj.c b/generic/tclStringObj.c
index 3afee99..bc2d4e9 100644
--- a/generic/tclStringObj.c
+++ b/generic/tclStringObj.c
@@ -1963,7 +1963,7 @@ AppendUnicodeToUtfRep(
  *	None.
  *
  * Side effects:
- *	objPtr's internal rep is reallocated.
+ *	objPtr's internal rep is reallocated and string rep is cleaned.
  *
  *----------------------------------------------------------------------
  */
@@ -1999,7 +1999,7 @@ AppendUtfToUnicodeRep(
  *	None.
  *
  * Side effects:
- *	objPtr's internal rep is reallocated.
+ *	objPtr's string rep is reallocated (by TCL STRING GROWTH ALGORITHM).
  *
  *----------------------------------------------------------------------
  */
@@ -2079,6 +2079,39 @@ AppendUtfToUtfRep(
 /*
  *----------------------------------------------------------------------
  *
+ * TclAppendUtfToUtf -- 
+ *
+ *	This function appends "numBytes" bytes of "bytes" to the UTF string
+ *	rep of "objPtr" (objPtr's internal rep converted to string on demand).
+ *	numBytes must be non-negative.
+ *
+ * Results:
+ *	None.
+ *
+ * Side effects:
+ *	objPtr's string rep is reallocated (by TCL STRING GROWTH ALGORITHM).
+ *
+ *----------------------------------------------------------------------
+ */
+
+void
+TclAppendUtfToUtf(
+    Tcl_Obj *objPtr,		/* Points to the object to append to. */
+    const char *bytes,		/* String to append (or NULL to enlarge buffer). */
+    Tcl_Size numBytes)		/* Number of bytes of "bytes" to append. */
+{
+    if (Tcl_IsShared(objPtr)) {
+	Tcl_Panic("%s called with shared object", "TclAppendUtfToUtf");
+    }
+
+    SetStringFromAny(NULL, objPtr);
+
+    AppendUtfToUtfRep(objPtr, bytes, numBytes);
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
  * Tcl_AppendStringsToObjVA --
  *
  *	This function appends one or more null-terminated strings to an
diff --git a/tests-perf/chan.perf.tcl b/tests-perf/chan.perf.tcl
new file mode 100644
index 0000000..2ef87cb
--- /dev/null
+++ b/tests-perf/chan.perf.tcl
@@ -0,0 +1,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 [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 binary -encoding utf-8 -buffersize $bufSize -buffering full
+  fconfigure $wch -translation binary -encoding utf-8 -buffersize $bufSize -buffering full
+
+  exec [info nameofexecutable] -- $bufSize >@$wch << {
+    set bufSize [lindex $::argv end]
+    fconfigure stdout -translation binary -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)
+}