Attachment "binary.patch" to
ticket [429916ffff]
added by
hobbs
2001-06-04 08:13:47.
Index: generic/tclBinary.c
===================================================================
RCS file: /cvsroot/tcl/tcl/generic/tclBinary.c,v
retrieving revision 1.7
diff -b -c -r1.7 tclBinary.c
*** generic/tclBinary.c 2001/04/04 16:07:20 1.7
--- generic/tclBinary.c 2001/06/04 01:11:50
***************
*** 37,42 ****
--- 37,43 ----
static int GetFormatSpec _ANSI_ARGS_((char **formatPtr,
char *cmdPtr, int *countPtr));
static Tcl_Obj * ScanNumber _ANSI_ARGS_((unsigned char *buffer, int type));
+ static long ScanLong _ANSI_ARGS_((unsigned char *buffer, int type));
static int SetByteArrayFromAny _ANSI_ARGS_((Tcl_Interp *interp,
Tcl_Obj *objPtr));
static void UpdateStringOfByteArray _ANSI_ARGS_((Tcl_Obj *listPtr));
***************
*** 1199,1205 ****
--- 1200,1250 ----
}
valuePtr = ScanNumber(buffer+offset, cmd);
offset += size;
+ #if 1
+ } else if ((count == BINARY_ALL)
+ && (cmd != 'd') && (cmd != 'f')) {
+ Tcl_HashTable charReuseTable;
+ Tcl_HashEntry *hPtr;
+ int isNew;
+ long elementVal;
+
+ /*
+ * Handle the special case of splitting on every
+ * long value.
+ *
+ * Uses a hash table to ensure that each value has
+ * only one Tcl_Obj instance (multiply-referenced)
+ * in the final list. This is a *major* win when
+ * splitting on a long bytearray (especially in the
+ * megabyte range!) - DKF/MS
+ */
+
+ Tcl_InitHashTable(&charReuseTable,
+ TCL_ONE_WORD_KEYS);
+ count = (length - offset) / size;
+ valuePtr = Tcl_NewObj();
+ src = buffer+offset;
+ for (i = 0; i < count; i++) {
+ elementVal = ScanLong(src, cmd);
+ hPtr = Tcl_CreateHashEntry(&charReuseTable,
+ (char *) elementVal, &isNew);
+ if (isNew) {
+ /* Don't need to fiddle with refcount... */
+ elementPtr = Tcl_NewLongObj(elementVal);
+ Tcl_SetHashValue(hPtr,
+ (ClientData) elementPtr);
} else {
+ elementPtr =
+ (Tcl_Obj*) Tcl_GetHashValue(hPtr);
+ }
+ src += size;
+ Tcl_ListObjAppendElement(NULL, valuePtr,
+ elementPtr);
+ }
+ Tcl_DeleteHashTable(&charReuseTable);
+ offset += count*size;
+ #endif
+ } else {
if (count == BINARY_ALL) {
count = (length - offset) / size;
}
***************
*** 1548,1551 ****
--- 1593,1686 ----
}
}
return NULL;
+ }
+
+ /*
+ *----------------------------------------------------------------------
+ *
+ * ScanNumber --
+ *
+ * This routine is called by Tcl_BinaryObjCmd to scan a number
+ * out of a buffer.
+ *
+ * Results:
+ * Returns a long representing the scanned number.
+ *
+ * Side effects:
+ * None.
+ *
+ *----------------------------------------------------------------------
+ */
+
+ static long
+ ScanLong(buffer, type)
+ unsigned char *buffer; /* Buffer to scan number from. */
+ int type; /* Format character from "binary scan" */
+ {
+ long value;
+
+ /*
+ * 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;
+ }
+ return (long) value;
+ }
+ 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;
+ }
+ return (long) value;
+ }
+ 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);
+ }
+ return (long) value;
+ }
+ default: {
+ panic("binary scan: uncaught bad format string\n");
+ return 0;
+ }
+ }
}
