TIP 345 Implementation.

3 files changed, 78 insertions, 39 deletions

diff --git a/generic/tclEncoding.c b/generic/tclEncoding.c
index e328340..1f48a1c 100644
--- a/generic/tclEncoding.c
+++ b/generic/tclEncoding.c
@@ -563,7 +563,7 @@ TclInitEncodingSubsystem(void)
      * formed UTF-8 into a properly formed stream.
      */
 
-    type.encodingName	= "identity";
+    type.encodingName	= NULL;
     type.toUtfProc	= BinaryProc;
     type.fromUtfProc	= BinaryProc;
     type.freeProc	= NULL;
@@ -851,7 +851,9 @@ FreeEncoding(
 	if (encodingPtr->hPtr != NULL) {
 	    Tcl_DeleteHashEntry(encodingPtr->hPtr);
 	}
-	ckfree(encodingPtr->name);
+	if (encodingPtr->name) {
+	    ckfree(encodingPtr->name);
+	}
 	ckfree(encodingPtr);
     }
 }
@@ -1040,9 +1042,24 @@ Tcl_CreateEncoding(
     const Tcl_EncodingType *typePtr)
 				/* The encoding type. */
 {
+    Encoding *encodingPtr = ckalloc(sizeof(Encoding));
+    encodingPtr->name		= NULL;
+    encodingPtr->toUtfProc	= typePtr->toUtfProc;
+    encodingPtr->fromUtfProc	= typePtr->fromUtfProc;
+    encodingPtr->freeProc	= typePtr->freeProc;
+    encodingPtr->nullSize	= typePtr->nullSize;
+    encodingPtr->clientData	= typePtr->clientData;
+    if (typePtr->nullSize == 1) {
+	encodingPtr->lengthProc = (LengthProc *) strlen;
+    } else {
+	encodingPtr->lengthProc = (LengthProc *) unilen;
+    }
+    encodingPtr->refCount	= 1;
+    encodingPtr->hPtr		= NULL;
+
+  if (typePtr->encodingName) {
     Tcl_HashEntry *hPtr;
     int isNew;
-    Encoding *encodingPtr;
     char *name;
 
     Tcl_MutexLock(&encodingMutex);
@@ -1053,30 +1070,17 @@ Tcl_CreateEncoding(
 	 * reference goes away.
 	 */
 
-	encodingPtr = Tcl_GetHashValue(hPtr);
-	encodingPtr->hPtr = NULL;
+	Encoding *replaceMe = Tcl_GetHashValue(hPtr);
+	replaceMe->hPtr = NULL;
     }
 
     name = ckalloc(strlen(typePtr->encodingName) + 1);
-
-    encodingPtr = ckalloc(sizeof(Encoding));
     encodingPtr->name		= strcpy(name, typePtr->encodingName);
-    encodingPtr->toUtfProc	= typePtr->toUtfProc;
-    encodingPtr->fromUtfProc	= typePtr->fromUtfProc;
-    encodingPtr->freeProc	= typePtr->freeProc;
-    encodingPtr->nullSize	= typePtr->nullSize;
-    encodingPtr->clientData	= typePtr->clientData;
-    if (typePtr->nullSize == 1) {
-	encodingPtr->lengthProc = (LengthProc *) strlen;
-    } else {
-	encodingPtr->lengthProc = (LengthProc *) unilen;
-    }
-    encodingPtr->refCount	= 1;
     encodingPtr->hPtr		= hPtr;
     Tcl_SetHashValue(hPtr, encodingPtr);
 
     Tcl_MutexUnlock(&encodingMutex);
-
+  }
     return (Tcl_Encoding) encodingPtr;
 }
 
