Index: doc/binary.n ================================================================== --- doc/binary.n +++ doc/binary.n @@ -17,10 +17,14 @@ \fBbinary encode \fIformat\fR ?\fI\-option value ...\fR? \fIdata\fR .br \fBbinary format \fIformatString \fR?\fIarg arg ...\fR? .br \fBbinary scan \fIstring formatString \fR?\fIvarName varName ...\fR? +.br +.VS "8.7, TIP 450" +\fBbinary set \fIvarName formatString \fR?\fIarg arg ...\fR? +.VE "8.7, TIP 450" .BE .SH DESCRIPTION .PP This command provides facilities for manipulating binary data. The subcommand \fBbinary format\fR creates a binary string from normal @@ -27,10 +31,14 @@ Tcl values. For example, given the values 16 and 22, on a 32-bit architecture, it might produce an 8-byte binary string consisting of two 4-byte integers, one for each of the numbers. The subcommand \fBbinary scan\fR, does the opposite: it extracts data from a binary string and returns it as ordinary Tcl string values. +.VS "8.7, TIP 450" +The subcommand \fBbinary set\fR is similar to \fBbinary format\fR, except that +it updates an existing binary string in a variable. +.VE "8.7, TIP 450" The \fBbinary encode\fR and \fBbinary decode\fR subcommands convert binary data to or from string encodings such as base64 (used in MIME messages for example). .PP Note that other operations on binary data, such as taking a subsequence of it, @@ -121,17 +129,24 @@ characters. Otherwise it ignores them. .PP Note that neither the encoder nor the decoder handle the header and footer of the uuencode format. .RE -.SH "BINARY FORMAT" +.SH "BINARY FORMAT AND BINARY SET" .PP The \fBbinary format\fR command generates a binary string whose layout is specified by the \fIformatString\fR and whose contents come from the additional arguments. The resulting binary value is returned. .PP -The \fIformatString\fR consists of a sequence of zero or more field +.VS "8.7, TIP 450" +The \fBbinary set\fR command reads an existing binary string stored in the +variable \fIvarName\fR, modifies it according to the \fIformatString\fR using +the contents from the additional arguments, and writes the result back. The +result of the command is the empty string. +.VE "8.7, TIP 450" +.PP +In both cases, \fIformatString\fR consists of a sequence of zero or more field specifiers separated by zero or more spaces. Each field specifier is a single type character followed by an optional flag character followed by an optional numeric \fIcount\fR. Most field specifiers consume one argument to obtain the value to be formatted. The type character specifies how the value is to be @@ -141,11 +156,12 @@ .QW \fB*\fR , which normally indicates that all of the items in the value are to be used. If the number of arguments does not match the number of fields in the format string that consume arguments, then an error is generated. The flag character -is ignored for \fBbinary format\fR. +.QW \fBu\fR +is ignored for \fBbinary format\fR and \fBbinary set\fR. .PP Here is a small example to clarify the relation between the field specifiers and the arguments: .PP .CS @@ -178,11 +194,11 @@ \fIcount\fR is .QW \fB*\fR , then all of the bytes in \fIarg\fR will be formatted. If \fIcount\fR is omitted, then one character will be formatted. For example, the command: -.RS +.RS .PP .CS \fBbinary format\fR a7a*a alpha bravo charlie .CE .PP @@ -384,11 +400,11 @@ .RE .IP \fBS\fR 5 This form is the same as \fBs\fR except that it stores one or more 16-bit integers in big-endian byte order in the output string. For example, -.RS +.RS .PP .CS \fBbinary format\fR S3 {3 -3 258 1} .CE .PP @@ -483,11 +499,12 @@ or more single-precision floating point numbers in the machine's native representation in the output string. This representation is not portable across architectures, so it should not be used to communicate floating point numbers across the network. The size of a floating point number may vary across architectures, so the number of bytes -that are generated may vary. If the value overflows the +that are generated may vary, but is 4 on common architectures that implement +IEEE floating point representation. If the value overflows the machine's native representation, then the value of FLT_MAX as defined by the system will be used instead. Because Tcl uses double-precision floating point numbers internally, there may be some loss of precision in the conversion to single-precision. For example, on a Windows system running on an Intel Pentium processor, @@ -513,11 +530,13 @@ This form is the same as \fBr\fR except that it stores the single-precision floating point numbers in big-endian order. .IP \fBd\fR 5 This form is the same as \fBf\fR except that it stores one or more one or more double-precision floating point numbers in the machine's native -representation in the output string. For example, on a +representation in the output string (these are usually 8 bytes wide on +common architectures, i.e., those that use IEEE floating point representation). +For example, on a Windows system running on an Intel Pentium processor, .RS .PP .CS \fBbinary format\fR d1 {1.6} @@ -593,10 +612,22 @@ will return .PP .CS \fBabfdeghi\e000\e000j\fR .CE +.PP +will return \fBabfdeghi\e000\e000j\fR, and +.VS "8.7, TIP 450" +.PP +.CS +set x abc +\fBbinary set\fR x c@*c 65 68 +.CE +.PP +will update the variable \fIx\fR to \fBAbcD\fR (extending it by one byte from +the value it was before). +.VE "8.7, TIP 450" .RE .SH "BINARY SCAN" .PP The \fBbinary scan\fR command parses fields from a binary string, returning the number of conversions performed. \fIString\fR gives the @@ -623,11 +654,11 @@ position to satisfy the current field specifier, then the corresponding variable is left untouched and \fBbinary scan\fR returns immediately with the number of variables that were set. If there are not enough arguments for all of the fields in the format string that consume arguments, then an error is generated. The flag character -.QW u +.QW \fBu\fR may be given to cause some types to be read as unsigned values. The flag is accepted for all field types but is ignored for non-integer fields. .PP A similar example as with \fBbinary format\fR should explain the relation between field specifiers and arguments in case of the binary @@ -669,11 +700,11 @@ set signShort [\fBbinary format\fR s1 0x8000] \fBbinary scan\fR $signShort s1 val; \fI# val == 0xFFFF8000\fR .CE .PP If you require unsigned values you can include the -.QW u +.QW \fBu\fR flag character following the field type. For example, to read an unsigned short value: .PP .CS set signShort [\fBbinary format\fR s1 0x8000] @@ -807,11 +838,12 @@ will return \fB2\fR with \fB7 -122\fR stored in \fIvar1\fR and \fB5\fR stored in \fIvar2\fR. Note that the integers returned are signed unless \fBcu\fR in place of \fBc\fR. .RE .IP \fBs\fR 5 -The data is interpreted as \fIcount\fR 16-bit signed integers +The data is interpreted as \fIcount\fR 16-bit signed (or unsigned if \fBsu\fR is +used instead of \fBs\fR) integers represented in little-endian byte order, or as unsigned if \fBu\fR is placed immediately after the \fBs\fR. The integers are stored in the corresponding variable as a list. If \fIcount\fR is .QW \fB*\fR , then all of the remaining bytes in \fIstring\fR will be scanned. If @@ -839,18 +871,20 @@ .PP will return \fB2\fR with \fB5 7\fR stored in \fIvar1\fR and \fB\-16\fR stored in \fIvar2\fR. .RE .IP \fBt\fR 5 -The data is interpreted as \fIcount\fR 16-bit signed integers +The data is interpreted as \fIcount\fR 16-bit signed (or unsigned if \fBtu\fR is +used instead of \fBt\fR) integers represented in the native byte order of the machine running the Tcl script, or as unsigned if \fBu\fR is placed immediately after the \fBt\fR. It is otherwise identical to \fBs\fR and \fBS\fR. To determine what the native byte order of the machine is, refer to the \fBbyteOrder\fR element of the \fBtcl_platform\fR array. .IP \fBi\fR 5 -The data is interpreted as \fIcount\fR 32-bit signed integers +The data is interpreted as \fIcount\fR 32-bit signed (or unsigned if \fBiu\fR is +used instead of \fBi\fR) integers represented in little-endian byte order, or as unsigned if \fBu\fR is placed immediately after the \fBi\fR. The integers are stored in the corresponding variable as a list. If \fIcount\fR is .QW \fB*\fR , then all of the remaining bytes in \fIstring\fR will be scanned. If @@ -867,11 +901,12 @@ stored in \fIvar2\fR. Note that the integers returned are signed unless \fBiu\fR is used in place of \fBi\fR. .RE .IP \fBI\fR 5 This form is the same as \fBI\fR except that the data is interpreted -as \fIcount\fR 32-bit signed integers represented in big-endian byte +as \fIcount\fR 32-bit signed (or unsigned if \fBIu\fR is +used instead of \fBI\fR) integers represented in big-endian byte order, or as unsigned if \fBu\fR is placed immediately after the \fBI\fR. For example, .RS .PP .CS @@ -881,18 +916,20 @@ .PP will return \fB2\fR with \fB5 7\fR stored in \fIvar1\fR and \fB\-16\fR stored in \fIvar2\fR. .RE .IP \fBn\fR 5 -The data is interpreted as \fIcount\fR 32-bit signed integers +The data is interpreted as \fIcount\fR 32-bit signed (or unsigned if \fBnu\fR is +used instead of \fBn\fR) integers represented in the native byte order of the machine running the Tcl script, or as unsigned if \fBu\fR is placed immediately after the \fBn\fR. It is otherwise identical to \fBi\fR and \fBI\fR. To determine what the native byte order of the machine is, refer to the \fBbyteOrder\fR element of the \fBtcl_platform\fR array. .IP \fBw\fR 5 -The data is interpreted as \fIcount\fR 64-bit signed integers +The data is interpreted as \fIcount\fR 64-bit signed (or unsigned if \fBwu\fR is +used instead of \fBw\fR) integers represented in little-endian byte order, or as unsigned if \fBu\fR is placed immediately after the \fBw\fR. The integers are stored in the corresponding variable as a list. If \fIcount\fR is .QW \fB*\fR , then all of the remaining bytes in \fIstring\fR will be scanned. If @@ -908,11 +945,12 @@ will return \fB2\fR with \fB30064771077\fR stored in \fIvar1\fR and \fB\-16\fR stored in \fIvar2\fR. .RE .IP \fBW\fR 5 This form is the same as \fBw\fR except that the data is interpreted -as \fIcount\fR 64-bit signed integers represented in big-endian byte +as \fIcount\fR 64-bit signed (or unsigned if \fBWu\fR is +used instead of \fBw\fR) integers represented in big-endian byte order, or as unsigned if \fBu\fR is placed immediately after the \fBW\fR. For example, .RS .PP .CS @@ -922,11 +960,12 @@ .PP will return \fB2\fR with \fB21474836487\fR stored in \fIvar1\fR and \fB\-16\fR stored in \fIvar2\fR. .RE .IP \fBm\fR 5 -The data is interpreted as \fIcount\fR 64-bit signed integers +The data is interpreted as \fIcount\fR 64-bit signed (or unsigned if \fBmu\fR is +used instead of \fBm\fR) integers represented in the native byte order of the machine running the Tcl script, or as unsigned if \fBu\fR is placed immediately after the \fBm\fR. It is otherwise identical to \fBw\fR and \fBW\fR. To determine what the native byte order of the machine is, refer to the \fBbyteOrder\fR element of the \fBtcl_platform\fR array. @@ -938,11 +977,12 @@ .QW \fB*\fR , then all of the remaining bytes in \fIstring\fR will be scanned. If \fIcount\fR is omitted, then one single-precision floating point number will be scanned. The size of a floating point number may vary across architectures, so the number of -bytes that are scanned may vary. If the data does not represent a +bytes that are scanned may vary; on most common architectures (i.e., those +that use IEEE floating point representation) it is 4 bytes wide. If the data does not represent a valid floating point number, the resulting value is undefined and compiler dependent. For example, on a Windows system running on an Intel Pentium processor, .RS .PP @@ -964,11 +1004,12 @@ order. This conversion is not portable to the minority of systems not using IEEE floating point representations. .IP \fBd\fR 5 This form is the same as \fBf\fR except that the data is interpreted as \fIcount\fR double-precision floating point numbers in the -machine's native representation. For example, on a Windows system +machine's native representation (which is 8 bytes wide when IEEE floating +point representation is used; this is the common case). For example, on a Windows system running on an Intel Pentium processor, .RS .PP .CS \fBbinary scan\fR \ex9a\ex99\ex99\ex99\ex99\ex99\exf9\ex3f d var1 Index: generic/tclBinary.c ================================================================== --- generic/tclBinary.c +++ generic/tclBinary.c @@ -78,10 +78,13 @@ 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[]); +static int BinarySetCmd(ClientData clientData, + Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]); /* Binary encoding sub-ensemble commands */ static int BinaryEncodeHex(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]); @@ -139,10 +142,11 @@ */ static const EnsembleImplMap binaryMap[] = { { "format", BinaryFormatCmd, TclCompileBasicMin1ArgCmd, NULL, NULL, 0 }, { "scan", BinaryScanCmd, TclCompileBasicMin2ArgCmd, NULL, NULL, 0 }, + { "set", BinarySetCmd, TclCompileBasicMin2ArgCmd, NULL, NULL, 0 }, { "encode", NULL, NULL, NULL, NULL, 0 }, { "decode", NULL, NULL, NULL, NULL, 0 }, { NULL, NULL, NULL, NULL, NULL, 0 } }; static const EnsembleImplMap encodeMap[] = { @@ -1343,10 +1347,606 @@ } } Tcl_SetObjResult(interp, resultPtr); return TCL_OK; + badValue: + Tcl_ResetResult(interp); + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "expected %s string but got \"%s\" instead", + errorString, errorValue)); + 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 = 0; + char buf[TCL_UTF_MAX + 1] = ""; + + TclUtfToUniChar(errorString, &ch); + buf[Tcl_UniCharToUtf(ch, buf)] = '\0'; + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "bad field specifier \"%s\"", buf)); + return TCL_ERROR; + } + + error: + Tcl_SetObjResult(interp, Tcl_NewStringObj(errorString, -1)); + return TCL_ERROR; +} + +/* + *---------------------------------------------------------------------- + * + * BinarySetCmd -- + * + * This procedure implements the "binary set" Tcl command. + * + * Results: + * A standard Tcl result. + * + * Side effects: + * See the user documentation. + * + *---------------------------------------------------------------------- + */ + +static int +BinarySetCmd( + ClientData ignored, /* 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 */ + const char *format; /* Pointer to current position in format + * string. */ + Tcl_Obj *valuePtr; /* Object holding binary value buffer, which + * might be value read from variable, or might + * be duplicate or new. */ + int originalLength; /* Length of the starting value read from the + * variable. */ + unsigned char *buffer; /* Start of result buffer. */ + unsigned char *cursor; /* Current position within result buffer. */ + unsigned char *maxPos; /* Greatest position within result buffer that + * cursor has visited.*/ + const char *errorString; + const char *errorValue, *str; + int offset, size, length, i, argLength; + const unsigned char *bytes; /* Working buffer for testing arguments. */ + Tcl_Obj **listv; /* Used for parsing list arguments. */ + int listc; /* Used for parsing list arguments. */ + int isFloat; /* What type of number parsing to use. */ + int type; /* Used for parsing numbers. */ + ClientData data; /* Used for parsing numbers. */ + Tcl_WideInt wide; /* Used for parsing numbers. */ + double dummy; /* Used for parsing numbers. */ + + if (objc < 3) { + Tcl_WrongNumArgs(interp, 1, objv, "varName formatString ?arg ...?"); + return TCL_ERROR; + } + + valuePtr = Tcl_ObjGetVar2(interp, objv[1], NULL, 0); + if (valuePtr == NULL) { + originalLength = 0; + } else { + (void) Tcl_GetByteArrayFromObj(valuePtr, &originalLength); + } + length = originalLength; + + /* + * To avoid copying the data, we format the string in two passes. The + * first pass computes the size of the output buffer and checks that the + * supplied values are legal. The second pass places the formatted data + * into the buffer. + */ + + format = TclGetString(objv[2]); + arg = 3; + offset = 0; + while (*format != '\0') { + str = format; + flags = 0; + if (!GetFormatSpec(&format, &cmd, &count, &flags)) { + break; + } + isFloat = 0; + switch (cmd) { + case 'b': + case 'B': + /* + * For string-type specifiers, the count corresponds to the number + * of bytes in a single argument. + */ + + if (arg >= objc) { + goto badIndex; + } + if (count == BINARY_ALL) { + Tcl_GetByteArrayFromObj(objv[arg], &count); + } else if (count == BINARY_NOCOUNT) { + count = 1; + } + bytes = Tcl_GetByteArrayFromObj(objv[arg], &argLength); + if (count > argLength) { + count = argLength; + } + for (i = 0 ; i < count; i++) { + switch (bytes[i]) { + case '0': + case '1': + break; + default: + errorString = "binary"; + errorValue = Tcl_GetString(objv[arg]); + goto badValue; + } + } + arg++; + offset += (count + 7) / 8; + break; + case 'h': + case 'H': + /* + * For string-type specifiers, the count corresponds to the number + * of bytes in a single argument. + */ + + if (arg >= objc) { + goto badIndex; + } + if (count == BINARY_ALL) { + Tcl_GetByteArrayFromObj(objv[arg], &count); + } else if (count == BINARY_NOCOUNT) { + count = 1; + } + bytes = Tcl_GetByteArrayFromObj(objv[arg], &argLength); + if (count > argLength) { + count = argLength; + } + for (i = 0 ; i < count; i++) { + if (!isxdigit(bytes[i])) { /* INTL: digit */ + errorString = "hexadecimal"; + errorValue = Tcl_GetString(objv[arg]); + goto badValue; + } + } + arg++; + offset += (count + 1) / 2; + break; + case 'a': + case 'A': + /* + * For string-type specifiers, the count corresponds to the number + * of bytes in a single argument. + */ + + if (arg >= objc) { + goto badIndex; + } + if (count == BINARY_ALL) { + Tcl_GetByteArrayFromObj(objv[arg], &count); + } else if (count == BINARY_NOCOUNT) { + count = 1; + } + arg++; + offset += count; + break; + case 'c': + size = 1; + goto doNumbers; + case 't': + case 's': + case 'S': + size = 2; + goto doNumbers; + case 'n': + case 'i': + case 'I': + size = 4; + goto doNumbers; + case 'm': + case 'w': + case 'W': + size = 8; + goto doNumbers; + case 'r': + case 'R': + case 'f': + size = sizeof(float); + isFloat = 1; + goto doNumbers; + case 'q': + case 'Q': + case 'd': + size = sizeof(double); + isFloat = 1; + + doNumbers: + if (arg >= objc) { + goto badIndex; + } + + /* + * For number-type specifiers, the count corresponds to the number + * of elements in the list stored in a single argument. If no + * count is specified, then the argument is taken as a single + * non-list value. + */ + + if (count == BINARY_NOCOUNT) { + if (isFloat) { + if (TclGetNumberFromObj(NULL, objv[arg], + &data, &type) != TCL_OK) { + return Tcl_GetDoubleFromObj(interp, objv[arg], &dummy); + } + } else { + if (Tcl_GetWideIntFromObj(interp, objv[arg], + &wide) != TCL_OK) { + return TCL_ERROR; + } + } + count = 1; + } else { + /* + * The macro evals its args more than once: avoid arg++ + */ + + if (TclListObjGetElements(interp, objv[arg], &listc, + &listv) != TCL_OK) { + return TCL_ERROR; + } + + if (count == BINARY_ALL) { + count = listc; + } else if (count > listc) { + errorString = + "number of elements in list does not match count"; + goto error; + } + for (i = 0; i < count; i++) { + if (isFloat) { + if (TclGetNumberFromObj(NULL, listv[i], + &data, &type) != TCL_OK) { + return Tcl_GetDoubleFromObj(interp, listv[i], + &dummy); + } + } else { + if (Tcl_GetWideIntFromObj(interp, listv[i], + &wide) != TCL_OK) { + return TCL_ERROR; + } + } + } + } + arg++; + offset += count * size; + break; + + case 'x': + if (count == BINARY_ALL) { + errorString = "cannot use \"*\" in format string with \"x\""; + goto error; + } else if (count == BINARY_NOCOUNT) { + count = 1; + } + offset += count; + break; + case 'X': + if (count == BINARY_NOCOUNT) { + count = 1; + } + if ((count > offset) || (count == BINARY_ALL)) { + count = offset; + } + if (offset > length) { + length = offset; + } + offset -= count; + break; + case '@': + if (offset > length) { + length = offset; + } + if (count == BINARY_ALL) { + offset = length; + } else if (count == BINARY_NOCOUNT) { + goto badCount; + } else { + offset = count; + } + break; + default: + errorString = str; + goto badField; + } + } + if (offset > length) { + length = offset; + } + + /* + * Prepare the result object by preallocating the caclulated number of + * bytes and filling with nulls. Note that if we use an operation that can + * fail part way through, we must duplicate here even if the object is + * unshared because we mustn't mutate anything on failure. Bother. + */ + + if (valuePtr == NULL) { + valuePtr = Tcl_NewObj(); + } else if (Tcl_IsShared(valuePtr)) { + valuePtr = Tcl_DuplicateObj(valuePtr); + } + buffer = Tcl_SetByteArrayLength(valuePtr, length); + if (length > originalLength) { + memset(buffer + originalLength, 0, length - originalLength); + } + + /* + * 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 + originalLength; + while (*format != 0) { + flags = 0; + if (!GetFormatSpec(&format, &cmd, &count, &flags)) { + break; + } + if ((count == 0) && (cmd != '@')) { + if (cmd != 'x') { + arg++; + } + continue; + } + switch (cmd) { + case 'a': + case 'A': { + char pad = (char) (cmd == 'a' ? '\0' : ' '); + + bytes = Tcl_GetByteArrayFromObj(objv[arg++], &length); + + if (count == BINARY_ALL) { + count = length; + } else if (count == BINARY_NOCOUNT) { + count = 1; + } + if (length >= count) { + memcpy(cursor, bytes, count); + } else { + memcpy(cursor, bytes, length); + memset(cursor + length, pad, count - length); + } + cursor += count; + break; + } + case 'b': + case 'B': { + unsigned char *last; + + str = TclGetStringFromObj(objv[arg], &length); + arg++; + if (count == BINARY_ALL) { + count = length; + } else if (count == BINARY_NOCOUNT) { + count = 1; + } + last = cursor + ((count + 7) / 8); + if (count > length) { + count = length; + } + value = 0; + if (cmd == 'B') { + for (offset = 0; offset < count; offset++) { + value <<= 1; + if (str[offset] == '1') { + value |= 1; + } + if (((offset + 1) % 8) == 0) { + *cursor++ = UCHAR(value); + value = 0; + } + } + } else { + for (offset = 0; offset < count; offset++) { + value >>= 1; + if (str[offset] == '1') { + value |= 128; + } + if (!((offset + 1) % 8)) { + *cursor++ = UCHAR(value); + value = 0; + } + } + } + if ((offset % 8) != 0) { + if (cmd == 'B') { + value <<= 8 - (offset % 8); + } else { + value >>= 8 - (offset % 8); + } + *cursor++ = UCHAR(value); + } + while (cursor < last) { + *cursor++ = '\0'; + } + break; + } + case 'h': + case 'H': { + unsigned char *last; + int c; + + str = TclGetStringFromObj(objv[arg], &length); + arg++; + if (count == BINARY_ALL) { + count = length; + } else if (count == BINARY_NOCOUNT) { + count = 1; + } + last = cursor + ((count + 1) / 2); + if (count > length) { + count = length; + } + value = 0; + if (cmd == 'H') { + for (offset = 0; offset < count; offset++) { + value <<= 4; + c = str[offset] - '0'; + if (c > 9) { + c += ('0' - 'A') + 10; + } + if (c > 16) { + c += ('A' - 'a'); + } + value |= (c & 0xf); + if (offset % 2) { + *cursor++ = (char) value; + value = 0; + } + } + } else { + for (offset = 0; offset < count; offset++) { + value >>= 4; + c = str[offset] - '0'; + if (c > 9) { + c += ('0' - 'A') + 10; + } + if (c > 16) { + c += ('A' - 'a'); + } + value |= ((c << 4) & 0xf0); + if (offset % 2) { + *cursor++ = UCHAR(value & 0xff); + value = 0; + } + } + } + if (offset % 2) { + if (cmd == 'H') { + value <<= 4; + } else { + value >>= 4; + } + *cursor++ = UCHAR(value); + } + + while (cursor < last) { + *cursor++ = '\0'; + } + break; + } + case 'c': + case 't': + case 's': + case 'S': + case 'n': + case 'i': + case 'I': + case 'm': + case 'w': + case 'W': + case 'r': + case 'R': + case 'd': + case 'q': + case 'Q': + case 'f': + if (count == BINARY_NOCOUNT) { + /* + * Note that we are casting away the const-ness of objv, but + * this is safe since we aren't going to modify the array. + */ + + listv = (Tcl_Obj **) (objv + arg); + listc = 1; + count = 1; + } else { + TclListObjGetElements(interp, objv[arg], &listc, &listv); + if (count == BINARY_ALL) { + count = listc; + } + } + arg++; + for (i = 0; i < count; i++) { + /* + * Already checked the error cases. + */ + + (void) FormatNumber(interp, cmd, listv[i], &cursor); + } + break; + case 'x': + if (count == BINARY_NOCOUNT) { + count = 1; + } + memset(cursor, 0, count); + cursor += count; + break; + case 'X': + if (cursor > maxPos) { + maxPos = cursor; + } + if (count == BINARY_NOCOUNT) { + count = 1; + } + if ((count == BINARY_ALL) || (count > cursor - buffer)) { + cursor = buffer; + } else { + cursor -= count; + } + break; + case '@': + if (cursor > maxPos) { + maxPos = cursor; + } + if (count == BINARY_ALL) { + cursor = maxPos; + } else { + cursor = buffer + count; + } + break; + } + } + + /* + * Store the value back in the variable. This is vital if the value was + * allocated in this function, which could be the case if either we + * duplicated a shared value or we are assigning the variable anew. + */ + + Tcl_IncrRefCount(valuePtr); + if (!Tcl_ObjSetVar2(interp, objv[1], NULL, valuePtr, TCL_LEAVE_ERR_MSG)) { + /* + * Failure here with an in-place modification means there are traces + * applying shenanigans. + */ + + TclDecrRefCount(valuePtr); + return TCL_ERROR; + } + TclDecrRefCount(valuePtr); + return TCL_OK; + badValue: Tcl_ResetResult(interp); Tcl_SetObjResult(interp, Tcl_ObjPrintf( "expected %s string but got \"%s\" instead", errorString, errorValue)); Index: tests/binary.test ================================================================== --- tests/binary.test +++ tests/binary.test @@ -641,11 +641,11 @@ test binary-18.1 {Tcl_BinaryObjCmd: format} -returnCodes error -body { binary format u0a3 abc abd } -result {bad field specifier "u"} test binary-19.1 {Tcl_BinaryObjCmd: errors} -returnCodes error -body { - binary s + binary sc } -result {wrong # args: should be "binary scan value formatString ?varName ...?"} test binary-19.2 {Tcl_BinaryObjCmd: errors} -returnCodes error -body { binary scan foo } -result {wrong # args: should be "binary scan value formatString ?varName ...?"} test binary-19.3 {Tcl_BinaryObjCmd: scan} { @@ -2915,10 +2915,653 @@ # just test for BO-segfault (high surrogate w/o advance source pointer for out of BMP char if TCL_UTF_MAX <= 4): binary encode hex \U0001f415 binary scan \U0001f415 a* v; set v set str {} } -result {} + +test binary-79.1 {binary set} { + list [set x abc] [binary set x @1c 66] [set x] +} {abc {} aBc} +test binary-79.2 {binary set} -returnCodes error -body { + binary set +} -result {wrong # args: should be "binary set varName formatString ?arg ...?"} +test binary-79.3 {binary set} -returnCodes error -body { + binary set x +} -result {wrong # args: should be "binary set varName formatString ?arg ...?"} +test binary-79.4 {binary set} -returnCodes error -body { + binary set x c +} -result {not enough arguments for all format specifiers} +test binary-79.5 {binary set} -setup { + unset -nocomplain ary + array set ary {x y} +} -returnCodes error -body { + binary set ary c 1 +} -cleanup { + unset -nocomplain ary +} -result {can't set "ary": variable is array} +test binary-79.6 {binary set: errors prevent mutation} -setup { + unset -nocomplain x + set foo foo + set bar bar +} -body { + # Make unshared string + set x [format %s%s $foo $bar] + list [catch {binary set x ci 70 gorp} msg] $msg $x +} -cleanup { + unset -nocomplain x +} -result {1 {expected integer but got "gorp"} foobar} +test binary-79.7 {binary set: errors prevent creation} -setup { + unset -nocomplain nosuchvar +} -body { + list [catch {binary set nosuchvar ci 70 gorp} msg] $msg \ + [info exist nosuchvar] +} -cleanup { + unset -nocomplain nosuchvar +} -result {1 {expected integer but got "gorp"} 0} +test binary-79.8 {binary set: create variable} -setup { + unset -nocomplain nosuchvar +} -body { + binary set nosuchvar "c3" {65 66 67} + return $nosuchvar +} -cleanup { + unset -nocomplain nosuchvar +} -result ABC + +test binary-80.1 {binary set: a} { + set x abc + binary set x a A + binary encode hex $x +} 416263 +test binary-80.2 {binary set: a} { + set x abc + binary set x a* AB + binary encode hex $x +} 414263 +test binary-80.3 {binary set: a} { + set x abc + binary set x a1 AB + binary encode hex $x +} 416263 +test binary-80.4 {binary set: a} { + set x abc + binary set x a2 A + binary encode hex $x +} 410063 + +test binary-81.1 {binary set: A} { + set x abc + binary set x A A + binary encode hex $x +} 416263 +test binary-81.2 {binary set: A} { + set x abc + binary set x A* AB + binary encode hex $x +} 414263 +test binary-81.3 {binary set: A} { + set x abc + binary set x A1 AB + binary encode hex $x +} 416263 +test binary-81.4 {binary set: A} { + set x abc + binary set x A2 A + binary encode hex $x +} 412063 + +test binary-82.1 {binary set: b} { + set x abc + binary set x b 10101010 + binary encode hex $x +} 016263 +test binary-82.2 {binary set: b} { + set x abc + binary set x b* 1010101011011010 + binary encode hex $x +} 555b63 +test binary-82.3 {binary set: b} { + set x abc + binary set x b4 1010101010101010 + binary encode hex $x +} 056263 +test binary-82.4 {binary set: b, error case} { + set x abc + append x def + list [catch {binary set x ab8 A 1010gorp} msg] $msg $x +} {1 {expected binary string but got "1010gorp" instead} abcdef} + +test binary-83.1 {binary set: B} { + set x abc + binary set x B 10101010 + binary encode hex $x +} 806263 +test binary-83.2 {binary set: B} { + set x abc + binary set x B* 0101010101101101 + binary encode hex $x +} 556d63 +test binary-83.3 {binary set: B} { + set x abc + binary set x B4 1010101010101010 + binary encode hex $x +} a06263 +test binary-83.4 {binary set: B, error case} { + set x abc + append x def + list [catch {binary set x aB8 A 1010gorp} msg] $msg $x +} {1 {expected binary string but got "1010gorp" instead} abcdef} + +test binary-84.1 {binary set: c} { + set x abc + binary set x c 65 + binary encode hex $x +} 416263 +test binary-84.2 {binary set: c} { + set x abc + binary set x c* {65 66} + binary encode hex $x +} 414263 +test binary-84.3 {binary set: c} { + set x abcdef + binary set x c4 {65 66 67 68 69} + binary encode hex $x +} 414243446566 +test binary-83.4 {binary set: c, error case} { + set x abc + append x def + list [catch {binary set x ac A gorp} msg] $msg $x +} {1 {expected integer but got "gorp"} abcdef} +test binary-83.5 {binary set: c, error case} { + set x abc + append x def + list [catch {binary set x ac2 A {65 gorp}} msg] $msg $x +} {1 {expected integer but got "gorp"} abcdef} + +test binary-85.1 {binary set: h} { + set x abc + binary set x h abcdef + binary encode hex $x +} 0a6263 +test binary-85.2 {binary set: h} { + set x abc + binary set x h* 1424 + binary encode hex $x +} 414263 +test binary-85.3 {binary set: h} { + set x abc + binary set x h4 142434 + binary encode hex $x +} 414263 +test binary-85.4 {binary set: h, error case} { + set x abc + append x def + list [catch {binary set x ah8 A 1010gorp} msg] $msg $x +} {1 {expected hexadecimal string but got "1010gorp" instead} abcdef} + +test binary-86.1 {binary set: H} { + set x abc + binary set x H abcdef + binary encode hex $x +} a06263 +test binary-86.2 {binary set: H} { + set x abc + binary set x H* 4142 + binary encode hex $x +} 414263 +test binary-86.3 {binary set: H} { + set x abc + binary set x H4 414243 + binary encode hex $x +} 414263 +test binary-86.4 {binary set: H, error case} { + set x abc + append x def + list [catch {binary set x aH8 A 1010gorp} msg] $msg $x +} {1 {expected hexadecimal string but got "1010gorp" instead} abcdef} + +test binary-87.1 {binary set: s} { + set x abcdef + binary set x s 65 + binary encode hex $x +} 410063646566 +test binary-87.2 {binary set: s} { + set x abcdef + binary set x s* {65 66} + binary encode hex $x +} 410042006566 +test binary-87.3 {binary set: s} { + set x abcdef + binary set x s2 {65 -66 67 68 69} + binary encode hex $x +} 4100beff6566 +test binary-87.4 {binary set: s, error case} { + set x abc + append x def + list [catch {binary set x as A gorp} msg] $msg $x +} {1 {expected integer but got "gorp"} abcdef} +test binary-87.5 {binary set: s, error case} { + set x abc + append x def + list [catch {binary set x as2 A {65 gorp}} msg] $msg $x +} {1 {expected integer but got "gorp"} abcdef} + +test binary-88.1 {binary set: S} { + set x abcdef + binary set x S 65 + binary encode hex $x +} 004163646566 +test binary-88.2 {binary set: S} { + set x abcdef + binary set x S* {65 66} + binary encode hex $x +} 004100426566 +test binary-88.3 {binary set: S} { + set x abcdef + binary set x S2 {65 -66 67 68 69} + binary encode hex $x +} 0041ffbe6566 +test binary-83.4 {binary set: S, error case} { + set x abc + append x def + list [catch {binary set x aS A gorp} msg] $msg $x +} {1 {expected integer but got "gorp"} abcdef} +test binary-83.5 {binary set: S, error case} { + set x abc + append x def + list [catch {binary set x aS2 A {65 gorp}} msg] $msg $x +} {1 {expected integer but got "gorp"} abcdef} + +test binary-89.1.BE {binary set: t} bigEndian { + set x abcdef + binary set x t 65 + binary encode hex $x +} 004163646566 +test binary-89.2.BE {binary set: t} bigEndian { + set x abcdef + binary set x t* {65 66} + binary encode hex $x +} 004100426566 +test binary-89.3.BE {binary set: t} bigEndian { + set x abcdef + binary set x t2 {65 -66 67 68 69} + binary encode hex $x +} 0041ffbe6566 +test binary-89.1.LE {binary set: t} littleEndian { + set x abcdef + binary set x t 65 + binary encode hex $x +} 410063646566 +test binary-89.2.LE {binary set: t} littleEndian { + set x abcdef + binary set x t* {65 66} + binary encode hex $x +} 410042006566 +test binary-89.3.LE {binary set: t} littleEndian { + set x abcdef + binary set x t2 {65 -66 67 68 69} + binary encode hex $x +} 4100beff6566 + +test binary-90.1 {binary set: i} { + set x abcdefghij + binary set x i 65 + binary encode hex $x +} 4100000065666768696a +test binary-90.2 {binary set: i} { + set x abcdefghij + binary set x i* {65 66} + binary encode hex $x +} 4100000042000000696a +test binary-90.3 {binary set: i} { + set x abcdefghij + binary set x i2 {65 -66 67 68 69} + binary encode hex $x +} 41000000beffffff696a +test binary-90.4 {binary set: i, error case} { + set x abc + append x def + list [catch {binary set x ai A gorp} msg] $msg $x +} {1 {expected integer but got "gorp"} abcdef} +test binary-90.5 {binary set: i, error case} { + set x abc + append x def + list [catch {binary set x ai2 A {65 gorp}} msg] $msg $x +} {1 {expected integer but got "gorp"} abcdef} + +test binary-91.1 {binary set: I} { + set x abcdefghij + binary set x I 65 + binary encode hex $x +} 0000004165666768696a +test binary-91.2 {binary set: I} { + set x abcdefghij + binary set x I* {65 66} + binary encode hex $x +} 0000004100000042696a +test binary-91.3 {binary set: I} { + set x abcdefghij + binary set x I2 {65 -66 67 68 69} + binary encode hex $x +} 00000041ffffffbe696a +test binary-91.4 {binary set: I, error case} { + set x abc + append x def + list [catch {binary set x aI A gorp} msg] $msg $x +} {1 {expected integer but got "gorp"} abcdef} +test binary-91.5 {binary set: I, error case} { + set x abc + append x def + list [catch {binary set x aI2 A {65 gorp}} msg] $msg $x +} {1 {expected integer but got "gorp"} abcdef} + +test binary-92.1.BE {binary set: n} bigEndian { + set x abcdefghij + binary set x n 65 + binary encode hex $x +} 0000004165666768696a +test binary-92.2.BE {binary set: n} bigEndian { + set x abcdefghij + binary set x n* {65 66} + binary encode hex $x +} 0000004100000042696a +test binary-92.3.BE {binary set: n} bigEndian { + set x abcdefghij + binary set x n2 {65 -66 67 68 69} + binary encode hex $x +} 00000041ffffffbe696a +test binary-92.1.LE {binary set: n} littleEndian { + set x abcdefghij + binary set x n 65 + binary encode hex $x +} 4100000065666768696a +test binary-92.2.LE {binary set: n} littleEndian { + set x abcdefghij + binary set x n* {65 66} + binary encode hex $x +} 4100000042000000696a +test binary-92.3.LE {binary set: n} littleEndian { + set x abcdefghij + binary set x n2 {65 -66 67 68 69} + binary encode hex $x +} 41000000beffffff696a + +test binary-93.1 {binary set: w} { + set x abcdefghijklmnopqr + binary set x w 65 + binary encode hex $x +} 4100000000000000696a6b6c6d6e6f707172 +test binary-93.2 {binary set: w} { + set x abcdefghijklmnopqr + binary set x w* {65 66} + binary encode hex $x +} 410000000000000042000000000000007172 +test binary-93.3 {binary set: w} { + set x abcdefghijklmnopqr + binary set x w2 {65 -66 67 68 69} + binary encode hex $x +} 4100000000000000beffffffffffffff7172 +test binary-93.4 {binary set: w, error case} { + set x abc + append x def + list [catch {binary set x aw A gorp} msg] $msg $x +} {1 {expected integer but got "gorp"} abcdef} +test binary-93.5 {binary set: w, error case} { + set x abc + append x def + list [catch {binary set x aw2 A {65 gorp}} msg] $msg $x +} {1 {expected integer but got "gorp"} abcdef} + +test binary-94.1 {binary set: W} { + set x abcdefghijklmnopqr + binary set x W 65 + binary encode hex $x +} 0000000000000041696a6b6c6d6e6f707172 +test binary-94.2 {binary set: W} { + set x abcdefghijklmnopqr + binary set x W* {65 66} + binary encode hex $x +} 000000000000004100000000000000427172 +test binary-94.3 {binary set: W} { + set x abcdefghijklmnopqr + binary set x W2 {65 -66 67 68 69} + binary encode hex $x +} 0000000000000041ffffffffffffffbe7172 +test binary-94.4 {binary set: W, error case} { + set x abc + append x def + list [catch {binary set x aW A gorp} msg] $msg $x +} {1 {expected integer but got "gorp"} abcdef} +test binary-94.5 {binary set: W, error case} { + set x abc + append x def + list [catch {binary set x aW2 A {65 gorp}} msg] $msg $x +} {1 {expected integer but got "gorp"} abcdef} + +test binary-95.1.BE {binary set: m} bigEndian { + set x abcdefghijklmnopqr + binary set x m 65 + binary encode hex $x +} 0000000000000041696a6b6c6d6e6f707172 +test binary-95.2.BE {binary set: m} bigEndian { + set x abcdefghijklmnopqr + binary set x m* {65 66} + binary encode hex $x +} 000000000000004100000000000000427172 +test binary-95.3.BE {binary set: m} bigEndian { + set x abcdefghijklmnopqr + binary set x m2 {65 -66 67 68 69} + binary encode hex $x +} 0000000000000041ffffffffffffffbe7172 +test binary-95.1.LE {binary set: m} littleEndian { + set x abcdefghijklmnopqr + binary set x m 65 + binary encode hex $x +} 4100000000000000696a6b6c6d6e6f707172 +test binary-95.2.LE {binary set: m} littleEndian { + set x abcdefghijklmnopqr + binary set x m* {65 66} + binary encode hex $x +} 410000000000000042000000000000007172 +test binary-95.3.LE {binary set: m} littleEndian { + set x abcdefghijklmnopqr + binary set x m2 {65 -66 67 68 69} + binary encode hex $x +} 4100000000000000beffffffffffffff7172 + +test binary-96.1 {binary set: r} { + set x abcdefghij + binary set x r 65.3 + binary encode hex $x +} 9a99824265666768696a +test binary-96.2 {binary set: r} { + set x abcdefghij + binary set x r* {65.3 66.6} + binary encode hex $x +} 9a99824233338542696a +test binary-96.3 {binary set: r} { + set x abcdefghij + binary set x r2 {65.3 -66.6 67.1 68.8 69.2} + binary encode hex $x +} 9a998242333385c2696a + +test binary-97.1 {binary set: R} { + set x abcdefghij + binary set x R 65.3 + binary encode hex $x +} 4282999a65666768696a +test binary-97.2 {binary set: R} { + set x abcdefghij + binary set x R* {65.3 66.6} + binary encode hex $x +} 4282999a42853333696a +test binary-97.3 {binary set: R} { + set x abcdefghij + binary set x R2 {65.3 -66.6 67.1 68.8 69.2} + binary encode hex $x +} 4282999ac2853333696a + +test binary-98.1.BE {binary set: f} bigEndian { + set x abcdefghij + binary set x f 65.3 + binary encode hex $x +} 4282999a65666768696a +test binary-98.2.BE {binary set: f} bigEndian { + set x abcdefghij + binary set x f* {65.3 66.6} + binary encode hex $x +} 4282999a42853333696a +test binary-98.3.BE {binary set: f} bigEndian { + set x abcdefghij + binary set x f2 {65.3 -66.6 67.1 68.8 69.2} + binary encode hex $x +} 4282999ac2853333696a +test binary-98.1.LE {binary set: f} littleEndian { + set x abcdefghij + binary set x f 65.3 + binary encode hex $x +} 9a99824265666768696a +test binary-98.2.LE {binary set: f} littleEndian { + set x abcdefghij + binary set x f* {65.3 66.6} + binary encode hex $x +} 9a99824233338542696a +test binary-98.3.LE {binary set: f} littleEndian { + set x abcdefghij + binary set x f2 {65.3 -66.6 67.1 68.8 69.2} + binary encode hex $x +} 9a998242333385c2696a +test binary-98.4 {binary set: f, error case} { + set x abc + append x def + list [catch {binary set x af A gorp} msg] $msg $x +} {1 {expected floating-point number but got "gorp"} abcdef} +test binary-98.5 {binary set: f, error case} { + set x abc + append x def + list [catch {binary set x af2 A {65 gorp}} msg] $msg $x +} {1 {expected floating-point number but got "gorp"} abcdef} + +test binary-99.1 {binary set: q} { + set x abcdefghijklmnopqr + binary set x q 65.3 + binary encode hex $x +} 3333333333535040696a6b6c6d6e6f707172 +test binary-99.2 {binary set: q} { + set x abcdefghijklmnopqr + binary set x q* {65.3 66.6} + binary encode hex $x +} 33333333335350406666666666a650407172 +test binary-99.3 {binary set: q} { + set x abcdefghijklmnopqr + binary set x q2 {65.3 -66.6 67.1 68.8 69.2} + binary encode hex $x +} 33333333335350406666666666a650c07172 + +test binary-100.1 {binary set: Q} { + set x abcdefghijklmnopqr + binary set x Q 65.3 + binary encode hex $x +} 4050533333333333696a6b6c6d6e6f707172 +test binary-100.2 {binary set: Q} { + set x abcdefghijklmnopqr + binary set x Q* {65.3 66.6} + binary encode hex $x +} 40505333333333334050a666666666667172 +test binary-100.3 {binary set: Q} { + set x abcdefghijklmnopqr + binary set x Q2 {65.3 -66.6 67.1 68.8 69.2} + binary encode hex $x +} 4050533333333333c050a666666666667172 + +test binary-101.1.BE {binary set: d} bigEndian { + set x abcdefghijklmnopqr + binary set x d 65.3 + binary encode hex $x +} 4050533333333333696a6b6c6d6e6f707172 +test binary-101.2.BE {binary set: d} bigEndian { + set x abcdefghijklmnopqr + binary set x d* {65.3 66.6} + binary encode hex $x +} 40505333333333334050a666666666667172 +test binary-101.3.BE {binary set: d} bigEndian { + set x abcdefghijklmnopqr + binary set x d2 {65.3 -66.6 67.1 68.8 69.2} + binary encode hex $x +} 4050533333333333c050a666666666667172 +test binary-101.1.LE {binary set: d} littleEndian { + set x abcdefghijklmnopqr + binary set x d 65.3 + binary encode hex $x +} 3333333333535040696a6b6c6d6e6f707172 +test binary-101.2.LE {binary set: d} littleEndian { + set x abcdefghijklmnopqr + binary set x d* {65.3 66.6} + binary encode hex $x +} 33333333335350406666666666a650407172 +test binary-101.3.LE {binary set: d} littleEndian { + set x abcdefghijklmnopqr + binary set x d2 {65.3 -66.6 67.1 68.8 69.2} + binary encode hex $x +} 33333333335350406666666666a650c07172 +test binary-101.4 {binary set: d, error case} { + set x abc + append x def + list [catch {binary set x ad A gorp} msg] $msg $x +} {1 {expected floating-point number but got "gorp"} abcdef} +test binary-101.5 {binary set: d, error case} { + set x abc + append x def + list [catch {binary set x ad2 A {65 gorp}} msg] $msg $x +} {1 {expected floating-point number but got "gorp"} abcdef} + +test binary-102.1 {binary set: x} { + set x abc + binary set x x + binary encode hex $x +} 006263 +test binary-102.2 {binary set: x} { + set x abc + binary set x x2 + binary encode hex $x +} 000063 + +test binary-103.1 {binary set: X} { + set x abcdef + binary set x a2Xa AB Z + binary encode hex $x +} 415a63646566 +test binary-103.2 {binary set: X} { + set x abcdef + binary set x a4X2a ABCD Z + binary encode hex $x +} 41425a446566 +test binary-103.3 {binary set: X} { + set x abcdef + binary set x a2X4a ABCD Z + binary encode hex $x +} 5a4263646566 +test binary-103.4 {binary set: X} { + set x abcdef + binary set x a2X*a ABCD Z + binary encode hex $x +} 5a4263646566 + +test binary-104.1 {binary set: @} { + set x abcdef + binary set x a4@2a ABCD Z + binary encode hex $x +} 41425a446566 +test binary-104.2 {binary set: @} { + set x abcdef + binary set x a2@4a ABCD Z + binary encode hex $x +} 414263645a66 +test binary-104.3 {binary set: @} { + set x abcdef + binary set x a2@*a ABCD Z + binary encode hex $x +} 4142636465665a # ---------------------------------------------------------------------- # cleanup ::tcltest::cleanupTests