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