diff options
| -rw-r--r-- | ChangeLog | 7 | ||||
| -rw-r--r-- | doc/ByteArrObj.3 | 12 | ||||
| -rw-r--r-- | generic/tclBinary.c | 128 | ||||
| -rw-r--r-- | generic/tclInt.h | 11 | ||||
| -rw-r--r-- | generic/tclNamesp.c | 102 |
5 files changed, 127 insertions, 133 deletions
@@ -1,3 +1,10 @@ +2008-11-07 Pat Thoyts <patthoyts@users.sourceforge.net> + + * generic/tclInt.h: Applied patch #2215022 from Duoas to clean up + * generic/tclBinary.c: the binary ensemble initiailization code. + * generic/tclNamesp.c: Extends the TclMakeEnsemble to do + * doc/ByteArrObj.3: sub-ensembles from tables. + 2008-11-06 Jan Nijtmans <nijtmans@users.sf.net> * win/tcl.m4: add "-Wno-implicit-int" flag for gcc, as on UNIX diff --git a/doc/ByteArrObj.3 b/doc/ByteArrObj.3 index e7cc023..6d0822d 100644 --- a/doc/ByteArrObj.3 +++ b/doc/ByteArrObj.3 @@ -4,7 +4,7 @@ '\" See the file "license.terms" for information on usage and redistribution '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES. '\" -'\" RCS: @(#) $Id: ByteArrObj.3,v 1.6 2004/10/07 15:15:35 dkf Exp $ +'\" RCS: @(#) $Id: ByteArrObj.3,v 1.7 2008/11/07 20:10:19 patthoyts Exp $ '\" .so man.macros .TH Tcl_ByteArrayObj 3 8.1 Tcl "Tcl Library Procedures" @@ -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 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; } |