/* Return the number of times the regular expression "regexp_cstr" * uniquely matches against the input string "s". */ static unsigned long regcount(const char* regexp_cstr, Tcl_Obj* s) { int regexec_rv = 0; int index = 0; int index_max = 0; unsigned long rv = 0; Tcl_Obj* regexp_cstr_obj = NULL; Tcl_RegExp regexp = NULL; struct Tcl_RegExpInfo info = {0}; /* Get "regexp_cstr" as a Tcl string object. */ regexp_cstr_obj = Tcl_NewStringObj(regexp_cstr, strlen(regexp_cstr)); Tcl_IncrRefCount(regexp_cstr_obj); /* Compile the regular expression. */ regexp = Tcl_GetRegExpFromObj(NULL, regexp_cstr_obj, TCL_REG_ADVANCED | TCL_REG_NOCASE | TCL_REG_NEWLINE); if (!regexp) { fprintf(stderr, "*** Error: Tcl_GetRegExpFromObj: failed"); exit(1); } /* Iterate over each match. */ index = 0; index_max = Tcl_GetCharLength(s); while (index < index_max) { /* Test for a match. */ regexec_rv = Tcl_RegExpExecObj(NULL, regexp, s, index, 1, 0); if (regexec_rv == -1) { fprintf(stderr, "*** Error: Tcl_RegExpExecObj: failed"); exit(1); } if (regexec_rv == 0) { /* No matches. */ break; } /* Get the match information. */ Tcl_RegExpGetInfo(regexp, &info); /* Advance curr. */ index += info.matches[0].end; /* Increment the match count. */ ++rv; } /* Clean up. Note that "regexp" is owned by "regexp_cstr_obj" so * it does not need explicit clean up. */ Tcl_DecrRefCount(regexp_cstr_obj); return rv; }
int main(int argc, char* argv[]) { int rv = 0; int cpu_count = 0; int init_length = 0; int code_length = 0; int seq_length = 0; char* s_cstr = NULL; Tcl_Interp *tcl = NULL; Tcl_Obj* s = NULL; /* Initialize Tcl. */ Tcl_FindExecutable(argv[0]); tcl = Tcl_CreateInterp(); Tcl_Preserve((ClientData)tcl); /* Count the number of cpus. If the cpu count could not be * determined, assume 4 cpus. */ cpu_count = get_cpu_count(); if (!cpu_count) { cpu_count = 4; } /* Allocate s. */ s = Tcl_NewStringObj("", 0); Tcl_IncrRefCount(s); /* Load stdin into s. */ load_file(stdin, s); /* Get the length of s. */ init_length = Tcl_GetCharLength(s); /* Strip off section headers and EOLs from s. This is a little * messy because we have to go from Tcl-string to C-string and * back to Tcl-string. */ s_cstr = regsub("(>.*)|\n", Tcl_GetString(s), "", NULL); Tcl_SetStringObj(s, s_cstr, strlen(s_cstr)); g_free(s_cstr); s_cstr = NULL; /* Get the length of s. */ code_length = Tcl_GetCharLength(s); /* Process the variants by counting them and printing the results. */ process_variants(cpu_count, s); /* Substitute nucleic acid codes in s with their meanings. */ process_nacodes(cpu_count, s); /* Get the length of s. */ seq_length = Tcl_GetCharLength(s); /* Print the lengths. */ printf("\n%d\n%d\n%d\n", init_length, code_length, seq_length); /* Clean up. */ Tcl_DecrRefCount(s); /* Finalize Tcl. */ Tcl_Release((ClientData)tcl); Tcl_Exit(rv); /* Not reached. */ return rv; }
/* Process the nucleic acid codes by substituting each nucleic acid * code in "s" with its meaning as defined in the static "nacodes" * structure (see top of file). On return, "s" will hold the * substituted string. */ static void process_nacodes(int cpu_count, Tcl_Obj* s) { int i = 0; int first = 0; int last = 0; int s_length = 0; int range_length = 0; int thread_rv = 0; nacodes_worker_data_t data = NULL; pthread_t* threads = NULL; /* Sanity check to make sure we don't divide by zero. */ if (cpu_count == 0) { return; } /* Get the total length of s. */ s_length = Tcl_GetCharLength(s); if (s_length == 0) { return; } /* Allocate the "data" array which is used to pass data to and * from the threads. */ data = calloc(cpu_count, sizeof(*data)); /* Allocate the "threads" array which holds the thread IDs. */ threads = calloc(cpu_count, sizeof(*threads)); /* Calculate the number of characters to feed each thread. Note * that we checked above to make sure cpu_count is not zero. */ range_length = s_length / cpu_count; /* Start one thread for each cpu. */ for (i = 0 ; i < cpu_count ; ++i) { /* First, initialize the thread's client data. */ /* Calculate the first and last index for the range. Both * "first" and "last" indexes are inclusive because that is * what Tcl_GetRange() requires. We also need to make sure * the very last range has all the characters in case * range_length does not divide s_length evenly. */ first = range_length * i; last = range_length * (i + 1) - 1; if (i + 1 == cpu_count) { last = s_length - 1; } /* Pack the data for the worker thread. */ data[i].range = Tcl_GetRange(s, first, last); Tcl_IncrRefCount(data[i].range); /* Second, start the thread. */ thread_rv = pthread_create(&threads[i], NULL, (thread_start_t)process_nacodes_worker, &data[i]); if (thread_rv) { fprintf(stderr, "*** Error: pthread_create: failed"); exit(1); } } /* Wait for each thread to finish. */ for (i = 0 ; i < cpu_count ; ++i) { thread_rv = pthread_join(threads[i], NULL); if (thread_rv) { fprintf(stderr, "*** Error: pthread_join: failed"); exit(1); } } /* Merge results. */ Tcl_SetObjLength(s, 0); for (i = 0 ; i < cpu_count ; ++i) { Tcl_AppendObjToObj(s, data[i].range); } /* Clean up. */ for (i = 0 ; i < cpu_count ; ++i) { Tcl_DecrRefCount(data[i].range); } free(threads); free(data); }
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; }
int DBusMonitorCmd(ClientData dummy, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]) { Tcl_DBusBus *dbus = defaultbus; Tcl_DBusMonitorData *snoop; Tcl_HashEntry *memberPtr; Tcl_Obj *handler; int x = 1, flags = 0, index; char c; static const char *options[] = {"-details", NULL}; enum options {DBUS_DETAILS}; if (objc > 2) { c = Tcl_GetString(objv[1])[0]; /* If the arg doesn't start with '-', it must be a busId specification */ if (c != '-') { if (DBus_BusType(interp, objv[1]) < 0) return TCL_ERROR; dbus = DBus_GetConnection(interp, objv[1]); x++; } } for (; x < objc - 1; 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 (objc != x + 1) { Tcl_WrongNumArgs(interp, 1, objv, "?busId? script"); return TCL_ERROR; } handler = objv[x]; if (dbus == NULL) { Tcl_SetObjResult(interp, Tcl_NewStringObj("Not connected", -1)); return TCL_ERROR; } /* Find the snoop entry for the current interpreter */ memberPtr = Tcl_FindHashEntry(dbus->snoop, (char *) interp); snoop = Tcl_GetHashValue(memberPtr); /* Unregistering the old handler */ if (snoop != NULL) { dbus_connection_remove_filter(dbus->conn, DBus_Monitor, snoop); Tcl_DecrRefCount(snoop->script); ckfree((char *) snoop); Tcl_SetHashValue(memberPtr, NULL); } if (Tcl_GetCharLength(handler) > 0) { /* Register the new handler */ snoop = (Tcl_DBusMonitorData *)ckalloc(sizeof(Tcl_DBusMonitorData)); snoop->interp = interp; snoop->script = handler; snoop->flags = flags; Tcl_IncrRefCount(handler); Tcl_SetHashValue(memberPtr, snoop); dbus_connection_add_filter(dbus->conn, DBus_Monitor, snoop, NULL); } return TCL_OK; }
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; }