diff --git a/generic/tclTest.c b/generic/tclTest.c
index ebd90ae..834cd79 100644
--- a/generic/tclTest.c
+++ b/generic/tclTest.c
@@ -227,6 +227,9 @@ static int		TestasyncCmd(ClientData dummy,
 static int		TestbytestringObjCmd(ClientData clientData,
 			    Tcl_Interp *interp, int objc,
 			    Tcl_Obj *const objv[]);
+static int		TeststringbytesObjCmd(ClientData clientData,
+			    Tcl_Interp *interp, int objc,
+			    Tcl_Obj *const objv[]);
 static int		TestcmdinfoCmd(ClientData dummy,
 			    Tcl_Interp *interp, int argc, const char **argv);
 static int		TestcmdtokenCmd(ClientData dummy,
@@ -581,6 +584,7 @@ Tcltest_Init(
     Tcl_CreateCommand(interp, "noop", NoopCmd, NULL, NULL);
     Tcl_CreateObjCommand(interp, "noop", NoopObjCmd, NULL, NULL);
     Tcl_CreateObjCommand(interp, "testbytestring", TestbytestringObjCmd, NULL, NULL);
+    Tcl_CreateObjCommand(interp, "teststringbytes", TeststringbytesObjCmd, NULL, NULL);
     Tcl_CreateObjCommand(interp, "testwrongnumargs", TestWrongNumArgsObjCmd,
 	    NULL, NULL);
     Tcl_CreateObjCommand(interp, "testfilesystem", TestFilesystemObjCmd,
@@ -1985,9 +1989,12 @@ TestencodingObjCmd(
 	if (objc != 3) {
 	    return TCL_ERROR;
 	}
-	encoding = Tcl_GetEncoding(NULL, Tcl_GetString(objv[2]));
-	Tcl_FreeEncoding(encoding);
-	Tcl_FreeEncoding(encoding);
+	if (TCL_OK != Tcl_GetEncodingFromObj(interp, objv[2], &encoding)) {
+	    return TCL_ERROR;
+	}
+	Tcl_FreeEncoding(encoding);	/* Free returned reference */
+	Tcl_FreeEncoding(encoding);	/* Free to match CREATE */
+	TclFreeIntRep(objv[2]);		/* Free the cached ref */
 	break;
     }
     return TCL_OK;
@@ -5046,6 +5053,40 @@ NoopObjCmd(
 /*
  *----------------------------------------------------------------------
  *
+ * TeststringbytesObjCmd --
+ *	Returns bytearray value of the bytes in argument string rep
+ *
+ * Results:
+ *	Returns the TCL_OK result code.
+ *
+ * Side effects:
+ *	None.
+ *
+ *----------------------------------------------------------------------
+ */
+
+static int
+TeststringbytesObjCmd(
+    ClientData unused,		/* Not used. */
+    Tcl_Interp *interp,		/* Current interpreter. */
+    int objc,			/* Number of arguments. */
+    Tcl_Obj *const objv[])	/* The argument objects. */
+{
+    int n;
+    const unsigned char *p;
+
+    if (objc != 2) {
+	Tcl_WrongNumArgs(interp, 1, objv, "value");
+	return TCL_ERROR;
+    }
+    p = (const unsigned char *)Tcl_GetStringFromObj(objv[1], &n);
+    Tcl_SetObjResult(interp, Tcl_NewByteArrayObj(p, n));
+    return TCL_OK;
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
  * TestbytestringObjCmd --
  *
  *	This object-based procedure constructs a string which can
diff --git a/tests/encoding.test b/tests/encoding.test
index ffac748..e447c20 100644
--- a/tests/encoding.test
+++ b/tests/encoding.test
@@ -34,6 +34,8 @@ proc runtests {} {
 
 # Some tests require the testencoding command
 testConstraint testencoding [llength [info commands testencoding]]
+testConstraint testbytestring [llength [info commands testbytestring]]
+testConstraint teststringbytes [llength [info commands teststringbytes]]
 testConstraint fullutf [expr {[format %c 0x010000] != "\ufffd"}]
 testConstraint exec [llength [info commands exec]]
 testConstraint testgetencpath [llength [info commands testgetencpath]]
@@ -308,26 +310,18 @@ test encoding-13.1 {LoadEscapeTable} {
     viewable [set x [encoding convertto iso2022 ab\u4e4e\u68d9g]]
 } [viewable "ab\x1b\$B8C\x1b\$\(DD%\x1b(Bg"]
 
-test encoding-14.1 {BinaryProc} {
-    encoding convertto identity \x12\x34\x56\xff\x69
-} "\x12\x34\x56\xc3\xbf\x69"
-
 test encoding-15.1 {UtfToUtfProc} {
     encoding convertto utf-8 \xa3
 } "\xc2\xa3"
-test encoding-15.2 {UtfToUtfProc null character output} {
-    set x \u0000
-    set y [encoding convertto utf-8 \u0000]
-    set y [encoding convertfrom identity $y]
-    binary scan $y H* z
-    list [string bytelength $x] [string bytelength $y] $z
-} {2 1 00}
-test encoding-15.3 {UtfToUtfProc null character input} {
-    set x [encoding convertfrom identity \x00]
-    set y [encoding convertfrom utf-8 $x]
-    binary scan [encoding convertto identity $y] H* z
-    list [string bytelength $x] [string bytelength $y] $z
-} {1 2 c080}
+test encoding-15.2 {UtfToUtfProc null character output} testbytestring {
+    binary scan [testbytestring [encoding convertto utf-8 \u0000]] H* z
+    set z
+} 00
+test encoding-15.3 {UtfToUtfProc null character input} teststringbytes {
+    set y [encoding convertfrom utf-8 [encoding convertto utf-8 \u0000]]
+    binary scan [teststringbytes $y] H* z
+    set z
+} c080
 
 test encoding-16.1 {UnicodeToUtfProc} {
     set val [encoding convertfrom unicode NN]