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