TIP 651 implementation

8 files changed, 88 insertions, 8 deletions

diff --git a/doc/DString.3 b/doc/DString.3
index 00f1b8a..66323a7 100644
--- a/doc/DString.3
+++ b/doc/DString.3
@@ -41,6 +41,10 @@ char *
 \fBTcl_DStringResult\fR(\fIinterp, dsPtr\fR)
 .sp
 \fBTcl_DStringGetResult\fR(\fIinterp, dsPtr\fR)
+.sp
+Tcl_Obj *
+\fBTcl_DStringToObj\fR(\fIdsPtr\fR)
+.sp
 .SH ARGUMENTS
 .AS Tcl_DString newLength in/out
 .AP Tcl_DString *dsPtr in/out
@@ -142,12 +146,25 @@ a pointer from \fIdsPtr\fR to the interpreter's result.
 This saves the cost of allocating new memory and copying the string.
 \fBTcl_DStringResult\fR also reinitializes the dynamic string to
 an empty string.
+Since the dynamic string is reinitialized, there is no need to
+further call \fBTcl_DStringFree\fR on it and it can be reused without
+calling \fBTcl_DStringInit\fR.
 .PP
 \fBTcl_DStringGetResult\fR does the opposite of \fBTcl_DStringResult\fR.
 It sets the value of \fIdsPtr\fR to the result of \fIinterp\fR and
 it clears \fIinterp\fR's result.
 If possible it does this by moving a pointer rather than by copying
 the string.
+.PP
+\fBTcl_DStringToObj\fR returns a \fBTcl_Obj\fR containing the value of
+the dynamic string given by \fIdsPtr\fR.  It does this by moving
+a pointer from \fIdsPtr\fR to a newly allocated \fBTcl_Obj\fR
+and reinitializing to dynamic string to an empty string.
+This saves the cost of allocating new memory and copying the string.
+Since the dynamic string is reinitialized, there is no need to
+further call \fBTcl_DStringFree\fR on it and it can be reused without
+calling \fBTcl_DStringInit\fR.
+The returned \fBTcl_Obj\fR has a reference count of 0.
 
 .SH KEYWORDS
 append, dynamic string, free, result
