tclbinary.c

tcl是工具命令语言

			
			resultPtr = Tcl_ObjSetVar2(interp, objv[arg],
				NULL, valuePtr, TCL_LEAVE_ERR_MSG);
			arg++;
			if (resultPtr == NULL) {
			    if (numberCachePtr != NULL) {
				Tcl_DeleteHashTable(numberCachePtr);
			    }
			    Tcl_DecrRefCount(valuePtr);	/* unneeded */
			    return TCL_ERROR;
			}
			offset += (count + 7 ) / 8;
			break;
		    }
		    case 'h':
		    case 'H': {
			char *dest;
			unsigned char *src;
			int i;
			static char hexdigit[] = "0123456789abcdef";

			if (arg >= objc) {
			    if (numberCachePtr != NULL) {
				Tcl_DeleteHashTable(numberCachePtr);
			    }
			    goto badIndex;
			}
			if (count == BINARY_ALL) {
			    count = (length - offset)*2;
			} else {
			    if (count == BINARY_NOCOUNT) {
				count = 1;
			    }
			    if (count > (length - offset)*2) {
				goto done;
			    }
			}
			src = buffer + offset;
			valuePtr = Tcl_NewObj();
			Tcl_SetObjLength(valuePtr, count);
			dest = Tcl_GetString(valuePtr);

			if (cmd == 'h') {
			    for (i = 0; i < count; i++) {
				if (i % 2) {
				    value >>= 4;
				} else {
				    value = *src++;
				}
				*dest++ = hexdigit[value & 0xf];
			    }
			} else {
			    for (i = 0; i < count; i++) {
				if (i % 2) {
				    value <<= 4;
				} else {
				    value = *src++;
				}
				*dest++ = hexdigit[(value >> 4) & 0xf];
			    }
			}
			
			resultPtr = Tcl_ObjSetVar2(interp, objv[arg],
				NULL, valuePtr, TCL_LEAVE_ERR_MSG);
			arg++;
			if (resultPtr == NULL) {
			    if (numberCachePtr != NULL) {
				Tcl_DeleteHashTable(numberCachePtr);
			    }
			    Tcl_DecrRefCount(valuePtr);	/* unneeded */
			    return TCL_ERROR;
			}
			offset += (count + 1) / 2;
			break;
		    }
		    case 'c': {
			size = 1;
			goto scanNumber;
		    }
		    case 's':
		    case 'S': {
			size = 2;
			goto scanNumber;
		    }
		    case 'i':
		    case 'I': {
			size = 4;
			goto scanNumber;
		    }
		    case 'w':
		    case 'W': {
			size = 8;
			goto scanNumber;
		    }
		    case 'f': {
			size = sizeof(float);
			goto scanNumber;
		    }
		    case 'd': {
			unsigned char *src;

			size = sizeof(double);
			/* fall through */
			
			scanNumber:
			if (arg >= objc) {
			    if (numberCachePtr != NULL) {
				Tcl_DeleteHashTable(numberCachePtr);
			    }
			    goto badIndex;
			}
			if (count == BINARY_NOCOUNT) {
			    if ((length - offset) < size) {
				goto done;
			    }
			    valuePtr = ScanNumber(buffer+offset, cmd,
				    &numberCachePtr);
			    offset += size;
			} else {
			    if (count == BINARY_ALL) {
				count = (length - offset) / size;
			    }
			    if ((length - offset) < (count * size)) {
				goto done;
			    }
			    valuePtr = Tcl_NewObj();
			    src = buffer+offset;
			    for (i = 0; i < count; i++) {
				elementPtr = ScanNumber(src, cmd,
					&numberCachePtr);
				src += size;
				Tcl_ListObjAppendElement(NULL, valuePtr,
					elementPtr);
			    }
			    offset += count*size;
			}

			resultPtr = Tcl_ObjSetVar2(interp, objv[arg],
				NULL, valuePtr, TCL_LEAVE_ERR_MSG);
			arg++;
			if (resultPtr == NULL) {
			    if (numberCachePtr != NULL) {
				Tcl_DeleteHashTable(numberCachePtr);
			    }
			    Tcl_DecrRefCount(valuePtr);	/* unneeded */
			    return TCL_ERROR;
			}
			break;
		    }
		    case 'x': {
			if (count == BINARY_NOCOUNT) {
			    count = 1;
			}
			if ((count == BINARY_ALL)
				|| (count > (length - offset))) {
			    offset = length;
			} else {
			    offset += count;
			}
			break;
		    }
		    case 'X': {
			if (count == BINARY_NOCOUNT) {
			    count = 1;
			}
			if ((count == BINARY_ALL) || (count > offset)) {
			    offset = 0;
			} else {
			    offset -= count;
			}
			break;
		    }
		    case '@': {
			if (count == BINARY_NOCOUNT) {
			    if (numberCachePtr != NULL) {
				Tcl_DeleteHashTable(numberCachePtr);
			    }
			    goto badCount;
			}
			if ((count == BINARY_ALL) || (count > length)) {
			    offset = length;
			} else {
			    offset = count;
			}
			break;
		    }
		    default: {
			if (numberCachePtr != NULL) {
			    Tcl_DeleteHashTable(numberCachePtr);
			}
			errorString = str;
			goto badfield;
		    }
		}
	    }

	    /*
	     * Set the result to the last position of the cursor.
	     */

	    done:
	    Tcl_ResetResult(interp);
	    Tcl_SetLongObj(Tcl_GetObjResult(interp), arg - 4);
	    if (numberCachePtr != NULL) {
		Tcl_DeleteHashTable(numberCachePtr);
	    }
	    break;
	}
    }
    return TCL_OK;

    badValue:
    Tcl_ResetResult(interp);
    Tcl_AppendStringsToObj(Tcl_GetObjResult(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;
}

/*
 *----------------------------------------------------------------------
 *
 * GetFormatSpec --
 *
 *	This function parses the format strings used in the binary
 *	format and scan commands.
 *
 * Results:
 *	Moves the formatPtr to the start of the next command. Returns
 *	the current command character and count in cmdPtr and countPtr.
 *	The count is set to BINARY_ALL if the count character was '*'
 *	or BINARY_NOCOUNT if no count was specified.  Returns 1 on
 *	success, or 0 if the string did not have a format specifier.
 *
 * Side effects:
 *	None.
 *
 *----------------------------------------------------------------------
 */

static int
GetFormatSpec(formatPtr, cmdPtr, countPtr)
    char **formatPtr;		/* Pointer to format string. */
    char *cmdPtr;		/* Pointer to location of command char. */
    int *countPtr;		/* Pointer to repeat count value. */
{
    /*
     * Skip any leading blanks.
     */

    while (**formatPtr == ' ') {
	(*formatPtr)++;
    }

    /*
     * The string was empty, except for whitespace, so fail.
     */

    if (!(**formatPtr)) {
	return 0;
    }

    /*
     * Extract the command character and any trailing digits or '*'.
     */

    *cmdPtr = **formatPtr;
    (*formatPtr)++;
    if (**formatPtr == '*') {
	(*formatPtr)++;
	(*countPtr) = BINARY_ALL;
    } else if (isdigit(UCHAR(**formatPtr))) { /* INTL: digit */
	(*countPtr) = strtoul(*formatPtr, formatPtr, 10);
    } else {
	(*countPtr) = BINARY_NOCOUNT;
    }
    return 1;
}

/*
 *----------------------------------------------------------------------
 *
 * FormatNumber --
 *
 *	This routine is called by Tcl_BinaryObjCmd to format a number
 *	into a location pointed at by cursor.
 *
 * Results:
 *	 A standard Tcl result.
 *
 * Side effects:
 *	Moves the cursor to the next location to be written into.
 *
 *----------------------------------------------------------------------
 */

static int
FormatNumber(interp, type, src, cursorPtr)
    Tcl_Interp *interp;		/* Current interpreter, used to report
				 * errors. */
    int type;			/* Type of number to format. */
    Tcl_Obj *src;		/* Number to format. */
    unsigned char **cursorPtr;	/* Pointer to index into destination buffer. */
{
    long value;
    double dvalue;
    Tcl_WideInt wvalue;

    switch (type) {
    case 'd':
    case 'f':
	/*
	 * For floating point types, we need to copy the data using
	 * memcpy to avoid alignment issues.
	 */

	if (Tcl_GetDoubleFromObj(interp, src, &dvalue) != TCL_OK) {
	    return TCL_ERROR;
	}
	if (type == 'd') {
	    memcpy((VOID *) *cursorPtr, (VOID *) &dvalue, sizeof(double));
	    *cursorPtr += sizeof(double);
	} else {
	    float fvalue;

	    /*
	     * Because some compilers will generate floating point exceptions
	     * on an overflow cast (e.g. Borland), we restrict the values
	     * to the valid range for float.
	     */

	    if (fabs(dvalue) > (double)FLT_MAX) {
		fvalue = (dvalue >= 0.0) ? FLT_MAX : -FLT_MAX;
	    } else {
		fvalue = (float) dvalue;
	    }
	    memcpy((VOID *) *cursorPtr, (VOID *) &fvalue, sizeof(float));
	    *cursorPtr += sizeof(float);
	}
	return TCL_OK;

	/*
	 * Next cases separate from other integer cases because we
	 * need a different API to get a wide.
	 */
    case 'w':
    case 'W':
	if (Tcl_GetWideIntFromObj(interp, src, &wvalue) != TCL_OK) {
	    return TCL_ERROR;
	}
	if (type == 'w') {
	    *(*cursorPtr)++ = (unsigned char) wvalue;
	    *(*cursorPtr)++ = (unsigned char) (wvalue >> 8);
	    *(*cursorPtr)++ = (unsigned char) (wvalue >> 16);
	    *(*cursorPtr)++ = (unsigned char) (wvalue >> 24);
	    *(*cursorPtr)++ = (unsigned char) (wvalue >> 32);
	    *(*cursorPtr)++ = (unsigned char) (wvalue >> 40);
	    *(*cursorPtr)++ = (unsigned char) (wvalue >> 48);
	    *(*cursorPtr)++ = (unsigned char) (wvalue >> 56);
	} else {
	    *(*cursorPtr)++ = (unsigned char) (wvalue >> 56);
	    *(*cursorPtr)++ = (unsigned char) (wvalue >> 48);
	    *(*cursorPtr)++ = (unsigned char) (wvalue >> 40);
	    *(*cursorPtr)++ = (unsigned char) (wvalue >> 32);
	    *(*cursorPtr)++ = (unsigned char) (wvalue >> 24);
	    *(*cursorPtr)++ = (unsigned char) (wvalue >> 16);
	    *(*cursorPtr)++ = (unsigned char) (wvalue >> 8);
	    *(*cursorPtr)++ = (unsigned char) wvalue;
	}
	return TCL_OK;
    default:
	if (Tcl_GetLongFromObj(interp, src, &value) != TCL_OK) {
	    return TCL_ERROR;
	}
	if (type == 'c') {
	    *(*cursorPtr)++ = (unsigned char) value;
	} else if (type == 's') {
	    *(*cursorPtr)++ = (unsigned char) value;
	    *(*cursorPtr)++ = (unsigned char) (value >> 8);
	} else if (type == 'S') {
	    *(*cursorPtr)++ = (unsigned char) (value >> 8);
	    *(*cursorPtr)++ = (unsigned char) value;
	} else if (type == 'i') {
	    *(*cursorPtr)++ = (unsigned char) value;
	    *(*cursorPtr)++ = (unsigned char) (value >> 8);
	    *(*cursorPtr)++ = (unsigned char) (value >> 16);
	    *(*cursorPtr)++ = (unsigned char) (value >> 24);
	} else if (type == 'I') {
	    *(*cursorPtr)++ = (unsigned char) (value >> 24);
	    *(*cursorPtr)++ = (unsigned char) (value >> 16);
	    *(*cursorPtr)++ = (unsigned char) (value >> 8);
	    *(*cursorPtr)++ = (unsigned char) value;
	}
	return TCL_OK;
    }
}

/*
 *----------------------------------------------------------------------
 *
 * ScanNumber --
 *
 *	This routine is called by Tcl_BinaryObjCmd to scan a number
 *	out of a buffer.
 *
 * Results:
 *	Returns a newly created object containing the scanned number.
 *	This object has a ref count of zero.
 *
 * Side effects:
 *	Might reuse an object in the number cache, place a new object
 *	in the cache, or delete the cache and set the reference to
 *	it (itself passed in by reference) to NULL.
 *
 *----------------------------------------------------------------------
 */

static Tcl_Obj *
ScanNumber(buffer, type, numberCachePtrPtr)
    unsigned char *buffer;	/* Buffer to scan number from. */
    int type;			/* Format character from "binary scan" */
    Tcl_HashTable **numberCachePtrPtr;
				/* Place to look for cache of scanned
				 * value objects, or NULL if too many
				 * different numbers have been scanned. */
{
    long value;
    Tcl_WideUInt uwvalue;

    /*
     * We cannot rely on the compiler to properly sign extend integer values
     * when we cast from smaller values to larger values because we don't know
     * the exact size of the integer types.  So, we have to handle sign
     * extension explicitly by checking the high bit and padding with 1's as
     * needed.
     */

    switch (type) {
	case 'c':
	    /*
	     * Characters need special handling.  We want to produce a
	     * signed result, but on some platforms (such as AIX) chars
	     * are unsigned.  To deal with this, check for a value that
	     * should be negative but isn't.
	     */

	    value = buffer[0];
	    if (value & 0x80) {
		value |= -0x100;
	    }
	    goto returnNumericObject;

	case 's':
	    value = (long) (buffer[0] + (buffer[1] << 8));
	    goto shortValue;
	case 'S':
	    value = (long) (buffer[1] + (buffer[0] << 8));
	    shortValue:
	    if (value & 0x8000) {
		value |= -0x10000;
	    }
	    goto returnNumericObject;

	case 'i':
	    value = (long) (buffer[0] 
		    + (buffer[1] << 8)
		    + (buffer[2] << 16)
		    + (buffer[3] << 24));
	    goto intValue;
	case 'I':
	    value = (long) (buffer[3]
		    + (buffer[2] << 8)
		    + (buffer[1] << 16)
		    + (buffer[0] << 24));
	    intValue:
	    /*
	     * Check to see if the value was sign extended properly on
	     * systems where an int is more than 32-bits.
	     */

	    if ((value & (((unsigned int)1)<<31)) && (value > 0)) {
		value -= (((unsigned int)1)<<31);
		value -= (((unsigned int)1)<<31);
	    }
	    returnNumericObject:
	    if (*numberCachePtrPtr == NULL) {
		return Tcl_NewLongObj(value);
	    } else {
		register Tcl_HashTable *tablePtr = *numberCachePtrPtr;
		register Tcl_HashEntry *hPtr;
		int isNew;

		hPtr = Tcl_CreateHashEntry(tablePtr, (char *)value, &isNew);
		if (!isNew) {
		    return (Tcl_Obj *) Tcl_GetHashValue(hPtr);
		}
		if (tablePtr->numEntries > BINARY_SCAN_MAX_CACHE) {
		    /*
		     * We've overflowed the cache!  Someone's parsing
		     * a LOT of varied binary data in a single call!
		     * Bail out by switching back to the old behaviour
		     * for the rest of the scan.
		     *
		     * Note that anyone just using the 'c' conversion
		     * (for bytes) cannot trigger this.
		     */
		    Tcl_DeleteHashTable(tablePtr);
		    *numberCachePtrPtr = NULL;
		    return Tcl_NewLongObj(value);
		} else {
		    register Tcl_Obj *objPtr = Tcl_NewLongObj(value);
		    /* Don't need to fiddle with refcount... */
		    Tcl_SetHashValue(hPtr, (ClientData) objPtr);
		    return objPtr;
		}
	    }
	case 'w':
	    uwvalue =  ((Tcl_WideUInt) buffer[0])
		    | (((Tcl_WideUInt) buffer[1]) << 8)
		    | (((Tcl_WideUInt) buffer[2]) << 16)
		    | (((Tcl_WideUInt) buffer[3]) << 24)
		    | (((Tcl_WideUInt) buffer[4]) << 32)
		    | (((Tcl_WideUInt) buffer[5]) << 40)
		    | (((Tcl_WideUInt) buffer[6]) << 48)
		    | (((Tcl_WideUInt) buffer[7]) << 56);
	    return Tcl_NewWideIntObj((Tcl_WideInt) uwvalue);
	case 'W':
	    uwvalue =  ((Tcl_WideUInt) buffer[7])
		    | (((Tcl_WideUInt) buffer[6]) << 8)
		    | (((Tcl_WideUInt) buffer[5]) << 16)
		    | (((Tcl_WideUInt) buffer[4]) << 24)
		    | (((Tcl_WideUInt) buffer[3]) << 32)
		    | (((Tcl_WideUInt) buffer[2]) << 40)
		    | (((Tcl_WideUInt) buffer[1]) << 48)
		    | (((Tcl_WideUInt) buffer[0]) << 56);
	    return Tcl_NewWideIntObj((Tcl_WideInt) uwvalue);
	case 'f': {
	    float fvalue;
	    memcpy((VOID *) &fvalue, (VOID *) buffer, sizeof(float));
	    return Tcl_NewDoubleObj(fvalue);
	}
	case 'd': {
	    double dvalue;
	    memcpy((VOID *) &dvalue, (VOID *) buffer, sizeof(double));
	    return Tcl_NewDoubleObj(dvalue);
	}
    }
    return NULL;
}