From 46e5b17ffbd7d678e0113f8564deaeb32f137a82 Mon Sep 17 00:00:00 2001
From: dgp <dgp@users.sourceforge.net>
Date: Thu, 12 Mar 2020 17:29:33 +0000
Subject: Add some testing of Tcl_SetByteArrayLength().

---
 generic/tclTest.c | 48 ++++++++++++++++++++++++++++++++++++++++++++++++
 tests/binary.test | 11 +++++++++++
 2 files changed, 59 insertions(+)

diff --git a/generic/tclTest.c b/generic/tclTest.c
index 5e807d4..3e942bb 100644
--- a/generic/tclTest.c
+++ b/generic/tclTest.c
@@ -226,6 +226,9 @@ static int		TestbumpinterpepochObjCmd(ClientData clientData,
 static int		TestpurebytesobjObjCmd(ClientData clientData,
 			    Tcl_Interp *interp, int objc,
 			    Tcl_Obj *const objv[]);
+static int		TestsetbytearraylengthObjCmd(ClientData clientData,
+			    Tcl_Interp *interp, int objc,
+			    Tcl_Obj *const objv[]);
 static int		TestbytestringObjCmd(ClientData clientData,
 			    Tcl_Interp *interp, int objc,
 			    Tcl_Obj *const objv[]);
@@ -577,6 +580,7 @@ Tcltest_Init(
     Tcl_CreateCommand(interp, "noop", NoopCmd, NULL, NULL);
     Tcl_CreateObjCommand(interp, "noop", NoopObjCmd, NULL, NULL);
     Tcl_CreateObjCommand(interp, "testpurebytesobj", TestpurebytesobjObjCmd, NULL, NULL);
+    Tcl_CreateObjCommand(interp, "testsetbytearraylength", TestsetbytearraylengthObjCmd, NULL, NULL);
     Tcl_CreateObjCommand(interp, "testbytestring", TestbytestringObjCmd, NULL, NULL);
     Tcl_CreateObjCommand(interp, "testwrongnumargs", TestWrongNumArgsObjCmd,
 	    NULL, NULL);
@@ -5037,6 +5041,50 @@ TestpurebytesobjObjCmd(
 /*
  *----------------------------------------------------------------------
  *
+ * TestsetbytearraylengthObjCmd --
+ *
+ *	Testing command 'testsetbytearraylength` used to test the public
+ *	interface routine Tcl_SetByteArrayLength().
+ *
+ * Results:
+ *	Returns the TCL_OK result code.
+ *
+ * Side effects:
+ *	None.
+ *
+ *----------------------------------------------------------------------
+ */
+
+static int
+TestsetbytearraylengthObjCmd(
+    ClientData unused,		/* Not used. */
+    Tcl_Interp *interp,		/* Current interpreter. */
+    int objc,			/* Number of arguments. */
+    Tcl_Obj *const objv[])	/* The argument objects. */
+{
+    int n;
+    Tcl_Obj *obj = NULL;
+
+    if (objc != 3) {
+	Tcl_WrongNumArgs(interp, 1, objv, "value length");
+	return TCL_ERROR;
+    }
+    if (TCL_OK != Tcl_GetIntFromObj(interp, objv[2], &n)) {
+	return TCL_ERROR;
+    }
+    if (Tcl_IsShared(objv[1])) {
+	obj = Tcl_DuplicateObj(objv[1]);
+    } else {
+	obj = objv[1];
+    }
+    Tcl_SetByteArrayLength(obj, n);
+    Tcl_SetObjResult(interp, obj);
+    return TCL_OK;
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
  * TestbytestringObjCmd --
  *
  *	This object-based procedure constructs a string which can
diff --git a/tests/binary.test b/tests/binary.test
index 8c1dedb..92fb648 100644
--- a/tests/binary.test
+++ b/tests/binary.test
@@ -2889,6 +2889,17 @@ test binary-76.2 {binary string appending growth algorithm} win {
     # Append to it
     string length [append str [binary format a* foo]]
 } 3
+
+testConstraint testsetbytearraylength \
+		[expr {"testsetbytearraylength" in [info commands]}]
+
+test binary-77.1 {Tcl_SetByteArrayLength} testsetbytearraylength {
+    testsetbytearraylength [string cat A B C] 1
+} A
+test binary-77.2 {Tcl_SetByteArrayLength} testsetbytearraylength {
+    testsetbytearraylength [string cat \u0141 B C] 1
+} A
+
 
 # ----------------------------------------------------------------------
 # cleanup
-- 
cgit v0.12