diff --git a/generic/tcl.decls b/generic/tcl.decls
index 3f4103f..59d0ece 100644
--- a/generic/tcl.decls
+++ b/generic/tcl.decls
@@ -2566,10 +2566,10 @@ declare 683 {
 #	    Tcl_WideUInt *uwidePtr)
 #}
 
-# TIP 651 (reserved)
-#declare 687 {
-#    Tcl_Obj *Tcl_DStringToObj(Tcl_DString *dsPtr)
-#}
+# TIP 651
+declare 687 {
+    Tcl_Obj *Tcl_DStringToObj(Tcl_DString *dsPtr)
+}
 
 # ----- BASELINE -- FOR -- 8.7.0 / 9.0.0 ----- #
 
diff --git a/generic/tclDecls.h b/generic/tclDecls.h
index 0888ecf..3a57b2f 100644
--- a/generic/tclDecls.h
+++ b/generic/tclDecls.h
@@ -2040,6 +2040,11 @@ EXTERN int		Tcl_RemoveChannelMode(Tcl_Interp *interp,
 				Tcl_Channel chan, int mode);
 /* 683 */
 EXTERN int		Tcl_GetEncodingNulLength(Tcl_Encoding encoding);
+/* Slot 684 is reserved */
+/* Slot 685 is reserved */
+/* Slot 686 is reserved */
+/* 687 */
+EXTERN Tcl_Obj *	Tcl_DStringToObj(Tcl_DString *dsPtr);
 
 typedef struct {
     const struct TclPlatStubs *tclPlatStubs;
@@ -2759,6 +2764,10 @@ typedef struct TclStubs {
     int (*tcl_GetNumber) (Tcl_Interp *interp, const char *bytes, size_t numBytes, void **clientDataPtr, int *typePtr); /* 681 */
     int (*tcl_RemoveChannelMode) (Tcl_Interp *interp, Tcl_Channel chan, int mode); /* 682 */
     int (*tcl_GetEncodingNulLength) (Tcl_Encoding encoding); /* 683 */
+    void (*reserved684)(void);
+    void (*reserved685)(void);
+    void (*reserved686)(void);
+    Tcl_Obj * (*tcl_DStringToObj) (Tcl_DString *dsPtr); /* 687 */
 } TclStubs;
 
 extern const TclStubs *tclStubsPtr;
@@ -4157,6 +4166,11 @@ extern const TclStubs *tclStubsPtr;
 	(tclStubsPtr->tcl_RemoveChannelMode) /* 682 */
 #define Tcl_GetEncodingNulLength \
 	(tclStubsPtr->tcl_GetEncodingNulLength) /* 683 */
+/* Slot 684 is reserved */
+/* Slot 685 is reserved */
+/* Slot 686 is reserved */
+#define Tcl_DStringToObj \
+	(tclStubsPtr->tcl_DStringToObj) /* 687 */
 
 #endif /* defined(USE_TCL_STUBS) */
 
diff --git a/generic/tclInt.h b/generic/tclInt.h
index 2d29e1d..9f0eef0 100644
--- a/generic/tclInt.h
+++ b/generic/tclInt.h
@@ -3128,7 +3128,6 @@ MODULE_SCOPE char *	TclDStringAppendObj(Tcl_DString *dsPtr,
 			    Tcl_Obj *objPtr);
 MODULE_SCOPE char *	TclDStringAppendDString(Tcl_DString *dsPtr,
 			    Tcl_DString *toAppendPtr);
-MODULE_SCOPE Tcl_Obj *	TclDStringToObj(Tcl_DString *dsPtr);
 MODULE_SCOPE Tcl_Obj *const *TclFetchEnsembleRoot(Tcl_Interp *interp,
 			    Tcl_Obj *const *objv, int objc, int *objcPtr);
 MODULE_SCOPE Tcl_Obj *const *TclEnsembleGetRewriteValues(Tcl_Interp *interp);
@@ -4946,6 +4945,8 @@ MODULE_SCOPE Tcl_LibraryInitProc Procbodytest_SafeInit;
     Tcl_DStringAppend((dsPtr), (sLiteral), sizeof(sLiteral "") - 1)
 #define TclDStringClear(dsPtr) \
     Tcl_DStringSetLength((dsPtr), 0)
+/* Backward compatibility for TclDStringToObj which is now exported */
+#define TclDStringToObj Tcl_DStringToObj
 
 /*
  *----------------------------------------------------------------
diff --git a/generic/tclStubInit.c b/generic/tclStubInit.c
index ad60fc3..b3eb0de 100644
--- a/generic/tclStubInit.c
+++ b/generic/tclStubInit.c
@@ -2055,6 +2055,10 @@ const TclStubs tclStubs = {
     Tcl_GetNumber, /* 681 */
     Tcl_RemoveChannelMode, /* 682 */
     Tcl_GetEncodingNulLength, /* 683 */
+    0, /* 684 */
+    0, /* 685 */
+    0, /* 686 */
+    Tcl_DStringToObj, /* 687 */
 };
 
 /* !END!: Do not edit above this line. */
diff --git a/generic/tclTest.c b/generic/tclTest.c
index c9bad56..86fd965 100644
--- a/generic/tclTest.c
+++ b/generic/tclTest.c
@@ -1934,6 +1934,11 @@ TestdstringCmd(
 	    goto wrongNumArgs;
 	}
 	Tcl_DStringResult(interp, &dstring);
+    } else if (strcmp(argv[1], "toobj") == 0) {
+	if (argc != 2) {
+	    goto wrongNumArgs;
+	}
+	Tcl_SetObjResult(interp, Tcl_DStringToObj(&dstring));
     } else if (strcmp(argv[1], "trunc") == 0) {
 	if (argc != 3) {
 	    goto wrongNumArgs;
@@ -1949,8 +1954,8 @@ TestdstringCmd(
 	Tcl_DStringStartSublist(&dstring);
     } else {
 	Tcl_AppendResult(interp, "bad option \"", argv[1],
-		"\": must be append, element, end, free, get, length, "
-		"result, trunc, or start", NULL);
+		"\": must be append, element, end, free, get, gresult, length, "
+		"result, start, toobj, or trunc", NULL);
 	return TCL_ERROR;
     }
     return TCL_OK;
diff --git a/generic/tclUtil.c b/generic/tclUtil.c
index ab97461..fc5d1cc 100644
--- a/generic/tclUtil.c
+++ b/generic/tclUtil.c
@@ -3107,7 +3107,7 @@ Tcl_DStringGetResult(
  */
 
 Tcl_Obj *
-TclDStringToObj(
+Tcl_DStringToObj(
     Tcl_DString *dsPtr)
 {
     Tcl_Obj *result;
diff --git a/tests/dstring.test b/tests/dstring.test
index 11c5754..314cee8 100644
--- a/tests/dstring.test
+++ b/tests/dstring.test
@@ -473,6 +473,45 @@ test dstring-6.5 {Tcl_DStringGetResult} -constraints testdstring -body {
 } -cleanup {
     testdstring free
 } -result {{} {This is a specially-allocated stringz}}
+
+test dstring-7.1 {copying to Tcl_Obj} -constraints testdstring -setup {
+    testdstring free
+} -body {
+    testdstring append xyz -1
+    list [testdstring toobj] [testdstring length]
+} -cleanup {
+    testdstring free
+} -result {xyz 0}
+test dstring-7.2 {copying to a Tcl_Obj} -constraints testdstring -setup {
+    testdstring free
+    unset -nocomplain a
+} -body {
+    foreach l {a b c d e f g h i j k l m n o p} {
+	testdstring append $l$l$l$l$l$l$l$l$l$l$l$l$l$l$l$l$l$l$l$l$l\n -1
+    }
+    set a [testdstring toobj]
+    testdstring append abc -1
+    list $a [testdstring get]
+} -cleanup {
+    testdstring free
+} -result {{aaaaaaaaaaaaaaaaaaaaa
+bbbbbbbbbbbbbbbbbbbbb
+ccccccccccccccccccccc
+ddddddddddddddddddddd
+eeeeeeeeeeeeeeeeeeeee
+fffffffffffffffffffff
+ggggggggggggggggggggg
+hhhhhhhhhhhhhhhhhhhhh
+iiiiiiiiiiiiiiiiiiiii
+jjjjjjjjjjjjjjjjjjjjj
+kkkkkkkkkkkkkkkkkkkkk
+lllllllllllllllllllll
+mmmmmmmmmmmmmmmmmmmmm
+nnnnnnnnnnnnnnnnnnnnn
+ooooooooooooooooooooo
+ppppppppppppppppppppp
+} abc}
+
 
 # cleanup
 if {[testConstraint testdstring]} {