Attachment "2215022.patch" to
ticket [2215022fff]
added by
patthoyts
2008-11-07 07:09:20.
diff --git a/doc/ByteArrObj.3 b/doc/ByteArrObj.3
index d2293e2..8ec1eb9 100644
--- a/doc/ByteArrObj.3
+++ b/doc/ByteArrObj.3
@@ -29,7 +29,8 @@ unsigned char *
.SH ARGUMENTS
.AS "const unsigned char" *lengthPtr in/out
.AP "const unsigned char" *bytes in
-The array of bytes used to initialize or set a byte-array object.
+The array of bytes used to initialize or set a byte-array object. May be NULL
+even if \fIlength\fR is non-zero.
.AP int length in
The length of the array of bytes. It must be >= 0.
.AP Tcl_Obj *objPtr in/out
@@ -55,7 +56,7 @@ byte-array or to convert an arbitrary object to a byte-array. Obtaining the
string representation of a byte-array object (by calling
\fBTcl_GetStringFromObj\fR) produces a properly formed UTF-8 sequence with a
one-to-one mapping between the bytes in the internal representation and the
-UTF-8 characters in the string representation.
+UTF-8 characters in the string representation.
.PP
\fBTcl_NewByteArrayObj\fR and \fBTcl_SetByteArrayObj\fR will
create a new object of byte-array type or modify an existing object to have a
@@ -65,7 +66,8 @@ array of bytes given by \fIbytes\fR. \fBTcl_NewByteArrayObj\fR returns a
pointer to a newly allocated object with a reference count of zero.
\fBTcl_SetByteArrayObj\fR invalidates any old string representation and, if
the object is not already a byte-array object, frees any old internal
-representation.
+representation. If \fIbytes\fR is NULL then the new byte array contains
+arbitrary values.
.PP
\fBTcl_GetByteArrayFromObj\fR converts a Tcl object to byte-array type and
returns a pointer to the object's new internal representation as an array of
@@ -73,7 +75,7 @@ bytes. The length of this array is stored in \fIlengthPtr\fR if
\fIlengthPtr\fR is non-NULL. The storage for the array of bytes is owned by
the object and should not be freed. The contents of the array may be
modified by the caller only if the object is not shared and the caller
-invalidates the string representation.
+invalidates the string representation.
.PP
\fBTcl_SetByteArrayLength\fR converts the Tcl object to byte-array type
and changes the length of the object's internal representation as an
diff --git a/generic/tclBinary.c b/generic/tclBinary.c
index 511bc3a..aadd1e5 100644
--- a/generic/tclBinary.c
+++ b/generic/tclBinary.c
@@ -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,13 @@ Tcl_SetByteArrayObj(
TclFreeIntRep(objPtr);
Tcl_InvalidateStringRep(objPtr);
+ length = (length < 0) ? 0 : length;
byteArrayPtr = (ByteArray *) ckalloc(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 +596,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 +611,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, NULL, NULL, NULL },
+ { "scan", BinaryScanCmd, NULL, NULL, NULL, NULL },
+ { "encode", NULL, NULL, NULL, NULL, NULL },
+ { "decode", NULL, NULL, NULL, NULL, NULL },
+ { NULL, NULL, NULL, NULL, NULL, NULL }
+ };
+ const EnsembleImplMap encodeMap[] = {
+ { "hex", BinaryEncodeHex, NULL, NULL, (ClientData)HexDigits, NULL },
+ { "uuencode",BinaryEncode64, NULL, NULL, (ClientData)UueDigits, NULL },
+ { "base64", BinaryEncode64, NULL, NULL, (ClientData)B64Digits, NULL },
+ { NULL, NULL, NULL, NULL, NULL, NULL }
+ };
+ const EnsembleImplMap decodeMap[] = {
+ { "hex", BinaryDecodeHex, NULL, NULL, NULL, NULL },
+ { "uuencode", BinaryDecodeUu, NULL, NULL, NULL, NULL },
+ { "base64", BinaryDecode64, NULL, NULL, NULL, NULL },
+ { NULL, NULL, 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 +2656,4 @@ BinaryDecode64(
* fill-column: 78
* End:
*/
+
diff --git a/generic/tclInt.h b/generic/tclInt.h
index d897a90..429e71f 100644
--- a/generic/tclInt.h
+++ b/generic/tclInt.h
@@ -1455,10 +1455,12 @@ 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 */
+ Tcl_CmdDeleteProc *deleteProc; /* The delete proc, may be NULL */
} EnsembleImplMap;
/*
diff --git a/generic/tclNamesp.c b/generic/tclNamesp.c
index b50b5a9..7188ae6 100644
--- a/generic/tclNamesp.c
+++ b/generic/tclNamesp.c
@@ -6127,11 +6127,44 @@ Tcl_IsEnsemble(
* ensemble will be subject to (limited) compilation if any of the
* implementation commands are compilable.
*
+ * The ensemble name may be a top-level command, like "binary".
+ *
+ * Top-level commands are placed in the global namespace and the
+ * ensemble sub-command procedures are placed in the ::tcl::$name
+ * namespace. For the 'binary' command and its 'format', 'scan', etc
+ * sub-commands, the following commands are created:
+ * ::binary
+ * ::tcl::binary::format
+ * ::tcl::binary::scan
+ * ::tcl::binary::encode
+ * ::tcl::binary::decode
+ *
+ * The ensemble name may be a nested ensemble command, like
+ * "binary encode".
+ *
+ * Nested commands are placed in their proper nested-namespace
+ * places (where they belong). For example, the 'binary encode'
+ * nested ensemble command and its 'hex', 'uuencode', and 'base64'
+ * sub-commands names are:
+ * ::tcl::binary::encode
+ * ::tcl::binary::encode::hex
+ * ::tcl::binary::encode::uuencode
+ * ::tcl::binary::encode::base64
+ *
+ * Additional notes:
+ * Currently, the TCL_ENSEMBLE_PREFIX ensemble flag is only used on
+ * top-level ensemble commands. That is the way the 'binary' command
+ * was originally encoded...
+ *
+ * The EnsembleImplMap currently has the Tcl_CmdDeleteProc item
+ * commented-out --I don't think it is ever used in core commands. Hence,
+ * it is commented out below as well...
+ *
* 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 +6172,90 @@ 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;
+ const char *currName; /* used to manipulate the full ns name */
+ const char *nextName; /* ditto */
+ int length;
+ int nameCount; /* n == 1: top-level; n > 1: nested cmd */
+ int ensembleFlags = 0;
+
+ /* Collect the argument ensemble command into a complete namespace name. */
- tclNsPtr = Tcl_FindNamespace(interp, "::tcl", NULL,
- TCL_CREATE_NS_IF_UNKNOWN);
- if (tclNsPtr == NULL) {
- Tcl_Panic("unable to find or create ::tcl namespace!");
- }
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);
+
+ nextName = name;
+ nameCount = 0;
+ do {
+ nameCount++;
+ currName = nextName + strspn(nextName, " \t");
+ nextName = strpbrk(currName, " \t");
+ length = (nextName == NULL) ? -1 : (nextName - currName);
+
+ Tcl_DStringAppend(&buf, "::", 2);
+ Tcl_DStringAppend(&buf, currName, length);
+ } while (nextName);
+
+ /* Create the ensemble's namespace */
+ 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));
}
- ensemble = Tcl_CreateEnsemble(interp, Tcl_DStringValue(&buf)+5, tclNsPtr,
- TCL_ENSEMBLE_PREFIX);
- Tcl_DStringAppend(&buf, "::", -1);
+
+ /* Create the ensemble itself in the correct namespace */
+ currName = Tcl_DStringValue(&buf)
+ + Tcl_DStringLength(&buf) - strlen( currName );
+ if (nameCount == 1) {
+ ensembleFlags = TCL_ENSEMBLE_PREFIX;
+ currName -= 2;
+ } else {
+ ns = ns->parentPtr;
+ }
+ ensemble = Tcl_CreateEnsemble(interp, currName, ns, ensembleFlags);
+
+ /*
+ * Create the ensemble mapping dictionary and the ensemble command procs
+ */
+
if (ensemble != NULL) {
Tcl_Obj *mapDict;
- int i, compile = 0;
+ int i;
+ 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, map[i].deleteProc);
+ 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);
return ensemble;
}
