diff options
| -rw-r--r-- | ChangeLog | 5 | ||||
| -rw-r--r-- | generic/tclBasic.c | 10 | ||||
| -rw-r--r-- | generic/tclBinary.c | 375 | ||||
| -rw-r--r-- | generic/tclInt.h | 6 | ||||
| -rw-r--r-- | tests/binary.test | 8 |
5 files changed, 244 insertions, 160 deletions
@@ -1,5 +1,10 @@ 2008-05-02 Pat Thoyts <patthoyts@users.sourceforge.net> + * generic/tclBasic.c: Converted the [binary] command into an + * generic/tclBinary.c: ensemble. + * generic/tclInt.h: + * test/binary.test: Updated the error tests for ensemble errors. + * generic/tclFileName.c: Reverted accidental commit of TIP 316 APIs. 2008-04-27 Donal K. Fellows <dkf@users.sf.net> diff --git a/generic/tclBasic.c b/generic/tclBasic.c index 8e46a77..4b7593a 100644 --- a/generic/tclBasic.c +++ b/generic/tclBasic.c @@ -14,7 +14,7 @@ * See the file "license.terms" for information on usage and redistribution of * this file, and for a DISCLAIMER OF ALL WARRANTIES. * - * RCS: @(#) $Id: tclBasic.c,v 1.297 2008/04/16 14:49:28 das Exp $ + * RCS: @(#) $Id: tclBasic.c,v 1.298 2008/05/02 20:08:51 patthoyts Exp $ */ #include "tclInt.h" @@ -125,7 +125,6 @@ static const CmdInfo builtInCmds[] = { {"append", Tcl_AppendObjCmd, TclCompileAppendCmd, 1}, {"apply", Tcl_ApplyObjCmd, NULL, 1}, {"array", Tcl_ArrayObjCmd, NULL, 1}, - {"binary", Tcl_BinaryObjCmd, NULL, 1}, {"break", Tcl_BreakObjCmd, TclCompileBreakCmd, 1}, #ifndef EXCLUDE_OBSOLETE_COMMANDS {"case", Tcl_CaseObjCmd, NULL, 1}, @@ -660,11 +659,12 @@ Tcl_CreateInterp(void) } /* - * Create the "chan", "dict", "info" and "string" ensembles. Note that all - * these commands (and their subcommands that are not present in the - * global namespace) are wholly safe. + * Create the "binary", "chan", "dict", "info" and "string" ensembles. + * Note that all these commands (and their subcommands that are not + * present in the global namespace) are wholly safe. */ + TclInitBinaryCmd(interp); TclInitChanCmd(interp); TclInitDictCmd(interp); TclInitInfoCmd(interp); diff --git a/generic/tclBinary.c b/generic/tclBinary.c index 3796ac1..8adf524 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.42 2008/04/27 22:21:29 dkf Exp $ + * RCS: @(#) $Id: tclBinary.c,v 1.43 2008/05/02 20:08:52 patthoyts Exp $ */ #include "tclInt.h" @@ -72,6 +72,21 @@ static void DeleteScanNumberCache(Tcl_HashTable *numberCachePtr); static int NeedReversing(int format); static void CopyNumber(const void *from, void *to, unsigned int length, int type); +/* Binary ensemble commands */ +static int BinaryFormatCmd(ClientData clientData, Tcl_Interp *interp, + int objc, Tcl_Obj *const objv[]); +static int BinaryScanCmd(ClientData clientData, Tcl_Interp *interp, + int objc, Tcl_Obj *const objv[]); + +/* + * Default description of the "binary" ensemble + */ + +static const EnsembleImplMap defaultBinaryMap[] = { + { "format", BinaryFormatCmd, NULL}, + { "scan", BinaryScanCmd, NULL}, + { NULL, NULL, NULL } +}; /* * The following object type represents an array of bytes. An array of bytes @@ -542,9 +557,32 @@ UpdateStringOfByteArray( /* *---------------------------------------------------------------------- * - * Tcl_BinaryObjCmd -- + * TclInitBinaryCmd -- + * + * 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. + * + * Side effects: + * Creates a new binary command as a mapped ensemble. + * + *---------------------------------------------------------------------- + */ + +Tcl_Command +TclInitBinaryCmd(Tcl_Interp *interp) +{ + return TclMakeEnsemble(interp, "binary", defaultBinaryMap); +} + +/* + *---------------------------------------------------------------------- + * + * BinaryFormatCmd -- * - * This procedure implements the "binary" Tcl command. + * This procedure implements the "binary format" Tcl command. * * Results: * A standard Tcl result. @@ -555,8 +593,8 @@ UpdateStringOfByteArray( *---------------------------------------------------------------------- */ -int -Tcl_BinaryObjCmd( +static int +BinaryFormatCmd( ClientData dummy, /* Not used. */ Tcl_Interp *interp, /* Current interpreter. */ int objc, /* Number of arguments. */ @@ -578,48 +616,30 @@ Tcl_BinaryObjCmd( * cursor has visited.*/ const char *errorString; char *errorValue, *str; - int offset, size, length, index; - static const char *options[] = { - "format", "scan", NULL - }; - enum options { - BINARY_FORMAT, BINARY_SCAN - }; + int offset, size, length; if (objc < 2) { - Tcl_WrongNumArgs(interp, 1, objv, "option ?arg arg ...?"); + Tcl_WrongNumArgs(interp, 1, objv, "formatString ?arg arg ...?"); return TCL_ERROR; } - if (Tcl_GetIndexFromObj(interp, objv[1], options, "option", 0, - &index) != TCL_OK) { - return TCL_ERROR; - } - - switch ((enum options) index) { - case BINARY_FORMAT: - if (objc < 3) { - Tcl_WrongNumArgs(interp, 2, objv, "formatString ?arg arg ...?"); - return TCL_ERROR; + /* + * To avoid copying the data, we format the string in two passes. The + * first pass computes the size of the output buffer. The second pass + * places the formatted data into the buffer. + */ + + format = TclGetString(objv[1]); + arg = 2; + offset = 0; + length = 0; + while (*format != '\0') { + str = format; + flags = 0; + if (!GetFormatSpec(&format, &cmd, &count, &flags)) { + break; } - - /* - * To avoid copying the data, we format the string in two passes. The - * first pass computes the size of the output buffer. The second pass - * places the formatted data into the buffer. - */ - - format = TclGetString(objv[2]); - arg = 3; - offset = 0; - length = 0; - while (*format != '\0') { - str = format; - flags = 0; - if (!GetFormatSpec(&format, &cmd, &count, &flags)) { - break; - } - switch (cmd) { + switch (cmd) { case 'a': case 'A': case 'b': @@ -630,7 +650,7 @@ Tcl_BinaryObjCmd( * For string-type specifiers, the count corresponds to the * number of bytes in a single argument. */ - + if (arg >= objc) { goto badIndex; } @@ -694,7 +714,7 @@ Tcl_BinaryObjCmd( } else { int listc; Tcl_Obj **listv; - + /* The macro evals its args more than once: avoid arg++ */ if (TclListObjGetElements(interp, objv[arg], &listc, &listv) != TCL_OK) { @@ -706,19 +726,19 @@ Tcl_BinaryObjCmd( count = listc; } else if (count > listc) { Tcl_AppendResult(interp, - "number of elements in list does not match count", - NULL); + "number of elements in list does not match count", + NULL); return TCL_ERROR; } } offset += count*size; break; - + case 'x': if (count == BINARY_ALL) { Tcl_AppendResult(interp, - "cannot use \"*\" in format string with \"x\"", - NULL); + "cannot use \"*\" in format string with \"x\"", + NULL); return TCL_ERROR; } else if (count == BINARY_NOCOUNT) { count = 1; @@ -752,53 +772,53 @@ Tcl_BinaryObjCmd( default: errorString = str; goto badField; - } - } - if (offset > length) { - length = offset; } - if (length == 0) { - return TCL_OK; - } - - /* - * Prepare the result object by preallocating the caclulated number of - * bytes and filling with nulls. - */ - - resultPtr = Tcl_NewObj(); - buffer = Tcl_SetByteArrayLength(resultPtr, length); - memset(buffer, 0, (size_t) length); - - /* - * Pack the data into the result object. Note that we can skip the - * error checking during this pass, since we have already parsed the - * string once. - */ + } + if (offset > length) { + length = offset; + } + if (length == 0) { + return TCL_OK; + } + + /* + * Prepare the result object by preallocating the caclulated number of + * bytes and filling with nulls. + */ + + resultPtr = Tcl_NewObj(); + buffer = Tcl_SetByteArrayLength(resultPtr, length); + memset(buffer, 0, (size_t) length); + + /* + * Pack the data into the result object. Note that we can skip the + * error checking during this pass, since we have already parsed the + * string once. + */ - arg = 3; - format = TclGetString(objv[2]); - cursor = buffer; - maxPos = cursor; - while (*format != 0) { - flags = 0; - if (!GetFormatSpec(&format, &cmd, &count, &flags)) { - break; - } - if ((count == 0) && (cmd != '@')) { - if (cmd != 'x') { - arg++; - } - continue; + arg = 2; + format = TclGetString(objv[1]); + cursor = buffer; + maxPos = cursor; + while (*format != 0) { + flags = 0; + if (!GetFormatSpec(&format, &cmd, &count, &flags)) { + break; + } + if ((count == 0) && (cmd != '@')) { + if (cmd != 'x') { + arg++; } - switch (cmd) { + continue; + } + switch (cmd) { case 'a': case 'A': { char pad = (char) (cmd == 'a' ? '\0' : ' '); unsigned char *bytes; - + bytes = Tcl_GetByteArrayFromObj(objv[arg++], &length); - + if (count == BINARY_ALL) { count = length; } else if (count == BINARY_NOCOUNT) { @@ -816,7 +836,7 @@ Tcl_BinaryObjCmd( case 'b': case 'B': { unsigned char *last; - + str = TclGetStringFromObj(objv[arg], &length); arg++; if (count == BINARY_ALL) { @@ -878,7 +898,7 @@ Tcl_BinaryObjCmd( case 'H': { unsigned char *last; int c; - + str = TclGetStringFromObj(objv[arg], &length); arg++; if (count == BINARY_ALL) { @@ -1024,39 +1044,108 @@ Tcl_BinaryObjCmd( cursor = buffer + count; } break; - } } - Tcl_SetObjResult(interp, resultPtr); - break; - case BINARY_SCAN: { - int i; - Tcl_Obj *valuePtr, *elementPtr; - Tcl_HashTable numberCacheHash; - Tcl_HashTable *numberCachePtr; - - if (objc < 4) { - Tcl_WrongNumArgs(interp, 2, objv, - "value formatString ?varName varName ...?"); - return TCL_ERROR; + } + Tcl_SetObjResult(interp, resultPtr); + return TCL_OK; + + badValue: + Tcl_ResetResult(interp); + Tcl_AppendResult(interp, "expected ", errorString, + " string but got \"", errorValue, "\" instead", NULL); + return TCL_ERROR; + + badCount: + errorString = "missing count for \"@\" field specifier"; + goto error; + + badIndex: + errorString = "not enough arguments for all format specifiers"; + goto error; + + badField: + { + Tcl_UniChar ch; + char buf[TCL_UTF_MAX + 1]; + + Tcl_UtfToUniChar(errorString, &ch); + buf[Tcl_UniCharToUtf(ch, buf)] = '\0'; + Tcl_AppendResult(interp, "bad field specifier \"", buf, "\"", NULL); + return TCL_ERROR; + } + + error: + Tcl_AppendResult(interp, errorString, NULL); + return TCL_ERROR; +} + +/* + *---------------------------------------------------------------------- + * + * BinaryScanCmd -- + * + * This procedure implements the "binary scan" Tcl command. + * + * Results: + * A standard Tcl result. + * + * Side effects: + * See the user documentation. + * + *---------------------------------------------------------------------- + */ + +int +BinaryScanCmd( + ClientData dummy, /* Not used. */ + Tcl_Interp *interp, /* Current interpreter. */ + int objc, /* Number of arguments. */ + Tcl_Obj *const objv[]) /* Argument objects. */ +{ + int arg; /* Index of next argument to consume. */ + int value = 0; /* Current integer value to be packed. + * Initialized to avoid compiler warning. */ + char cmd; /* Current format character. */ + int count; /* Count associated with current format + * character. */ + int flags; /* Format field flags */ + char *format; /* Pointer to current position in format + * string. */ + Tcl_Obj *resultPtr = NULL; /* Object holding result buffer. */ + unsigned char *buffer; /* Start of result buffer. */ + unsigned char *cursor; /* Current position within result buffer. */ + const char *errorString; + char *str; + int offset, size, length; + + int i; + Tcl_Obj *valuePtr, *elementPtr; + Tcl_HashTable numberCacheHash; + Tcl_HashTable *numberCachePtr; + + if (objc < 3) { + Tcl_WrongNumArgs(interp, 1, objv, + "value formatString ?varName varName ...?"); + return TCL_ERROR; + } + numberCachePtr = &numberCacheHash; + Tcl_InitHashTable(numberCachePtr, TCL_ONE_WORD_KEYS); + buffer = Tcl_GetByteArrayFromObj(objv[1], &length); + format = TclGetString(objv[2]); + cursor = buffer; + arg = 3; + offset = 0; + while (*format != '\0') { + str = format; + flags = 0; + if (!GetFormatSpec(&format, &cmd, &count, &flags)) { + goto done; } - numberCachePtr = &numberCacheHash; - Tcl_InitHashTable(numberCachePtr, TCL_ONE_WORD_KEYS); - buffer = Tcl_GetByteArrayFromObj(objv[2], &length); - format = TclGetString(objv[3]); - cursor = buffer; - arg = 4; - offset = 0; - while (*format != '\0') { - str = format; - flags = 0; - if (!GetFormatSpec(&format, &cmd, &count, &flags)) { - goto done; - } - switch (cmd) { + switch (cmd) { case 'a': case 'A': { unsigned char *src; - + if (arg >= objc) { DeleteScanNumberCache(numberCachePtr); goto badIndex; @@ -1071,14 +1160,14 @@ Tcl_BinaryObjCmd( goto done; } } - + src = buffer + offset; size = count; - + /* * Trim trailing nulls and spaces, if necessary. */ - + if (cmd == 'A') { while (size > 0) { if (src[size-1] != '\0' && src[size-1] != ' ') { @@ -1087,7 +1176,7 @@ Tcl_BinaryObjCmd( size--; } } - + /* * Have to do this #ifdef-fery because (as part of defining * Tcl_NewByteArrayObj) we removed the #def that hides this @@ -1326,47 +1415,39 @@ Tcl_BinaryObjCmd( DeleteScanNumberCache(numberCachePtr); errorString = str; goto badField; - } } - - /* - * Set the result to the last position of the cursor. - */ - - done: - Tcl_SetObjResult(interp, Tcl_NewLongObj(arg - 4)); - DeleteScanNumberCache(numberCachePtr); - break; - } } + + /* + * Set the result to the last position of the cursor. + */ + + done: + Tcl_SetObjResult(interp, Tcl_NewLongObj(arg - 3)); + DeleteScanNumberCache(numberCachePtr); + return TCL_OK; - - badValue: - Tcl_ResetResult(interp); - Tcl_AppendResult(interp, "expected ", errorString, - " string but got \"", errorValue, "\" instead", NULL); - return TCL_ERROR; - - badCount: + + badCount: errorString = "missing count for \"@\" field specifier"; goto error; - - badIndex: + + badIndex: errorString = "not enough arguments for all format specifiers"; goto error; - - badField: + + badField: { Tcl_UniChar ch; char buf[TCL_UTF_MAX + 1]; - + Tcl_UtfToUniChar(errorString, &ch); buf[Tcl_UniCharToUtf(ch, buf)] = '\0'; Tcl_AppendResult(interp, "bad field specifier \"", buf, "\"", NULL); return TCL_ERROR; } - - error: + + error: Tcl_AppendResult(interp, errorString, NULL); return TCL_ERROR; } diff --git a/generic/tclInt.h b/generic/tclInt.h index 2c50d21..93adf2a 100644 --- a/generic/tclInt.h +++ b/generic/tclInt.h @@ -13,7 +13,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.366 2008/05/02 10:27:07 dkf Exp $ + * RCS: @(#) $Id: tclInt.h,v 1.367 2008/05/02 20:08:52 patthoyts Exp $ */ #ifndef _TCLINT @@ -2702,9 +2702,7 @@ MODULE_SCOPE int Tcl_ApplyObjCmd(ClientData clientData, MODULE_SCOPE int Tcl_ArrayObjCmd(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]); -MODULE_SCOPE int Tcl_BinaryObjCmd(ClientData clientData, - Tcl_Interp *interp, int objc, - Tcl_Obj *const objv[]); +MODULE_SCOPE Tcl_Command TclInitBinaryCmd(Tcl_Interp *interp); MODULE_SCOPE int Tcl_BreakObjCmd(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]); diff --git a/tests/binary.test b/tests/binary.test index 71acaf3..28e9c78 100644 --- a/tests/binary.test +++ b/tests/binary.test @@ -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: binary.test,v 1.32 2008/03/24 03:10:46 patthoyts Exp $ +# RCS: @(#) $Id: binary.test,v 1.33 2008/05/02 20:08:53 patthoyts Exp $ if {[lsearch [namespace children] ::tcltest] == -1} { package require tcltest @@ -31,10 +31,10 @@ test binary-0.1 {DupByteArrayInternalRep} { test binary-1.1 {Tcl_BinaryObjCmd: bad args} { list [catch {binary} msg] $msg -} {1 {wrong # args: should be "binary option ?arg arg ...?"}} +} {1 {wrong # args: should be "binary subcommand ?argument ...?"}} test binary-1.2 {Tcl_BinaryObjCmd: bad args} { list [catch {binary foo} msg] $msg -} {1 {bad option "foo": must be format or scan}} +} {1 {unknown or ambiguous subcommand "foo": must be format, or scan}} test binary-1.3 {Tcl_BinaryObjCmd: format error} { list [catch {binary f} msg] $msg @@ -1541,7 +1541,7 @@ test binary-41.8 {ScanNumber: word alignment} littleEndian { test binary-42.1 {Tcl_BinaryObjCmd: bad arguments} {} { catch {binary ?} result set result -} {bad option "?": must be format or scan} +} {unknown or ambiguous subcommand "?": must be format, or scan} # Wide int (guaranteed at least 64-bit) handling test binary-43.1 {Tcl_BinaryObjCmd: format wide int} {} { |