Tcl Source Code

 *	See the user documentation.
 *
 *----------------------------------------------------------------------
 */

static int
BinarySetCmd(
    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 */
    const char *format;		/* Pointer to current position in format
				 * string. */
    Var *varPtr, *arrayPtr;
    Tcl_Obj *valuePtr;		/* Object holding binary value buffer. */




    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;

    const unsigned char *bytes;
    int offset, size, length, originalLength, duplicated = 0;
    int type, isFloat, i, argLength, listc;



    ClientData data;
    Tcl_WideInt wide;
    Tcl_Obj **listv;


    if (objc < 3) {
	Tcl_WrongNumArgs(interp, 1, objv, "varName formatString ?arg ...?");
	return TCL_ERROR;
    }

    /*
     * Trickery to create the variable if it didn't already exist but without
     * changing its internal representation at all; depends on the fact that
     * concatenating the empty string is a special case.
     */

    varPtr = TclObjLookupVarEx(interp, objv[1], NULL, TCL_LEAVE_ERR_MSG,
	    "set", /*createPart1*/ 1, /*createPart2*/ 1, &arrayPtr);
    if (varPtr == NULL) {
	return TCL_ERROR;
    }
    valuePtr = TclPtrGetVarIdx(interp, varPtr, arrayPtr, objv[1], NULL, 0, -1);
    if (valuePtr == NULL) {
	TclNewObj(valuePtr);
    }


    (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.
................................................................................
	     * 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) {
		    double dummy;
		    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) {
................................................................................
		} else if (count > listc) {
		    errorString =
			    "number of elements in list does not match count";
		    goto error;
		}
		for (i = 0; i < count; i++) {
		    if (isFloat) {
			double dummy;
			if (TclGetNumberFromObj(NULL, listv[i],
				&data, &type) != TCL_OK) {
			    return Tcl_GetDoubleFromObj(interp, listv[i],
				    &dummy);
			}
		    } else {
			if (Tcl_GetWideIntFromObj(interp, listv[i],
................................................................................
    /*
     * 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 (Tcl_IsShared(valuePtr)) {
	valuePtr = Tcl_DuplicateObj(valuePtr);
	duplicated = 1;
    }
    buffer = Tcl_SetByteArrayLength(valuePtr, length);
    if (length > originalLength) {
	memset(buffer + originalLength, 0, length - originalLength);
    }

    /*
................................................................................
		count = 1;
	    }
	    last = cursor + ((count + 7) / 8);
	    if (count > length) {
		count = length;
	    }
	    value = 0;
	    errorString = "binary";
	    if (cmd == 'B') {
		for (offset = 0; offset < count; offset++) {
		    value <<= 1;
		    if (str[offset] == '1') {
			value |= 1;
		    }
		    if (((offset + 1) % 8) == 0) {
................................................................................
		count = 1;
	    }
	    last = cursor + ((count + 1) / 2);
	    if (count > length) {
		count = length;
	    }
	    value = 0;
	    errorString = "hexadecimal";
	    if (cmd == 'H') {
		for (offset = 0; offset < count; offset++) {
		    value <<= 4;
		    c = str[offset] - '0';
		    if (c > 9) {
			c += ('0' - 'A') + 10;
		    }
................................................................................
	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);
................................................................................
		/*
		 * 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;
................................................................................
		cursor = maxPos;
	    } else {
		cursor = buffer + count;
	    }
	    break;
	}
    }








    if (!TclPtrSetVarIdx(interp, varPtr, arrayPtr, objv[1], NULL, valuePtr,
	    TCL_LEAVE_ERR_MSG, -1)) {
	/*
	 * Failure here with an in-place modification means there are traces
	 * applying shenanigans.
	 */

	if (duplicated) {
	    TclDecrRefCount(valuePtr);
	}
	return TCL_ERROR;
    }

    return TCL_OK;

 badValue:
    Tcl_ResetResult(interp);
    Tcl_SetObjResult(interp, Tcl_ObjPrintf(
	    "expected %s string but got \"%s\" instead",
	    errorString, errorValue));

 *	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.
................................................................................
	     * 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) {
................................................................................
		} 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],
................................................................................
    /*
     * 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);
    }

    /*
................................................................................
		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) {
................................................................................
		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;
		    }
................................................................................
	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);
................................................................................
		/*
		 * 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;
................................................................................
		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));

} -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 x
} -result {1 {expected integer but got "gorp"} 0}









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} {

} -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} {