patch #2215022: clean up the binary ensemble initialization code

 Applied a patch from Duoas which extends the TclMakeEnsemble command to
 handle sub-ensembles from tables. Cleaned up the original patch a bit.

3 files changed, 113 insertions, 128 deletions

diff --git a/generic/tclBinary.c b/generic/tclBinary.c
index 680ef41..70ed12f 100644
--- a/generic/tclBinary.c
+++ b/generic/tclBinary.c
@@ -10,7 +10,7 @@
  * See the file "license.terms" for information on usage and redistribution of
  * this file, and for a DISCLAIMER OF ALL WARRANTIES.
  *
- * RCS: @(#) $Id: tclBinary.c,v 1.49 2008/10/26 18:34:03 dkf Exp $
+ * RCS: @(#) $Id: tclBinary.c,v 1.50 2008/11/07 20:10:19 patthoyts Exp $
  */
 
 #include "tclInt.h"
@@ -312,9 +312,9 @@ void
 Tcl_SetByteArrayObj(
     Tcl_Obj *objPtr,		/* Object to initialize as a ByteArray. */
     const unsigned char *bytes,	/* The array of bytes to use as the new
-				 * value. */
-    int length)			/* Length of the array of bytes, which must be
-				 * >= 0. */
+				   value. May be NULL even if length > 0. */
+    int length)			/* Length of the array of bytes, which must
+				   be >= 0. */
 {
     ByteArray *byteArrayPtr;
 
@@ -324,10 +324,14 @@ Tcl_SetByteArrayObj(
     TclFreeIntRep(objPtr);
     Tcl_InvalidateStringRep(objPtr);
 
+    length = (length < 0) ? 0 : length;
     byteArrayPtr = (ByteArray *) ckalloc(BYTEARRAY_SIZE(length));
+    memset(byteArrayPtr, 0, BYTEARRAY_SIZE(length));
     byteArrayPtr->used = length;
     byteArrayPtr->allocated = length;
-    memcpy(byteArrayPtr->bytes, bytes, (size_t) length);
+    if (bytes && length) {
+	memcpy(byteArrayPtr->bytes, bytes, (size_t) length);
+    }
 
     objPtr->typePtr = &tclByteArrayType;
     SET_BYTEARRAY(objPtr, byteArrayPtr);
@@ -593,8 +597,8 @@ UpdateStringOfByteArray(
  *
  * TclInitBinaryCmd --
  *
- *	This function is called to create the "binary" Tcl command. See the user
- *	documentation for details on what it does.
+ *	This function is called to create the "binary" Tcl command. See the
+ *	user documentation for details on what it does.
  *
  * Results:
  *	A command token for the new command.
@@ -608,89 +612,32 @@ UpdateStringOfByteArray(
 Tcl_Command
 TclInitBinaryCmd(Tcl_Interp *interp)
 {
-    Tcl_Namespace *nsTclPtr, *nsBinPtr, *nsEncPtr, *nsDecPtr;
-    Tcl_Command binEnsemble, encEnsemble, decEnsemble;
-    Tcl_Obj *binDict, *encDict, *decDict;
-
-    /*
-     * FIX ME: I so ugly - please make me pretty ...
-     */
-
-    nsTclPtr = Tcl_FindNamespace(interp, "::tcl",
-	NULL, TCL_CREATE_NS_IF_UNKNOWN);
-    if (nsTclPtr == NULL) {
-	Tcl_Panic("unable to find or create ::tcl namespace!");
-    }
-    nsBinPtr = Tcl_FindNamespace(interp, "::tcl::binary",
-	NULL, TCL_CREATE_NS_IF_UNKNOWN);
-    if (nsBinPtr == NULL) {
-	Tcl_Panic("unable to find or create ::tcl::binary namespace!");
-    }
-    binEnsemble = Tcl_CreateEnsemble(interp, "::binary",
-	nsBinPtr, TCL_ENSEMBLE_PREFIX);
-
-    nsEncPtr = Tcl_FindNamespace(interp, "::tcl::binary::encode",
-	NULL, TCL_CREATE_NS_IF_UNKNOWN);
-    if (nsEncPtr == NULL) {
-	Tcl_Panic("unable to find or create ::tcl::binary::encode namespace!");
-    }
-    encEnsemble = Tcl_CreateEnsemble(interp, "encode",
-	nsBinPtr, 0);
-
-    nsDecPtr = Tcl_FindNamespace(interp, "::tcl::binary::decode",
-	NULL, TCL_CREATE_NS_IF_UNKNOWN);
-    if (nsDecPtr == NULL) {
-	Tcl_Panic("unable to find or create ::tcl::binary::decode namespace!");
-    }
-    decEnsemble = Tcl_CreateEnsemble(interp, "decode",
-	nsBinPtr, 0);
-
-    TclNewObj(binDict);
-    Tcl_DictObjPut(NULL, binDict, Tcl_NewStringObj("format",-1),
-	Tcl_NewStringObj("::tcl::binary::format",-1));
-    Tcl_DictObjPut(NULL, binDict, Tcl_NewStringObj("scan",-1),
-	Tcl_NewStringObj("::tcl::binary::scan",-1));
-    Tcl_DictObjPut(NULL, binDict, Tcl_NewStringObj("encode",-1),
-	Tcl_NewStringObj("::tcl::binary::encode",-1));
-    Tcl_DictObjPut(NULL, binDict, Tcl_NewStringObj("decode",-1),
-	Tcl_NewStringObj("::tcl::binary::decode",-1));
-    Tcl_CreateObjCommand(interp, "::tcl::binary::format",
-	BinaryFormatCmd, NULL, NULL);
-    Tcl_CreateObjCommand(interp, "::tcl::binary::scan",
-	BinaryScanCmd, NULL, NULL);
-    Tcl_SetEnsembleMappingDict(interp, binEnsemble, binDict);
-
-    TclNewObj(encDict);
-    Tcl_DictObjPut(NULL, encDict, Tcl_NewStringObj("hex",-1),
-	Tcl_NewStringObj("::tcl::binary::encode::hex",-1));
-    Tcl_DictObjPut(NULL, encDict, Tcl_NewStringObj("uuencode",-1),
-	Tcl_NewStringObj("::tcl::binary::encode::uuencode",-1));
-    Tcl_DictObjPut(NULL, encDict, Tcl_NewStringObj("base64",-1),
-	Tcl_NewStringObj("::tcl::binary::encode::base64",-1));
-    Tcl_CreateObjCommand(interp, "::tcl::binary::encode::hex",
-	BinaryEncodeHex, (ClientData)HexDigits, NULL);
-    Tcl_CreateObjCommand(interp, "::tcl::binary::encode::uuencode",
-	BinaryEncode64, (ClientData)UueDigits, NULL);
-    Tcl_CreateObjCommand(interp, "::tcl::binary::encode::base64",
-	BinaryEncode64, (ClientData)B64Digits, NULL);
-    Tcl_SetEnsembleMappingDict(interp, encEnsemble, encDict);
-
-    TclNewObj(decDict);
-    Tcl_DictObjPut(NULL, decDict, Tcl_NewStringObj("hex",-1),
-	Tcl_NewStringObj("::tcl::binary::decode::hex",-1));
-    Tcl_DictObjPut(NULL, decDict, Tcl_NewStringObj("uuencode",-1),
-	Tcl_NewStringObj("::tcl::binary::decode::uuencode",-1));
-    Tcl_DictObjPut(NULL, decDict, Tcl_NewStringObj("base64",-1),
-	Tcl_NewStringObj("::tcl::binary::decode::base64",-1));
-    Tcl_CreateObjCommand(interp, "::tcl::binary::decode::hex",
-	BinaryDecodeHex, (ClientData)NULL, NULL);
-    Tcl_CreateObjCommand(interp, "::tcl::binary::decode::uuencode",
-	BinaryDecodeUu, (ClientData)NULL, NULL);
-    Tcl_CreateObjCommand(interp, "::tcl::binary::decode::base64",
-	BinaryDecode64, (ClientData)NULL, NULL);
-    Tcl_SetEnsembleMappingDict(interp, decEnsemble, decDict);
-
-    return binEnsemble;
+    const EnsembleImplMap binaryMap[] = {
+	{ "format", BinaryFormatCmd, NULL },
+	{ "scan",   BinaryScanCmd,   NULL },
+	{ "encode", NULL,            NULL },
+	{ "decode", NULL,            NULL },
+	{ NULL, NULL, NULL }
+    };
+    const EnsembleImplMap encodeMap[] = {
+	{ "hex",      BinaryEncodeHex, NULL, NULL, (ClientData)HexDigits },
+	{ "uuencode", BinaryEncode64,  NULL, NULL, (ClientData)UueDigits },
+	{ "base64",   BinaryEncode64,  NULL, NULL, (ClientData)B64Digits },
+	{ NULL, NULL, NULL }
+    };
+    const EnsembleImplMap decodeMap[] = {
+	{ "hex",      BinaryDecodeHex, NULL },
+	{ "uuencode", BinaryDecodeUu,  NULL },
+	{ "base64",   BinaryDecode64,  NULL },
+	{ NULL, NULL, NULL }
+    };
+
+    Tcl_Command binaryEnsemble;
+
+    binaryEnsemble = TclMakeEnsemble(interp, "binary", binaryMap);
+    TclMakeEnsemble(interp, "binary encode", encodeMap);
+    TclMakeEnsemble(interp, "binary decode", decodeMap);
+    return binaryEnsemble;
 }
 
 /*
@@ -2710,3 +2657,4 @@ BinaryDecode64(
  * fill-column: 78
  * End:
  */
+
diff --git a/generic/tclInt.h b/generic/tclInt.h
index 551688d..f0c922f 100644
--- a/generic/tclInt.h
+++ b/generic/tclInt.h
@@ -15,7 +15,7 @@
  * See the file "license.terms" for information on usage and redistribution of
  * this file, and for a DISCLAIMER OF ALL WARRANTIES.
  *
- * RCS: @(#) $Id: tclInt.h,v 1.404 2008/10/15 06:17:03 nijtmans Exp $
+ * RCS: @(#) $Id: tclInt.h,v 1.405 2008/11/07 20:10:19 patthoyts Exp $
  */
 
 #ifndef _TCLINT
@@ -1455,10 +1455,11 @@ typedef struct ByteCodeStats {
  */
 
 typedef struct {
-    const char *name;		/* The name of the subcommand. */
-    Tcl_ObjCmdProc *proc;	/* The implementation of the subcommand. */
-    CompileProc *compileProc;	/* The compiler for the subcommand. */
-    Tcl_ObjCmdProc *nreProc;	/* NRE implementation of this command */
+    const char        *name;        /* The name of the subcommand           */
+    Tcl_ObjCmdProc    *proc;        /* The implementation of the subcommand */
+    CompileProc       *compileProc; /* The compiler for the subcommand      */
+    Tcl_ObjCmdProc    *nreProc;     /* NRE implementation of this command   */
+    ClientData         clientData;  /* Any clientData to give the command   */
 } EnsembleImplMap;
 
 /*
diff --git a/generic/tclNamesp.c b/generic/tclNamesp.c
index 6485831..10e3fd6 100644
--- a/generic/tclNamesp.c
+++ b/generic/tclNamesp.c
@@ -23,7 +23,7 @@
  * See the file "license.terms" for information on usage and redistribution of
  * this file, and for a DISCLAIMER OF ALL WARRANTIES.
  *
- * RCS: @(#) $Id: tclNamesp.c,v 1.180 2008/10/26 18:34:04 dkf Exp $
+ * RCS: @(#) $Id: tclNamesp.c,v 1.181 2008/11/07 20:10:19 patthoyts Exp $
  */
 
 #include "tclInt.h"
@@ -6127,11 +6127,17 @@ Tcl_IsEnsemble(
  *	ensemble will be subject to (limited) compilation if any of the
  *	implementation commands are compilable.
  *
+ *	The 'name' parameter may be a single command name or a list if
+ *	creating an ensemble subcommand (see the binary implementation).
+ *
+ * 	Currently, the TCL_ENSEMBLE_PREFIX ensemble flag is only used on
+ *	top-level ensemble commands.
+ *
  * Results:
- *	Handle for the ensemble, or NULL if creation of it fails.
+ *	Handle for the new ensemble, or NULL on failure.
  *
  * Side effects:
- *	May advance bytecode compilation epoch.
+ *	May advance the bytecode compilation epoch.
  *
  *----------------------------------------------------------------------
  */
@@ -6139,58 +6145,88 @@ Tcl_IsEnsemble(
 Tcl_Command
 TclMakeEnsemble(
     Tcl_Interp *interp,
-    const char *name,
-    const EnsembleImplMap map[])
+    const char *name,		 /* The ensemble name (as explained above) */
+    const EnsembleImplMap map[]) /* The subcommands to create */
 {
-    Tcl_Command ensemble;	/* The overall ensemble. */
-    Tcl_Namespace *tclNsPtr;	/* Reference to the "::tcl" namespace. */
+    Tcl_Command ensemble;
+    Tcl_Namespace *ns;
     Tcl_DString buf;
+    char **nameParts;
+    const char *cmdname;
+    int i, nameCount = 0, ensembleFlags = 0;
 
-    tclNsPtr = Tcl_FindNamespace(interp, "::tcl", NULL,
-	    TCL_CREATE_NS_IF_UNKNOWN);
-    if (tclNsPtr == NULL) {
-	Tcl_Panic("unable to find or create ::tcl namespace!");
-    }
+    /*
+     * Construct the path for the ensemble namespace and create it
+     */
+    
     Tcl_DStringInit(&buf);
-    Tcl_DStringAppend(&buf, "::tcl::", -1);
-    Tcl_DStringAppend(&buf, name, -1);
-    tclNsPtr = Tcl_FindNamespace(interp, Tcl_DStringValue(&buf), NULL,
-	    TCL_CREATE_NS_IF_UNKNOWN);
-    if (tclNsPtr == NULL) {
+    Tcl_DStringAppend(&buf, "::tcl", -1);
+    
+    if (Tcl_SplitList(NULL, name, &nameCount, &nameParts) != TCL_OK) {
+	Tcl_Panic("invalid ensemble name '%s'", name);
+    }
+
+    for (i = 0; i < nameCount; ++i) {
+	Tcl_DStringAppend(&buf, "::", 2);
+	Tcl_DStringAppend(&buf, nameParts[i], -1);
+    }
+    
+    ns = Tcl_FindNamespace(interp, Tcl_DStringValue(&buf),
+	NULL, TCL_CREATE_NS_IF_UNKNOWN);
+    if (!ns) {
 	Tcl_Panic("unable to find or create %s namespace!",
-		Tcl_DStringValue(&buf));
+	    Tcl_DStringValue(&buf));
+    }
+
+    /*
+     * Create the named ensemble in the correct namespace
+     */
+    
+    if (nameCount == 1) {
+	ensembleFlags = TCL_ENSEMBLE_PREFIX;
+	cmdname = Tcl_DStringValue(&buf) + 5;
+    } else {
+	ns = ns->parentPtr;
+	cmdname = nameParts[nameCount - 1];
     }
-    ensemble = Tcl_CreateEnsemble(interp, Tcl_DStringValue(&buf)+5, tclNsPtr,
-	    TCL_ENSEMBLE_PREFIX);
-    Tcl_DStringAppend(&buf, "::", -1);
+    ensemble = Tcl_CreateEnsemble(interp, cmdname, ns, ensembleFlags);
+
+    /*
+     * Create the ensemble mapping dictionary and the ensemble command procs
+     */
+
     if (ensemble != NULL) {
 	Tcl_Obj *mapDict;
-	int i, compile = 0;
 
+	Tcl_DStringAppend(&buf, "::", 2);
 	TclNewObj(mapDict);
 	for (i=0 ; map[i].name != NULL ; i++) {
 	    Tcl_Obj *fromObj, *toObj;
-	    register Command *cmdPtr;
+	    Command *cmdPtr;
 
 	    fromObj = Tcl_NewStringObj(map[i].name, -1);
 	    TclNewStringObj(toObj, Tcl_DStringValue(&buf),
-		    Tcl_DStringLength(&buf));
+		Tcl_DStringLength(&buf));
 	    Tcl_AppendToObj(toObj, map[i].name, -1);
 	    Tcl_DictObjPut(NULL, mapDict, fromObj, toObj);
-	    cmdPtr = (Command *) Tcl_CreateObjCommand(interp,
-		    TclGetString(toObj), map[i].proc, NULL, NULL);
-	    cmdPtr->compileProc = map[i].compileProc;
-	    cmdPtr->nreProc = map[i].nreProc;
-	    compile |= (map[i].compileProc != NULL);
+	    if (map[i].proc) {
+		cmdPtr = (Command *)Tcl_CreateObjCommand(interp,
+		    TclGetString(toObj), map[i].proc,
+		    map[i].clientData, NULL);
+		cmdPtr->compileProc = map[i].compileProc;
+		cmdPtr->nreProc = map[i].nreProc;
+		if (map[i].compileProc != NULL)
+		    ensembleFlags |= ENSEMBLE_COMPILE;
+	    }
 	}
 	Tcl_SetEnsembleMappingDict(interp, ensemble, mapDict);
-	if (compile) {
-	    Tcl_SetEnsembleFlags(interp, ensemble,
-		    TCL_ENSEMBLE_PREFIX | ENSEMBLE_COMPILE);
+	if (ensembleFlags & ENSEMBLE_COMPILE) {
+	    Tcl_SetEnsembleFlags(interp, ensemble, ensembleFlags);
 	}
     }
-    Tcl_DStringFree(&buf);
 
+    Tcl_DStringFree(&buf);
+    Tcl_Free((char *)nameParts);
     return ensemble;
 }