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