Exemplo n.º 1
0
static int DBus_EventHandler(Tcl_Event *evPtr, int flags)
{
   Tcl_DBusEvent *ev;
   DBusMessageIter iter;
   Tcl_Obj *script, *result;
   int rc;

   if (!(flags & TCL_IDLE_EVENTS)) return 0;
   ev = (Tcl_DBusEvent *) evPtr;
   script = ev->script;
   if (Tcl_IsShared(script))
     script = Tcl_DuplicateObj(script);
   Tcl_ListObjAppendElement(ev->interp, script, 
			    DBus_MessageInfo(ev->interp, ev->msg));
   /* read the parameters and append to the script */
   if (dbus_message_iter_init(ev->msg, &iter)) {
      Tcl_ListObjAppendList(ev->interp, script,
	DBus_IterList(ev->interp, &iter, (ev->flags & DBUSFLAG_DETAILS) != 0));
   }
   /* Excute the constructed Tcl command */
   rc = Tcl_EvalObjEx(ev->interp, script, TCL_EVAL_GLOBAL);
   if (rc != TCL_ERROR) {
      /* Report success only if noreply == 0 and async == 0 */
      if (!(ev->flags & DBUSFLAG_NOREPLY) && !(ev->flags & DBUSFLAG_ASYNC)) {
         /* read the parameters and append to the script */;
	 result = Tcl_GetObjResult(ev->interp);
	 DBus_SendMessage(ev->interp, ev->conn,
			  DBUS_MESSAGE_TYPE_METHOD_RETURN, NULL, NULL, NULL,
			  dbus_message_get_sender(ev->msg),
			  dbus_message_get_serial(ev->msg),
			  NULL, 1, &result);
      }
   } else {
      /* Always report failures if noreply == 0 */
      if (!(ev->flags & DBUSFLAG_NOREPLY)) {
	 result = Tcl_GetObjResult(ev->interp);
	 DBus_Error(ev->interp, ev->conn, NULL,
		    dbus_message_get_sender(ev->msg),
		    dbus_message_get_serial(ev->msg),
		    Tcl_GetString(result));
      }
   }
   dbus_message_unref(ev->msg);
   Tcl_DecrRefCount(ev->script);
   /* The event structure will be cleaned up by Tcl_ServiceEvent */
   return 1;
}
Exemplo n.º 2
0
int
Tk_SendObjCmd(
    ClientData clientData,	/* Used only for deletion */
    Tcl_Interp *interp,		/* The interp we are sending from */
    int objc,			/* Number of arguments */
    Tcl_Obj *const objv[])	/* The arguments */
{
    const char *const sendOptions[] = {"-async", "-displayof", "-", NULL};
    char *stringRep, *destName;
    /*int async = 0;*/
    int i, index, firstArg;
    RegisteredInterp *riPtr;
    Tcl_Obj *listObjPtr;
    int result = TCL_OK;

    for (i = 1; i < (objc - 1); ) {
	stringRep = Tcl_GetString(objv[i]);
	if (stringRep[0] == '-') {
	    if (Tcl_GetIndexFromObj(interp, objv[i], sendOptions, "option", 0,
		    &index) != TCL_OK) {
		return TCL_ERROR;
	    }
	    if (index == 0) {
		/*async = 1;*/
		i++;
	    } else if (index == 1) {
		i += 2;
	    } else {
		i++;
	    }
	} else {
	    break;
	}
    }

    if (objc < (i + 2)) {
	Tcl_WrongNumArgs(interp, 1, objv,
		"?-option value ...? interpName arg ?arg ...?");
	return TCL_ERROR;
    }

    destName = Tcl_GetString(objv[i]);
    firstArg = i + 1;

    /*
     * See if the target interpreter is local. If so, execute the command
     * directly without going through the DDE server. The only tricky thing is
     * passing the result from the target interpreter to the invoking
     * interpreter. Watch out: they could be the same!
     */

    for (riPtr = interpListPtr; (riPtr != NULL)
	    && (strcmp(destName, riPtr->name)); riPtr = riPtr->nextPtr) {
	/*
	 * Empty loop body.
	 */
    }

    if (riPtr != NULL) {
	/*
	 * This command is to a local interp. No need to go through the
	 * server.
	 */

	Tcl_Interp *localInterp;

	Tcl_Preserve(riPtr);
	localInterp = riPtr->interp;
	Tcl_Preserve(localInterp);
	if (firstArg == (objc - 1)) {
	    /*
	     * This might be one of those cases where the new parser is
	     * faster.
	     */

	    result = Tcl_EvalObjEx(localInterp, objv[firstArg],
		    TCL_EVAL_DIRECT);
	} else {
	    listObjPtr = Tcl_NewListObj(0, NULL);
	    for (i = firstArg; i < objc; i++) {
		Tcl_ListObjAppendList(interp, listObjPtr, objv[i]);
	    }
	    Tcl_IncrRefCount(listObjPtr);
	    result = Tcl_EvalObjEx(localInterp, listObjPtr, TCL_EVAL_DIRECT);
	    Tcl_DecrRefCount(listObjPtr);
	}
	if (interp != localInterp) {
	    if (result == TCL_ERROR) {
		/* Tcl_Obj *errorObjPtr; */

		/*
		 * An error occurred, so transfer error information from the
		 * destination interpreter back to our interpreter. Must clear
		 * interp's result before calling Tcl_AddErrorInfo, since
		 * Tcl_AddErrorInfo will store the interp's result in
		 * errorInfo before appending riPtr's $errorInfo; we've
		 * already got everything we need in riPtr's $errorInfo.
		 */

		Tcl_ResetResult(interp);
		Tcl_AddErrorInfo(interp, Tcl_GetVar2(localInterp,
			"errorInfo", NULL, TCL_GLOBAL_ONLY));
		/* errorObjPtr = Tcl_GetObjVar2(localInterp, "errorCode", NULL,
			TCL_GLOBAL_ONLY);
		Tcl_SetObjErrorCode(interp, errorObjPtr); */
	    }
	    Tcl_SetObjResult(interp, Tcl_GetObjResult(localInterp));
	}
	Tcl_Release(riPtr);
	Tcl_Release(localInterp);
    } else {
	/*
	 * TODO: This is a non-local request. Send the script to the server
	 * and poll it for a result.
	 */
    }

    return result;
}
Exemplo n.º 3
0
int DBusUnknownCmd(ClientData dummy, Tcl_Interp *interp,
	int objc, Tcl_Obj *const objv[])
{
   Tcl_DBusBus *dbus = defaultbus;
   Tcl_DBusHandlerData *data;
   Tcl_DBusMethodData *method;
   Tcl_HashEntry *memberPtr;
   int x = 1, isNew, flags, index;
   char c, *path = NULL;
   Tcl_Obj *handler = NULL, *result;
   static const char *options[] = {"-details", NULL};
   enum options {DBUS_DETAILS};

   if (objc > 1) {
      c = Tcl_GetString(objv[1])[0];
      /* Options start with '-', path starts with '/' or is "" */
      /* Anything else has to be a busId specification */
      if (c != '/' && c != '-' && c != '\0') {
	 if (DBus_BusType(interp, objv[1]) < 0) return TCL_ERROR;
	 dbus = DBus_GetConnection(interp, objv[1]);
	 x++;
      }
   }

   /* Unknown handlers are always async */
   flags = DBUSFLAG_ASYNC;

   for (; x < objc; x++) {
      c = Tcl_GetString(objv[x])[0];
      if (c != '-') break;
      if (Tcl_GetIndexFromObj(interp, objv[x], options, "option", 0,
			      &index) != TCL_OK) {
	 return TCL_ERROR;
      }
      switch ((enum options) index) {
       case DBUS_DETAILS:
	 flags |= DBUSFLAG_DETAILS;
	 break;
      }
   }
	 
   if (x < objc) {
      c = Tcl_GetString(objv[x])[0];
      if (c != '\0' && !DBus_CheckPath(objv[x])) {
	 Tcl_SetObjResult(interp, Tcl_NewStringObj("Invalid path", -1));
	 return TCL_ERROR;
      }
      path = Tcl_GetString(objv[x++]);
   }
   if (x < objc) {
      handler = objv[x++];
   }
   
   if (x != objc) {
      Tcl_WrongNumArgs(interp, 1, objv, "?busId? ?options? ?path ?script??");
      return TCL_ERROR;
   }

   if (dbus == NULL) {
      Tcl_SetObjResult(interp, Tcl_NewStringObj("Not connected", -1));
      return TCL_ERROR;
   }

   if (handler == NULL) {
      /* Request for a report on currently registered handler(s) */
      if (path == NULL) {
	 /* Get all handlers for any path */
	 result = DBus_ListListeners(interp, dbus, "", 
				     DBUS_METHODFLAG | DBUS_UNKNOWNFLAG);
	 /* append all currently registered handlers from the root path */
	 Tcl_ListObjAppendList(NULL, result,
		DBus_ListListeners(interp, dbus, "/", 
		   DBUS_METHODFLAG | DBUS_UNKNOWNFLAG | DBUS_RECURSEFLAG));
	 Tcl_SetObjResult(interp, result);
	 return TCL_OK;
      }
      method = DBus_FindListeners(dbus, path, "", TRUE);
      if (method != NULL && method->interp == interp) {
	 /* Return the script configured for the handler */
	 Tcl_IncrRefCount(method->script);
	 Tcl_SetObjResult(interp, method->script);
      }
      return TCL_OK;
   }
   
   if (Tcl_GetCharLength(handler) == 0) {
      /* Unregistering a handler */
      if (*path != '\0') {
	 if (!dbus_connection_get_object_path_data(dbus->conn, path,
						      (void **)&data))
	   return DBus_MemoryError(interp);
      }
      else {
	 data = dbus->fallback;
      }
      if (data == NULL) return TCL_OK;
      if (data->method == NULL) return TCL_OK;
      memberPtr = Tcl_FindHashEntry(data->method, "");
      if (memberPtr == NULL) return TCL_OK;
      method = Tcl_GetHashValue(memberPtr);
      Tcl_DecrRefCount(method->script);
      ckfree((char *) method);
      Tcl_DeleteHashEntry(memberPtr);
      /* Clean up the message handler, if no longer used */
      if (Tcl_CheckHashEmpty(data->method)) {
	 Tcl_DeleteHashTable(data->method);
	 ckfree((char *) data->method);
	 data->method = NULL;
	 if (data->signal == NULL && !(data->flags & DBUSFLAG_FALLBACK)) {
	    ckfree((char *) data);
	    if (*path != '\0')
	      dbus_connection_unregister_object_path(dbus->conn, path);
	    else
	      dbus->fallback = NULL;
	 }
      }
      return TCL_OK;
   }
   
   /* Register the new handler */
   data = DBus_GetMessageHandler(interp, dbus, path);
   if (data->method == NULL) {
      /* No methods have been defined for this path by any interpreter yet
         So first a hash table indexed by interpreter must be created */
      data->method = (Tcl_HashTable *) ckalloc(sizeof(Tcl_HashTable));
      Tcl_InitHashTable(data->method, TCL_STRING_KEYS);
   }
   memberPtr = Tcl_CreateHashEntry(data->method, "", &isNew);
   if (isNew) {
      method = (Tcl_DBusMethodData *) ckalloc(sizeof(Tcl_DBusMethodData));
      method->interp = interp;
      method->conn = dbus->conn;
      Tcl_SetHashValue(memberPtr, method);
   } else {
      method = Tcl_GetHashValue(memberPtr);
      if(method->interp == interp) {
	 /* Release the old script */
	 Tcl_DecrRefCount(method->script);
      } else {
	 /* Method was registered by another interpreter */
	 Tcl_SetObjResult(interp, Tcl_NewStringObj("unknown handler is defined "
						   "by another interpreter", -1));
	 return TCL_ERROR;
      }
   }
   method->script = handler;
   method->flags = flags;
   Tcl_IncrRefCount(handler);
   return TCL_OK;
}
Exemplo n.º 4
0
int DBusListenCmd(ClientData dummy, Tcl_Interp *interp,
	int objc, Tcl_Obj *const objv[])
{
   Tcl_DBusBus *dbus = defaultbus;
   Tcl_DBusHandlerData *data;
   Tcl_DBusSignalData *signal;
   Tcl_HashTable *interps;
   Tcl_HashEntry *memberPtr, *interpPtr;
   int x = 1, flags = 0, index, isNew;
   char c, *path = NULL;
   Tcl_Obj *name = NULL, *handler = NULL, *result;
   static const char *options[] = {"-details", NULL};
   enum options {DBUS_DETAILS};

   if (objc > 1) {
      c = Tcl_GetString(objv[1])[0];
      /* Options start with '-', path starts with '/' or is "" */
      /* Anything else has to be a busId specification */
      if (c != '/' && c != '-' && c != '\0') {
	 if (DBus_BusType(interp, objv[1]) < 0) return TCL_ERROR;
	 dbus = DBus_GetConnection(interp, objv[1]);
	 x++;
      }
   }

   for (; x < objc; x++) {
      c = Tcl_GetString(objv[x])[0];
      if (c != '-') break;
      if (Tcl_GetIndexFromObj(interp, objv[x], options, "option", 0,
			      &index) != TCL_OK) {
	 return TCL_ERROR;
      }
      switch ((enum options) index) {
       case DBUS_DETAILS:
	 flags |= DBUSFLAG_DETAILS;
	 break;
      }
   }

   if (x < objc) {
      if (Tcl_GetCharLength(objv[x]) > 0 && !DBus_CheckPath(objv[x])) {
	 Tcl_SetObjResult(interp, Tcl_NewStringObj("Invalid path", -1));
	 return TCL_ERROR;
      }
      path = Tcl_GetString(objv[x++]);
   }
   if (x < objc) {
      if (!DBus_CheckMember(objv[x]) && DBus_CheckIntfName(objv[x]) < 2) {
	 Tcl_SetObjResult(interp, Tcl_NewStringObj("Invalid signal name", -1));
	 return TCL_ERROR;
      }
      name = objv[x++];
   }
   if (x < objc) {
      handler = objv[x++];
   }
   
   if (x != objc) {
      Tcl_WrongNumArgs(interp, 1, objv, "?busId? ?options? "
		       "?path ?signal ?script???");
      return TCL_ERROR;
   }

   if (dbus == NULL) {
      Tcl_SetObjResult(interp, Tcl_NewStringObj("Not connected", -1));
      return TCL_ERROR;
   }

   if (handler == NULL) {
      /* Request for a report on currently registered handler(s) */
      if (path == NULL) {
	 /* Get all handlers for any path */
	 result = DBus_ListListeners(interp, dbus, "", 0);
	 /* Append the registered handlers from the root path */
	 Tcl_ListObjAppendList(NULL, result,
		DBus_ListListeners(interp, dbus, "/", DBUS_RECURSEFLAG));
	 Tcl_SetObjResult(interp, result);
	 return TCL_OK;
      }
      if (name == NULL) {
	 /* Report all currently registered handlers at the specified path */
	 Tcl_SetObjResult(interp,
		DBus_ListListeners(interp, dbus, path, 0));
	 return TCL_OK;
      }
      interps = DBus_FindListeners(dbus, path, Tcl_GetString(name), FALSE);
      if (interps != NULL) {
	 /* Check if a signal handler was registered by the current interp */
	 memberPtr = Tcl_FindHashEntry(interps, (char * ) interp);
	 if (memberPtr != NULL) {
	    /* Return the script configured for the handler */
	    signal = Tcl_GetHashValue(memberPtr);
	    Tcl_IncrRefCount(signal->script);
	    Tcl_SetObjResult(interp, signal->script);
	 }
      }
      return TCL_OK;
   }
   
   if (Tcl_GetCharLength(handler) == 0) {
      /* Unregistering a handler */
      if (*path != '\0') {
	 if (!dbus_connection_get_object_path_data(dbus->conn, path,
						      (void **)&data))
	   return DBus_MemoryError(interp);
      }
      else {
	 data = dbus->fallback;
      }
      if (data == NULL) return TCL_OK;
      if (data->signal == NULL) return TCL_OK;
      memberPtr = Tcl_FindHashEntry(data->signal, Tcl_GetString(name));
      if (memberPtr == NULL) return TCL_OK;
      interps = Tcl_GetHashValue(memberPtr);
      interpPtr = Tcl_FindHashEntry(interps, (char *) interp);
      if (interpPtr == NULL) return TCL_OK;
      signal = Tcl_GetHashValue(interpPtr);
      Tcl_DecrRefCount(signal->script);
      ckfree((char *) signal);
      Tcl_DeleteHashEntry(interpPtr);
      /* Clean up the message handler, if no longer used */
      if (Tcl_CheckHashEmpty(interps)) {
	 Tcl_DeleteHashTable(interps);
	 ckfree((char *) interps);
	 Tcl_DeleteHashEntry(memberPtr);
	 if (Tcl_CheckHashEmpty(data->signal)) {
	    Tcl_DeleteHashTable(data->signal);
	    ckfree((char *) data->signal);
	    data->signal = NULL;
	    if (data->method == NULL && !(data->flags & DBUSFLAG_FALLBACK)) {
	       ckfree((char *) data);
	       if (*path != '\0')
		 dbus_connection_unregister_object_path(dbus->conn, path);
	       else
		 dbus->fallback = NULL;
	    }
	 }
      }
      return TCL_OK;
   }
   
   /* Register the new handler */
   data = DBus_GetMessageHandler(interp, dbus, path);
   if (data->signal == NULL) {
      /* No signals have been defined for this path by any interpreter yet
         So first a hash table indexed by interpreter must be created */
      data->signal = (Tcl_HashTable *) ckalloc(sizeof(Tcl_HashTable));
      Tcl_InitHashTable(data->signal, TCL_STRING_KEYS);
   }
   memberPtr = Tcl_CreateHashEntry(data->signal, Tcl_GetString(name), &isNew);
   if (isNew) {
      interps = (Tcl_HashTable *) ckalloc(sizeof(Tcl_HashTable));
      Tcl_InitHashTable(interps, TCL_ONE_WORD_KEYS);
      Tcl_SetHashValue(memberPtr, (ClientData) interps);
   } else {
      interps = Tcl_GetHashValue(memberPtr);
   }
   /* Find the entry for the current interpreter */
   memberPtr = Tcl_CreateHashEntry(interps, (char *) interp, &isNew);
   if (isNew) {
      signal = (Tcl_DBusSignalData *) ckalloc(sizeof(Tcl_DBusSignalData));
      Tcl_SetHashValue(memberPtr, signal);
   } else {
      /* Release the old script */
      signal = Tcl_GetHashValue(memberPtr);
      Tcl_DecrRefCount(signal->script);
   }
   signal->script = handler;
   signal->flags = flags;
   Tcl_IncrRefCount(handler);
   return TCL_OK;
}
Exemplo n.º 5
0
static Tcl_Obj *DBus_ListListeners(Tcl_Interp *interp,
	Tcl_DBusBus *dbus, const char *path, int flags)
{
   Tcl_Obj *list, *sublist;
   char **entries, **entry, *newpath, *pathentry, *s;
   Tcl_DBusHandlerData *data;
   Tcl_DBusSignalData *signal;
   Tcl_DBusMethodData *method;
   Tcl_HashTable *interps;
   Tcl_HashEntry *memberPtr, *interpPtr;
   Tcl_HashSearch search;

   list = Tcl_NewObj();
   
   /* Check if the specified path has a handler defined */
   if (*path == '\0')
     data = dbus->fallback;
   else
     dbus_connection_get_object_path_data(dbus->conn, path, (void **)&data);
   if (data != NULL) {
      if ((flags & DBUS_METHODFLAG) == 0 && data->signal != NULL) {
	 for (memberPtr = Tcl_FirstHashEntry(data->signal, &search);
	      memberPtr != NULL; memberPtr = Tcl_NextHashEntry(&search)) {
	    interps = Tcl_GetHashValue(memberPtr);
	    interpPtr = Tcl_FindHashEntry(interps, (char *) interp);
	    if (interpPtr != NULL) {
	       signal = Tcl_GetHashValue(interpPtr);
	       /* Report both the path and the script configured for the path */
	       Tcl_ListObjAppendElement(NULL, list, Tcl_NewStringObj(path, -1));
	       s = Tcl_GetHashKey(data->signal, memberPtr);
	       Tcl_ListObjAppendElement(NULL, list, Tcl_NewStringObj(s, -1));
	       Tcl_ListObjAppendElement(NULL, list, signal->script);
	    }
	 }
      } else if ((flags & DBUS_METHODFLAG) != 0 && data->method != NULL) {
	 for (memberPtr = Tcl_FirstHashEntry(data->method, &search);
	      memberPtr != NULL; memberPtr = Tcl_NextHashEntry(&search)) {
	    method = Tcl_GetHashValue(memberPtr);
	    if (method->interp == interp) {
	       s = Tcl_GetHashKey(data->method, memberPtr);
	       /* Normally skip unknown handlers. But when listing */
	       /* unknown handlers, skip all named handlers. */
	       if (!(flags & DBUS_UNKNOWNFLAG) == (*s == '\0')) continue;
	       /* Report both the path and the script configured for the path */
	       Tcl_ListObjAppendElement(NULL, list, Tcl_NewStringObj(path, -1));
	       /* There is no method name for unknown handlers */
	       if (!(flags & DBUS_UNKNOWNFLAG))
		  Tcl_ListObjAppendElement(NULL, list, Tcl_NewStringObj(s, -1));
	       Tcl_ListObjAppendElement(NULL, list, method->script);
	    }
	 }
      }
   }
   if (flags & DBUS_RECURSEFLAG) {
      /* Get a list of children of the current path */
      dbus_connection_list_registered(dbus->conn, path, &entries);
      /* Allocate space for concatenating the path and a childs name */
      newpath = ckalloc(strlen(path) + 256);
      /* Copy the path in the allocated space, making sure it ends with a / */
      strcpy(newpath, path);
      pathentry = newpath + strlen(path) - 1;
      if (*pathentry++ != '/') *pathentry++ = '/';
      /* Append each childs name to the path in turn */
      for (entry = entries; *entry != NULL; entry++) {
	 strncpy(pathentry, *entry, 255);
	 /* Get a list of descendents from the child */
	 sublist = DBus_ListListeners(interp, dbus, newpath, flags);
	 /* Append the sublist entries to the total list */
	 Tcl_ListObjAppendList(NULL, list, sublist);
	 /* Release the temporary sublist */
	 Tcl_DecrRefCount(sublist);
      }
      /* Release the entries array */
      dbus_free_string_array(entries);
      ckfree(newpath);
   }
   return list;
}
Exemplo n.º 6
0
int
rt_binunif_tcladjust( Tcl_Interp *interp, struct rt_db_internal *intern, int argc, char **argv )
{
    struct rt_binunif_internal *bip;
    int i;

    RT_CK_DB_INTERNAL( intern );
    bip = (struct rt_binunif_internal *)intern->idb_ptr;
    RT_CHECK_BINUNIF( bip );

    while ( argc >= 2 ) {
	if ( !strcmp( argv[0], "T" ) ) {
	    int new_type=-1;
	    char *c;
	    int type_is_digit=1;

	    c = argv[1];
	    while ( *c != '\0' ) {
		if ( !isdigit( *c ) ) {
		    type_is_digit = 0;
		    break;
		}
		c++;
	    }

	    if ( type_is_digit ) {
		new_type = atoi( argv[1] );
	    } else {
		if ( argv[1][1] != '\0' ) {
		    Tcl_AppendResult( interp, "Illegal type: ",
				      argv[1],
				      ", must be 'f', 'd', 'c', 'i', 'l', 'C', 'S', 'I', or 'L'",
				      (char *)NULL );
		    return TCL_ERROR;
		}
		switch ( argv[1][0] ) {
		    case 'f':
			new_type = 2;
			break;
		    case 'd':
			new_type = 3;
			break;
		    case 'c':
			new_type = 4;
			break;
		    case 's':
			new_type = 5;
			break;
		    case 'i':
			new_type = 6;
			break;
		    case 'l':
			new_type = 7;
			break;
		    case 'C':
			new_type = 12;
			break;
		    case 'S':
			new_type = 13;
			break;
		    case 'I':
			new_type = 14;
			break;
		    case 'L':
			new_type = 15;
			break;
		}
	    }
	    if ( new_type < 0 ||
		 new_type > DB5_MINORTYPE_BINU_64BITINT ||
		 binu_types[new_type] == NULL ) {
		/* Illegal value for type */
		Tcl_AppendResult( interp, "Illegal value for binary type: ", argv[1],
				  (char *)NULL );
		return TCL_ERROR;
	    } else {
		if ( bip->u.uint8 ) {
		    int new_count;
		    int old_byte_count, new_byte_count;
		    int remainder;

		    old_byte_count = bip->count * binu_sizes[bip->type];
		    new_count = old_byte_count / binu_sizes[new_type];
		    remainder = old_byte_count % binu_sizes[new_type];
		    if ( remainder ) {
			new_count++;
			new_byte_count = new_count * binu_sizes[new_type];
		    } else {
			new_byte_count = old_byte_count;
		    }

		    if ( new_byte_count != old_byte_count ) {
			bip->u.uint8 = bu_realloc( bip->u.uint8,
						   new_byte_count,
						   "new bytes for binunif" );
			/* zero out the new bytes */
			for ( i=old_byte_count; i<new_byte_count; i++ ) {
			    bip->u.uint8[i] = 0;
			}
		    }
		    bip->count = new_count;
		}
		bip->type = new_type;
		intern->idb_type = new_type;
	    }
	} else if ( !strcmp( argv[0], "D" ) ) {
	    Tcl_Obj *obj, *list, **obj_array;
	    int list_len;
	    unsigned char *buf, *d;
	    char *s;
	    int hexlen;
	    unsigned int h;

	    obj = Tcl_NewStringObj( argv[1], -1 );
	    list = Tcl_NewListObj( 0, NULL );
	    Tcl_ListObjAppendList( interp, list, obj );
	    (void)Tcl_ListObjGetElements( interp, list, &list_len, &obj_array );

	    hexlen = 0;
	    for ( i=0; i<list_len; i++ ) {
		hexlen += Tcl_GetCharLength( obj_array[i] );
	    }

	    if ( hexlen % 2 ) {
		Tcl_AppendResult( interp,
				  "Hex form of binary data must have an even number of hex digits",
				  (char *)NULL );
		return TCL_ERROR;
	    }

	    buf = (unsigned char *)bu_malloc( hexlen / 2, "tcladjust binary data" );
	    d = buf;
	    for ( i=0; i<list_len; i++ ) {
		s = Tcl_GetString( obj_array[i] );
		while ( *s ) {
		    sscanf( s, "%2x", &h );
		    *d++ = h;
		    s += 2;
		}
	    }
	    Tcl_DecrRefCount( list );

	    if ( bip->u.uint8 ) {
		bu_free( bip->u.uint8, "binary data" );
	    }
	    bip->u.uint8 = buf;
	    bip->count = hexlen / 2 / binu_sizes[bip->type];
	}

	argc -= 2;
	argv += 2;
    }

    return TCL_OK;
}