Fix [2089279]: StringObj.3 Tcl_ObjPrintf inaccuracies.

Not only the documentation, also the behavior in the "unsigned long" case was wrong. Testcases added.

3 files changed, 89 insertions, 3 deletions

diff --git a/generic/tclStringObj.c b/generic/tclStringObj.c
index 7f9f874..bf6fd9d 100644
--- a/generic/tclStringObj.c
+++ b/generic/tclStringObj.c
@@ -2677,6 +2677,23 @@ Tcl_Format(
  *---------------------------------------------------------------------------
  */
 
+static Tcl_Obj *
+NewLongObj(
+    char c,
+	long value)
+{
+    if ((value < 0) && strchr("puoxX", c)) {
+#ifdef TCL_WIDE_INT_IS_LONG
+	mp_int bignumValue;
+	mp_init_u64(&bignumValue, (unsigned long)value);
+	return Tcl_NewBignumObj(&bignumValue);
+#else
+	return Tcl_NewWideIntObj((unsigned long)value | ~(unsigned long)LONG_MAX);
+#endif
+    }
+    return Tcl_NewLongObj(value);
+}
+
 static void
 AppendPrintfToObjVA(
     Tcl_Obj *objPtr,
@@ -2755,10 +2772,10 @@ AppendPrintfToObjVA(
 		case -1:
 		case 0:
 		    Tcl_ListObjAppendElement(NULL, list, Tcl_NewLongObj(
-			    (long) va_arg(argList, int)));
+			    (long)va_arg(argList, int)));
 		    break;
 		case 1:
-		    Tcl_ListObjAppendElement(NULL, list, Tcl_NewLongObj(
+		    Tcl_ListObjAppendElement(NULL, list, NewLongObj(*p,
 			    va_arg(argList, long)));
 		    break;
 		}
diff --git a/generic/tclTest.c b/generic/tclTest.c
index ea23d40..3d46d8b 100644
--- a/generic/tclTest.c
+++ b/generic/tclTest.c
@@ -260,6 +260,7 @@ static Tcl_ObjCmdProc	TestparseargsCmd;
 static Tcl_ObjCmdProc	TestparserObjCmd;
 static Tcl_ObjCmdProc	TestparsevarObjCmd;
 static Tcl_ObjCmdProc	TestparsevarnameObjCmd;
+static Tcl_ObjCmdProc	TestprintObjCmd;
 static Tcl_ObjCmdProc	TestregexpObjCmd;
 static Tcl_ObjCmdProc	TestreturnObjCmd;
 static void		TestregexpXflags(const char *string,
@@ -557,6 +558,8 @@ Tcltest_Init(
 	    NULL, NULL);
     Tcl_CreateObjCommand(interp, "testparsevarname", TestparsevarnameObjCmd,
 	    NULL, NULL);
+    Tcl_CreateObjCommand(interp, "testprint", TestprintObjCmd,
+	    NULL, NULL);
     Tcl_CreateObjCommand(interp, "testregexp", TestregexpObjCmd,
 	    NULL, NULL);
     Tcl_CreateObjCommand(interp, "testreturn", TestreturnObjCmd,
@@ -3955,6 +3958,44 @@ TestparsevarnameObjCmd(
 /*
  *----------------------------------------------------------------------
  *
+ * TestprintObjCmd --
+ *
+ *	This procedure implements the "testprint" command.  It is
+ *	used for being able to test the Tcl_ObjPrintf() function.
+ *
+ * Results:
+ *	A standard Tcl result.
+ *
+ * Side effects:
+ *	None.
+ *
+ *----------------------------------------------------------------------
+ */
+
+static int
+TestprintObjCmd(
+    void *clientData,
+    Tcl_Interp *interp,		/* Current interpreter. */
+    int objc,			/* Number of arguments. */
+    Tcl_Obj *const objv[])	/* The argument objects. */
+{
+    Tcl_WideInt argv1 = 0;
+    long argv2;
+
+    if (objc != 3) {
+	Tcl_WrongNumArgs(interp, 1, objv, "format longint");
+	return TCL_OK;
+    }
+
+    Tcl_GetWideIntFromObj(interp, objv[2], &argv1);
+    argv2 = (long)argv1;
+    Tcl_SetObjResult(interp, Tcl_ObjPrintf(Tcl_GetString(objv[1]), argv2, argv2, argv2, argv2));
+    return TCL_OK;
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
  * TestregexpObjCmd --
  *
  *	This procedure implements the "testregexp" command. It is used to give
diff --git a/tests/util.test b/tests/util.test
index 11ee3fa..29cdf3b 100644
--- a/tests/util.test
+++ b/tests/util.test
@@ -2,7 +2,7 @@
 # This file is organized in the standard fashion for Tcl tests.
 #
 # Copyright (c) 1995-1998 Sun Microsystems, Inc.
-# Copyright (c) 1998-1999 by Scriptics Corporation.
+# Copyright (c) 1998-1999 Scriptics Corporation.
 #
 # See the file "license.terms" for information on usage and redistribution
 # of this file, and for a DISCLAIMER OF ALL WARRANTIES.
@@ -20,6 +20,10 @@ testConstraint testbytestring [llength [info commands testbytestring]]
 testConstraint testdstring [llength [info commands testdstring]]
 testConstraint testconcatobj [llength [info commands testconcatobj]]
 testConstraint testdoubledigits [llength [info commands testdoubledigits]]
+testConstraint testprint [llength [info commands testprint]]
+testConstraint longIs32bit [expr {int(0x80000000) < 0}]
+testConstraint longIs64bit [expr {int(0x8000000000000000) < 0}]
+
 
 # Big test for correct ordering of data in [expr]
 
@@ -4063,6 +4067,30 @@ test util-17.1 {bankers' rounding [Bug 3349507]} {ieeeFloatingPoint} {
     0x4400000000000000 0xc400000000000000
 }]
 
+test util-18.1 {Tcl_ObjPrintf} {testprint longIs32bit} {
+    testprint %ld [expr {2**32-1}]
+} {-1}
+
+test util-18.2 {Tcl_ObjPrintf} {testprint longIs64bit} {
+    testprint %ld [expr {2**32-1}]
+} {4294967295}
+
+test util-18.3 {Tcl_ObjPrintf} {testprint} {
+    testprint %lu [expr {2**32-1}]
+} {4294967295}
+
+test util-18.4 {Tcl_ObjPrintf} {testprint} {
+    testprint %ld [expr {2**64-1}]
+} {-1}
+
+test util-18.5 {Tcl_ObjPrintf} {testprint longIs32bit} {
+    testprint %lu [expr {2**64-1}]
+} {4294967295}
+
+test util-18.6 {Tcl_ObjPrintf} {testprint longIs64bit} {
+    testprint %lu [expr {2**64-1}]
+} {18446744073709551615}
+
 set ::tcl_precision $saved_precision
 
 # cleanup