diff options
Diffstat (limited to 'generic')
| -rw-r--r-- | generic/tclBinary.c | 128 | ||||
| -rw-r--r-- | generic/tclInt.h | 11 | ||||
| -rw-r--r-- | generic/tclNamesp.c | 102 |
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; } |