void tclSendThread(Tcl_ThreadId thread, Tcl_Interp *interpreter, CONST char *script)
{
ThreadEvent *event;
Tcl_Channel errorChannel;
Tcl_Obj *object;
int boolean;
object = Tcl_GetVar2Ex(interpreter, "::tcl_platform", "threaded", 0);
if ((object == 0) || (Tcl_GetBooleanFromObj(interpreter, object, &boolean) != TCL_OK) || !boolean) {
errorChannel = Tcl_GetStdChannel(TCL_STDERR);
if (errorChannel == NULL) return;
Tcl_WriteChars(
errorChannel, "error: Python thread requested script evaluation on Tcl core not compiled for multithreading.\n", -1
);
return;
}
event = (ThreadEvent *)Tcl_Alloc(sizeof(ThreadEvent));
event->event.proc = ThreadEventProc;
event->interpreter = interpreter;
event->script = strcpy(Tcl_Alloc(strlen(script) + 1), script);
Tcl_MutexLock(&threadMutex);
Tcl_ThreadQueueEvent(thread, (Tcl_Event *)event, TCL_QUEUE_TAIL);
Tcl_ThreadAlert(thread);
Tcl_MutexUnlock(&threadMutex);
}
static void StateSpecUpdateString(Tcl_Obj *objPtr)
{
unsigned int onbits = (objPtr->internalRep.longValue & 0xFFFF0000) >> 16;
unsigned int offbits = objPtr->internalRep.longValue & 0x0000FFFF;
unsigned int mask = onbits | offbits;
Tcl_DString result;
int i, len;
Tcl_DStringInit(&result);
for (i=0; stateNames[i] != NULL; ++i) {
if (mask & (1<<i)) {
if (offbits & (1<<i))
Tcl_DStringAppend(&result, "!", 1);
Tcl_DStringAppend(&result, stateNames[i], -1);
Tcl_DStringAppend(&result, " ", 1);
}
}
len = Tcl_DStringLength(&result);
if (len) {
/* 'len' includes extra trailing ' ' */
objPtr->bytes = Tcl_Alloc((unsigned)len);
objPtr->length = len-1;
strncpy(objPtr->bytes, Tcl_DStringValue(&result), (size_t)len-1);
objPtr->bytes[len-1] = '\0';
} else {
/* empty string */
objPtr->length = 0;
objPtr->bytes = Tcl_Alloc(1);
*objPtr->bytes = '\0';
}
Tcl_DStringFree(&result);
}
Tfp_ArrayType
*Tfp_ArrayInit( Tfp_ArrayDeleteProc *cleanProc )
{
Tfp_ArrayType *arr;
arr = (Tfp_ArrayType *) Tcl_Alloc( sizeof(Tfp_ArrayType) );
arr->table = (Tcl_HashTable *) Tcl_Alloc( sizeof(Tcl_HashTable) );
Tcl_InitHashTable( arr->table, TCL_STRING_KEYS );
arr->cleanProc = cleanProc;
return arr;
}
static ReflectingChannel*
rcCreate (Tcl_Interp* ip_, Tcl_Obj* context_, int mode_, const char* name_)
{
ReflectingChannel* cp = (ReflectingChannel*) Tcl_Alloc (sizeof *cp);
cp->_validMask = mode_;
cp->_watchMask = 0;
cp->_chan = 0;
cp->_context = context_;
cp->_interp = ip_;
cp->_name = Tcl_NewStringObj(name_, -1);
cp->_timer = NULL;
/* support Tcl_GetIndexFromObj by keeping these objectified */
cp->_seek = Tcl_NewStringObj("seek", -1);
cp->_read = Tcl_NewStringObj("read", -1);
cp->_write = Tcl_NewStringObj("write", -1);
Tcl_IncrRefCount(cp->_context);
Tcl_IncrRefCount(cp->_seek);
Tcl_IncrRefCount(cp->_read);
Tcl_IncrRefCount(cp->_write);
Tcl_IncrRefCount(cp->_name);
return cp;
}
/*
* Sets an active tag array from the 'list' string.
* An empty 'list' sets the array to contain nothing, but a NULL list sets
* the array to the default - all.
*/
int SetActiveTags2 (char *list, int *num, char ***types) {
if (*types)
Tcl_Free((char *)*types);
if (list) {
if (SplitList(list, num, types) == -1) {
*types = NULL;
*num = 0;
return -1;
}
} else {
int i;
if (NULL == (*types = (char **)Tcl_Alloc(tag_db_count * sizeof(char *)))){
*num = 0;
return -1;
}
for (i = 0; i < tag_db_count; i++) {
(*types)[i] = tag_db[i].id;
}
*num = tag_db_count;
}
return 0;
}
char *DBus_Alloc(int size, char *file, int line)
{
char *rc;
rc = Tcl_Alloc(size);
printf("%p, %d bytes (%s:%d)\n", rc, size, file, line);
return rc;
}
void TclUtils::notifyProcError(Tcl_Interp *interp, const std::exception& ex, const char* default_message) {
const char *message = ex.what() && *ex.what() ? ex.what() : default_message;
char* buf = Tcl_Alloc(static_cast<int>(::strlen(message)) + 1);
Tcl_SetResult(
interp,
::strcpy(buf, message),
TCL_DYNAMIC);
}
Buf_BufferQueue
Buf_NewQueue ()
{
Queue* q = (Queue*) Tcl_Alloc (sizeof (Queue));
q->firstNode = (QNode*) NULL;
q->lastNode = (QNode*) NULL;
q->size = 0;
#if GT81
q->lock = (Tcl_Mutex) NULL;
#endif
return (Buf_BufferQueue) q;
}
/*
* Syslog_ListHash - appends to interp result all the values of given
* hash table
*/
static void Syslog_ListHash(Tcl_Interp *interp,Tcl_HashTable *table)
{
Tcl_HashSearch *searchPtr=(Tcl_HashSearch *)
Tcl_Alloc(sizeof(Tcl_HashSearch));
Tcl_HashEntry *entry;
char separator[3]={' ',' ',0};
entry=Tcl_FirstHashEntry(table,searchPtr);
while (entry) {
Tcl_AppendResult(interp,separator,Tcl_GetHashKey(table,entry),NULL);
separator[0]=',';
entry=Tcl_NextHashEntry(searchPtr);
}
Tcl_Free((char *)searchPtr);
}
/*************************************************************************
* FUNCTION : RPMPRoblem_Obj::Get_stringrep *
* ARGUMENTS : none *
* RETURNS : Tcl_Alloc'ed string rep of an object *
* EXCEPTIONS : none *
* PURPOSE : Return the string rep of an RPM header *
*************************************************************************/
char *RPMPRoblem_Obj::Get_stringrep(int &len)
{
// Get our parts as a TCL list
Tcl_Obj *name = Get_parts();
Tcl_IncrRefCount(name);
// we must return dynamaically allocated space, so allocate that
int size = 0;
char *from = Tcl_GetStringFromObj(name,&size);
char *space = Tcl_Alloc(size+1);
assert(space);
strncpy(space,from,size);
space[size] = 0;
Tcl_DecrRefCount(name);
len = size;
return space;
}
int
Tcljson_JsonObjToTclObj(struct json_object *joPtr, Tcl_Obj **objPtr)
{
TclJsonObject *tjPtr;
*objPtr = NULL;
tjPtr = (TclJsonObject *) Tcl_Alloc(sizeof(TclJsonObject));
tjPtr->joPtr = joPtr;
*objPtr = Tcl_NewObj();
(*objPtr)->internalRep.otherValuePtr = (VOID *) tjPtr;
(*objPtr)->typePtr = &tclJsonObjectType;
Tcl_InvalidateStringRep(*objPtr);
return TCL_OK;
}
static Tcl_Command *
PkguaInterpToTokens(
Tcl_Interp *interp)
{
int newEntry;
Tcl_Command *cmdTokens;
Tcl_HashEntry *entryPtr =
Tcl_CreateHashEntry(&interpTokenMap, (char *) interp, &newEntry);
if (newEntry) {
cmdTokens = (Tcl_Command *)
Tcl_Alloc(sizeof(Tcl_Command) * (MAX_REGISTERED_COMMANDS+1));
for (newEntry=0 ; newEntry<MAX_REGISTERED_COMMANDS+1 ; ++newEntry) {
cmdTokens[newEntry] = NULL;
}
Tcl_SetHashValue(entryPtr, cmdTokens);
} else {
cmdTokens = (Tcl_Command *) Tcl_GetHashValue(entryPtr);
}
return cmdTokens;
}
char *
curlCreateMultiObjCmd (Tcl_Interp *interp,struct curlMultiObjData *curlMultiData) {
char *handleName;
int i;
Tcl_CmdInfo info;
Tcl_Command cmdToken;
/* We try with mcurl1, if it already exists with mcurl2, ... */
handleName=(char *)Tcl_Alloc(10);
for (i=1;;i++) {
sprintf(handleName,"mcurl%d",i);
if (!Tcl_GetCommandInfo(interp,handleName,&info)) {
cmdToken=Tcl_CreateObjCommand(interp,handleName,curlMultiObjCmd,
(ClientData)curlMultiData,
(Tcl_CmdDeleteProc *)curlMultiDeleteCmd);
break;
}
}
curlMultiData->token=cmdToken;
return handleName;
}
/*
** configure a new audio tap
*/
static void *_configure_impl(_t *data) {
int b_size = sdrkit_buffer_size(data); /* size of jack buffer (samples) */
data->buff_n = 1<<data->opts.log2_buff_n; /* number of buffers (n) */
data->buff_size = 1<<data->opts.log2_buff_size; /* number of sample pairs in each buffer (samples) */
if (data->buff_size < b_size)
return "audio-tap buffer size must as large as jack buffer size";
data->buffs = (buffer_t *)Tcl_Alloc(data->buff_n*sizeof(buffer_t));
if (data->buffs == NULL) {
return "allocation failed: buff array";
}
for (int i = 0; i < data->buff_n; i += 1) {
data->buffs[i].bread = 1;
data->buffs[i].bframe = 0;
data->buffs[i].buff = Tcl_NewObj();
if (data->buffs[i].buff == NULL ||
Tcl_SetByteArrayLength(data->buffs[i].buff, data->buff_size*2*sizeof(float)) == NULL) {
_delete_impl(data);
return "allocation failed: byte array";
}
Tcl_IncrRefCount(data->buffs[i].buff);
}
data->current = &data->buffs[0];
return data;
}
/* real-to-complex transform in 1 dimension */
int tcl_rfft_1d(ClientData nodata, Tcl_Interp *interp,
int objc, Tcl_Obj *const objv[])
{
Tcl_Obj *result, **tdata;
const char *name;
kiss_fft_scalar *timed;
kiss_fft_cpx *freqd;
kiss_fftr_cfg work;
int dir, ndat, k;
/* thread safety */
Tcl_MutexLock(&myFftMutex);
/* set defaults: */
dir = FFT_FORWARD;
ndat = -1;
/* Parse arguments:
*
* usage: r2cfft_1d <data>
* or: c2rfft_1d <data>
*
* r2cfftf_1d : is the 1d real-to-complex forward transform.
* c2rfftb_1d : is the 1d complex-to-real backward transform.
* <data> : list containing data to be transformed. this can either a real
* or a list with two reals interpreted as complex.
*/
name = Tcl_GetString(objv[0]);
if (strcmp(name,"r2cfft_1d") == 0) {
dir = FFT_FORWARD;
} else if (strcmp(name,"c2rfft_1d") == 0) {
dir = FFT_BACKWARD;
} else {
Tcl_AppendResult(interp, name, ": unknown fft command.", NULL);
Tcl_MutexUnlock(&myFftMutex);
return TCL_ERROR;
}
if (objc != 2) {
Tcl_WrongNumArgs(interp, 1, objv, "<data>");
Tcl_MutexUnlock(&myFftMutex);
return TCL_ERROR;
}
/* get handle on data */
Tcl_IncrRefCount(objv[1]);
if (Tcl_ListObjGetElements(interp, objv[1], &ndat, &tdata) != TCL_OK) {
Tcl_DecrRefCount(objv[1]);
Tcl_MutexUnlock(&myFftMutex);
return TCL_ERROR;
}
if (ndat < 0) { /* this should not happen, but... */
Tcl_AppendResult(interp, name, ": illegal data array.", NULL);
Tcl_DecrRefCount(objv[1]);
Tcl_MutexUnlock(&myFftMutex);
return TCL_ERROR;
}
/* no effect for zero or one element */
if ((ndat == 0) || (ndat == 1)) {
Tcl_DecrRefCount(objv[1]);
Tcl_SetObjResult(interp, objv[1]);
Tcl_MutexUnlock(&myFftMutex);
return TCL_OK;
}
/* we need an even number of data points for the forward transform */
if (ndat & 1) {
if (dir == FFT_FORWARD) {
Tcl_AppendResult(interp, name, " needs an even number of data points.", NULL);
Tcl_DecrRefCount(objv[1]);
Tcl_MutexUnlock(&myFftMutex);
return TCL_ERROR;
}
}
check_thread_count(interp,"fftcmds");
/* size of data arrays for backward transform */
if (dir == FFT_BACKWARD) ndat = (ndat-1)*2;
/* get dynamic storage for passing data to the lowlevel code. */
timed = (void *)Tcl_Alloc(ndat*sizeof(kiss_fft_scalar));
freqd = (void *)Tcl_Alloc((ndat/2+1)*sizeof(kiss_fft_cpx));
work = kiss_fftr_alloc(ndat, dir, NULL, NULL);
/* parse/copy data list */
if (dir == FFT_FORWARD) {
for (k=0; k<ndat; ++k) {
if (Tcl_GetDoubleFromObj(interp, tdata[k], timed + k) != TCL_OK) {
Tcl_AppendResult(interp, name, ": illegal data array.", NULL);
Tcl_DecrRefCount(objv[1]);
Tcl_MutexUnlock(&myFftMutex);
return TCL_ERROR;
}
}
} else {
for (k=0; k<(ndat/2)+1; ++k) {
if (read_list_cpx(interp, tdata[k], freqd + k) != TCL_OK) {
Tcl_AppendResult(interp, name, ": illegal data array.", NULL);
Tcl_DecrRefCount(objv[1]);
Tcl_MutexUnlock(&myFftMutex);
return TCL_ERROR;
}
}
}
Tcl_DecrRefCount(objv[1]);
/* finally run the transform */
if (dir == FFT_FORWARD) {
kiss_fftr(work, timed, freqd);
} else {
kiss_fftri(work, freqd, timed);
}
/* prepare results */
result = Tcl_NewListObj(0, NULL);
if (dir == FFT_FORWARD) {
for (k=0; k<(ndat/2)+1; ++k) {
make_list_cpx(interp, result, freqd + k);
}
} else {
for (k=0; k<ndat; ++k) {
Tcl_ListObjAppendElement(interp, result, Tcl_NewDoubleObj(timed[k]));
}
}
Tcl_SetObjResult(interp, result);
/* free intermediate storage */
Tcl_Free((char *)timed);
Tcl_Free((char *)freqd);
kiss_fft_free(work);
kiss_fft_cleanup();
Tcl_MutexUnlock(&myFftMutex);
return TCL_OK;
}
/* generic complex <N>d-transform. */
int tcl_cfft_nd(ClientData nodata, Tcl_Interp *interp,
int objc, Tcl_Obj *const objv[])
{
Tcl_Obj *result, **tdata[FFT_MAX_DIM];
const char *name;
kiss_fft_cpx *input;
kiss_fft_cpx *output;
kiss_fftnd_cfg work;
int dir, ndim, alldim, ndat[FFT_MAX_DIM];
int i;
Tcl_MutexLock(&myFftMutex);
/* set defaults: */
dir = FFT_FORWARD;
ndim = -1;
/* Parse arguments:
*
* usage: cfftf_nd <data>
* or: cfftb_nd <data>
*
* cfftf_nd : is the Nd complex forward transform.
* cfftb_nd : is the Nd complex backward transform.
* <data> : list containing data to be transformed. this can either a real
* or a list with two reals interpreted as complex.
*/
name = Tcl_GetString(objv[0]);
if (strcmp(name,"cfftf_2d") == 0) {
dir = FFT_FORWARD;
ndim = 2;
} else if (strcmp(name,"cfftb_2d") == 0) {
dir = FFT_BACKWARD;
ndim = 2;
} else if (strcmp(name,"cfftf_3d") == 0) {
dir = FFT_FORWARD;
ndim = 3;
} else if (strcmp(name,"cfftb_3d") == 0) {
dir = FFT_BACKWARD;
ndim = 3;
} else if (strcmp(name,"cfftf_4d") == 0) {
dir = FFT_FORWARD;
ndim = 4;
} else if (strcmp(name,"cfftb_4d") == 0) {
dir = FFT_BACKWARD;
ndim = 4;
} else {
Tcl_AppendResult(interp, name, ": unknown fft command.", NULL);
Tcl_MutexUnlock(&myFftMutex);
return TCL_ERROR;
}
if (objc != 2) {
Tcl_WrongNumArgs(interp, 1, objv, "<data>");
Tcl_MutexUnlock(&myFftMutex);
return TCL_ERROR;
}
/* mark data as busy and check */
Tcl_IncrRefCount(objv[1]);
if (Tcl_ListObjGetElements(interp, objv[1], &(ndat[0]), &(tdata[0])) != TCL_OK) {
Tcl_DecrRefCount(objv[1]);
Tcl_MutexUnlock(&myFftMutex);
return TCL_ERROR;
}
if ((ndat[0] < 0) || (ndim > FFT_MAX_DIM)) { /* this should not happen, but... */
Tcl_AppendResult(interp, name, ": illegal or unsupported data array.", NULL);
Tcl_DecrRefCount(objv[1]);
Tcl_MutexUnlock(&myFftMutex);
return TCL_ERROR;
}
if (ndat[0] == 0) { /* no effect for empty array */
Tcl_DecrRefCount(objv[1]);
Tcl_SetObjResult(interp, objv[1]);
Tcl_MutexUnlock(&myFftMutex);
return TCL_OK;
}
check_thread_count(interp,"fftcmds");
/* determine size of each dimension for storage size and parsing/checking. */
alldim=ndat[0];
for (i=1; i<ndim; ++i) {
if (Tcl_ListObjGetElements(interp, tdata[i-1][0], &(ndat[i]), &(tdata[i])) != TCL_OK) {
Tcl_DecrRefCount(objv[1]);
Tcl_MutexUnlock(&myFftMutex);
return TCL_ERROR;
}
alldim *= ndat[i];
}
input = (void *)Tcl_Alloc(alldim*sizeof(kiss_fft_cpx));
output = (void *)Tcl_Alloc(alldim*sizeof(kiss_fft_cpx));
work = kiss_fftnd_alloc(ndat, ndim, dir, NULL, NULL);
/* parse/copy data list through recursive function and release original data. */
alldim=0;
for (i=0; i<ndat[0]; ++i) {
if (read_list_list(interp, tdata[0][i], 1, ndim, ndat, input, &alldim) != TCL_OK) {
Tcl_AppendResult(interp, name, ": illegal data array.", NULL);
Tcl_DecrRefCount(objv[1]);
Tcl_MutexUnlock(&myFftMutex);
return TCL_ERROR;
}
}
Tcl_DecrRefCount(objv[1]);
/* finally run the transform */
kiss_fftnd(work, input, output);
/* build result list(s) recursively */
result = Tcl_NewListObj(0, NULL);
alldim = 0;
for (i=0; i<ndat[0]; ++i) {
make_list_list(interp, result, 1, ndim, ndat, output, &alldim);
}
Tcl_SetObjResult(interp, result);
/* free intermediate storage */
Tcl_Free((char *)input);
Tcl_Free((char *)output);
kiss_fft_free(work);
kiss_fft_cleanup();
Tcl_MutexUnlock(&myFftMutex);
return TCL_OK;
}
/* generic complex 1d-transform. */
int tcl_cfft_1d(ClientData nodata, Tcl_Interp *interp,
int objc, Tcl_Obj *const objv[])
{
Tcl_Obj *result, **tdata;
const char *name;
kiss_fft_cpx *input;
kiss_fft_cpx *output;
kiss_fft_cfg work;
int dir, ndat, k;
/* thread safety */
Tcl_MutexLock(&myFftMutex);
/* set defaults: */
dir = FFT_FORWARD;
ndat = -1;
/* Parse arguments:
*
* usage: cfftf_1d <data>
* or: cfftb_1d <data>
*
* cfftf_1d : is the 1d complex forward transform.
* cfftb_1d : is the 1d complex backward transform.
* <data> : list containing data to be transformed. this can either a real
* or a list with two reals interpreted as complex.
*/
name = Tcl_GetString(objv[0]);
if (strcmp(name,"cfftf_1d") == 0) {
dir = FFT_FORWARD;
} else if (strcmp(name,"cfftb_1d") == 0) {
dir = FFT_BACKWARD;
} else {
Tcl_AppendResult(interp, name, ": unknown fft command.", NULL);
Tcl_MutexUnlock(&myFftMutex);
return TCL_ERROR;
}
if (objc != 2) {
Tcl_WrongNumArgs(interp, 1, objv, "<data>");
Tcl_MutexUnlock(&myFftMutex);
return TCL_ERROR;
}
/* get handle on data and check */
Tcl_IncrRefCount(objv[1]);
if (Tcl_ListObjGetElements(interp, objv[1], &ndat, &tdata) != TCL_OK) {
Tcl_DecrRefCount(objv[1]);
Tcl_MutexUnlock(&myFftMutex);
return TCL_ERROR;
}
if (ndat < 0) { /* this should not happen, but... */
Tcl_AppendResult(interp, name, ": illegal data array.", NULL);
Tcl_DecrRefCount(objv[1]);
Tcl_MutexUnlock(&myFftMutex);
return TCL_ERROR;
}
if ((ndat == 0) || (ndat == 1)) { /* no effect for zero or one element */
Tcl_DecrRefCount(objv[1]);
Tcl_SetObjResult(interp, objv[1]);
Tcl_MutexUnlock(&myFftMutex);
return TCL_OK;
}
check_thread_count(interp,"fftcmds");
/* get dynamic storage for passing data to the lowlevel code. */
input = (void *)Tcl_Alloc(ndat*sizeof(kiss_fft_cpx));
output = (void *)Tcl_Alloc(ndat*sizeof(kiss_fft_cpx));
work = kiss_fft_alloc(ndat, dir, NULL, NULL);
/* parse/copy data list */
for (k=0; k<ndat; ++k) {
if (read_list_cpx(interp, tdata[k], input + k) != TCL_OK) {
Tcl_AppendResult(interp, name, ": illegal data array.", NULL);
Tcl_DecrRefCount(objv[1]);
Tcl_MutexUnlock(&myFftMutex);
return TCL_ERROR;
}
}
Tcl_DecrRefCount(objv[1]);
/* finally run the transform */
kiss_fft(work, input, output);
/* prepare results */
result = Tcl_NewListObj(0, NULL);
for (k=0; k<ndat; ++k) {
make_list_cpx(interp, result, output + k);
}
Tcl_SetObjResult(interp, result);
/* free intermediate storage */
Tcl_Free((char *)input);
Tcl_Free((char *)output);
kiss_fft_free(work);
kiss_fft_cleanup();
Tcl_MutexUnlock(&myFftMutex);
return TCL_OK;
}
int
TclpDlopen(
Tcl_Interp *interp, /* Used for error reporting. */
Tcl_Obj *pathPtr, /* Name of the file containing the desired
* code (UTF-8). */
Tcl_LoadHandle *loadHandle, /* Filled with token for dynamically loaded
* file which will be passed back to
* (*unloadProcPtr)() to unload the file. */
Tcl_FSUnloadFileProc **unloadProcPtr,
/* Filled with address of Tcl_FSUnloadFileProc
* function which should be used for this
* file. */
int flags)
{
void *handle;
Tcl_LoadHandle newHandle;
const char *native;
int dlopenflags = 0;
/*
* First try the full path the user gave us. This is particularly
* important if the cwd is inside a vfs, and we are trying to load using a
* relative path.
*/
native = Tcl_FSGetNativePath(pathPtr);
/*
* Use (RTLD_NOW|RTLD_LOCAL) as default, see [Bug #3216070]
*/
if (flags & TCL_LOAD_GLOBAL) {
dlopenflags |= RTLD_GLOBAL;
} else {
dlopenflags |= RTLD_LOCAL;
}
if (flags & TCL_LOAD_LAZY) {
dlopenflags |= RTLD_LAZY;
} else {
dlopenflags |= RTLD_NOW;
}
handle = dlopen(native, dlopenflags);
if (handle == NULL) {
/*
* Let the OS loader examine the binary search path for whatever
* string the user gave us which hopefully refers to a file on the
* binary path.
*/
Tcl_DString ds;
const char *fileName = Tcl_GetString(pathPtr);
native = Tcl_UtfToExternalDString(NULL, fileName, -1, &ds);
/*
* Use (RTLD_NOW|RTLD_LOCAL) as default, see [Bug #3216070]
*/
handle = dlopen(native, dlopenflags);
Tcl_DStringFree(&ds);
}
if (handle == NULL) {
/*
* Write the string to a variable first to work around a compiler bug
* in the Sun Forte 6 compiler. [Bug 1503729]
*/
const char *errorStr = dlerror();
if (interp) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"couldn't load file \"%s\": %s",
Tcl_GetString(pathPtr), errorStr));
}
return TCL_ERROR;
}
newHandle = Tcl_Alloc(sizeof(*newHandle));
newHandle->clientData = handle;
newHandle->findSymbolProcPtr = &FindSymbol;
newHandle->unloadFileProcPtr = &UnloadFile;
*unloadProcPtr = &UnloadFile;
*loadHandle = newHandle;
return TCL_OK;
}
extern void *
TclBNAlloc(
size_t x)
{
return (void *) Tcl_Alloc((unsigned int) x);
}
/* I don't know if we need to use Tcl's allocators within
* tcl extensions, but this provides them. In the makefile
* I use -DMALLOC=gmlayer_alloc, and in the rest of the program I use
* #ifndef MALLOC
* #define MALLOC malloc
* #endif
* When (if?) we fully commit to being a tcl extension, these
* can go away. Use ckalloc/ckfree instead of MALLOC/FREE.
*/
void *gmlayer_alloc(size_t n) { return Tcl_Alloc(n); }
/*******************************************************************************
* dhsMetaDataTcl ( ... )
* Use: set dhsStat [dhs::MetaData <eID> <{data}> <nlines> <{cfgList}> <expID> <obsID>]
*******************************************************************************/
static int dhsMetaDataTcl ( ClientData clientData, Tcl_Interp *interp, int argc, char *argv[] ) {
/* declare local scope variable and initialize them */
char *fp=(char *)NULL, *ap=(char *)NULL, *cp=(char *)NULL;
char **lsArgvC=(char **)NULL, **lsArgvD=(char **)NULL, **lsArgvF=(char **)NULL, **lsArgvS=(char **)NULL;
dhsHandle eID=(dhsHandle)0;
double expID=(double)0.0;
int ival=0, ik=0, ic=0, ierror=0, nbytes=0, nlines=0, lsArgcC=0, lsArgcD=0, lsArgcF=0, lsArgcS=0;
long lstat=0;
mdConfig_t mdConfigTcl;
char fitsName[DHS_FITS_NAMESIZE], fitsValue[DHS_FITS_VALSIZE], fitsComment[DHS_FITS_COMMENT];
char avpName[DHS_AVP_NAMESIZE], avpValue[DHS_AVP_VALSIZE], avpComment[DHS_AVP_COMMENT], obsID[DHS_IMPL_MAXSTR];
(void) memset((void *)&mdConfigTcl,0,sizeof(mdConfig_t));
(void) memset(fitsName,'\0',DHS_FITS_NAMESIZE);
(void) memset(fitsValue,'\0',DHS_FITS_VALSIZE);
(void) memset(fitsComment,'\0',DHS_FITS_COMMENT);
(void) memset(avpName,'\0',DHS_AVP_NAMESIZE);
(void) memset(avpValue,'\0',DHS_AVP_VALSIZE);
(void) memset(avpComment,'\0',DHS_AVP_COMMENT);
(void) memset(obsID,'\0',DHS_IMPL_MAXSTR);
/* initialize static variables */
(void) memset(response,'\0',MAXMSG);
(void) memset(result,'\0',DHS_RESULT_LEN);
/* check handle */
if ( Tcl_GetInt(interp,argv[1],&ival) != TCL_OK ) {
(void) sprintf(result,"%s","dhsMetaDataTcl-E-bad handle\n");
(void) Tcl_SetResult(interp,result,TCL_STATIC);
return TCL_ERROR;
}
eID = (dhsHandle)ival;
#ifdef DEBUGTCL
(void) fprintf(stderr,"dhs::MetaData: eID=%d\n",(int)eID); (void) fflush(stderr);
#endif
/* check data list */
if ( Tcl_SplitList(interp,argv[2],&lsArgcD,(tclListP_t)&lsArgvD)!=TCL_OK ) {
(void) sprintf(result,"%s","dhsMetaDataTcl-E-bad data list\n");
(void) Tcl_SetResult(interp,result,TCL_STATIC);
return TCL_ERROR;
}
/* check nlines */
if ( Tcl_GetInt(interp,argv[3],&nlines) != TCL_OK ) {
(void) sprintf(result,"%s","dhsMetaDataTcl-E-bad nlines\n");
(void) Tcl_SetResult(interp,result,TCL_STATIC);
return TCL_ERROR;
}
#ifdef DEBUGTCL
(void) fprintf(stderr,"dhs::MetaData: nlines=%d\n",nlines); (void) fflush(stderr);
#endif
/* check configuration list */
if ( Tcl_SplitList(interp,argv[4],&lsArgcC,(tclListP_t)&lsArgvC)!=TCL_OK || lsArgcC!=4L ) {
(void) sprintf(result,"%s","dhsMetaDataTcl-E-bad configuration list\n");
(void) Tcl_SetResult(interp,result,TCL_STATIC);
return TCL_ERROR;
}
/* check expID */
if ( Tcl_GetDouble(interp,argv[5],&expID) != TCL_OK ) {
(void) sprintf(result,"%s","dhsMetaDataTcl-E-bad exposure id\n");
(void) Tcl_SetResult(interp,result,TCL_STATIC);
return TCL_ERROR;
}
#ifdef DEBUGTCL
(void) fprintf(stderr,"dhs::MetaData: expID=%lf\n",expID); (void) fflush(stderr);
#endif
/* check obsID */
for ( ic=6; ic<argc; ic++ ) { strcat(obsID,argv[ic]); strcat(obsID," "); }
obsID[strlen(obsID)-1] = '\0';
#ifdef DEBUGTCL
(void) fprintf(stderr,"dhs::MetaData: obsID=%s\n",obsID); (void) fflush(stderr);
#endif
/* set configuration */
ival=0; if ( Tcl_GetInt(interp,lsArgvC[0],&ival) != TCL_OK ) ierror = DHS_TRUE; mdConfigTcl.metaType = (XLONG) ival;
ival=0; if ( Tcl_GetInt(interp,lsArgvC[1],&ival) != TCL_OK ) ierror = DHS_TRUE; mdConfigTcl.numFields = (XLONG) ival;
if ( Tcl_SplitList(interp,lsArgvC[2],&lsArgcF,(tclListP_t)&lsArgvF) != TCL_OK ) ierror = DHS_TRUE;
if ( Tcl_SplitList(interp,lsArgvC[3],&lsArgcS,(tclListP_t)&lsArgvS) != TCL_OK ) ierror = DHS_TRUE;
if ( ierror ) {
(void) sprintf(result,"%s","dhsMetaDataTcl-E-bad list element\n");
(void) Tcl_SetResult(interp,result,TCL_STATIC);
return TCL_ERROR;
}
#ifdef DEBUGTCL
(void) fprintf(stderr,"dhs::MetaData: mdConfigTcl: metaType=%d, numFields=%d\n",(int)mdConfigTcl.metaType,(int)mdConfigTcl.numFields); (void) fflush(stderr);
#endif
for ( ic=0; ic<mdConfigTcl.numFields; ic++ ) {
ival=0; if ( Tcl_GetInt(interp,lsArgvF[ic],&ival) != TCL_OK ) ierror = DHS_TRUE; mdConfigTcl.fieldSize[ic] = (XLONG) ival;
ival=0; if ( Tcl_GetInt(interp,lsArgvS[ic],&ival) != TCL_OK ) ierror = DHS_TRUE; mdConfigTcl.dataType[ic] = (XLONG) ival;
if ( ierror ) {
(void) sprintf(result,"%s","dhsMetaDataTcl-E-bad configuration element\n");
(void) Tcl_SetResult(interp,result,TCL_STATIC);
return TCL_ERROR;
}
#ifdef DEBUGTCL
(void) fprintf(stderr,"dhs::MetaData: mdConfigTcl: fieldSize[%d]=%d, dataType[%d]=%d\n",ic,(int)mdConfigTcl.fieldSize[ic],ic,(int)mdConfigTcl.dataType[ic]); (void) fflush(stderr);
#endif
}
/* get memory */
switch (mdConfigTcl.metaType) {
case DHS_MDTYPE_FITSHEADER:
nbytes = nlines*DHS_FITS_RAWLEN;
if ( (cp=fp=(char *)Tcl_Alloc(nbytes)) == (char *)NULL ) {
(void) sprintf(result,"%s","dhsMetaDataTcl-E-bad alloc\n");
(void) Tcl_SetResult(interp,result,TCL_STATIC);
return TCL_ERROR;
}
(void) memset((void *)fp,' ',nbytes);
for ( ic=0, ik=0; ik<nlines*3; ik+=3 ) {
(void) sprintf((char *)fitsName,"%8s",lsArgvD[ik]);
(void) memmove((void *)fp,fitsName,DHS_FITS_NAMESIZE); fp += DHS_FITS_NAMESIZE;
(void) sprintf((char *)fitsValue,"%20s",lsArgvD[ik+1]);
(void) memmove((void *)fp,fitsValue,DHS_FITS_VALSIZE); fp += DHS_FITS_VALSIZE;
(void) sprintf((char *)fitsComment,"%46s",lsArgvD[ik+2]);
(void) memmove((void *)fp,fitsComment,DHS_FITS_COMMENT); fp += DHS_FITS_COMMENT;
}
break;
case DHS_MDTYPE_AVPAIR:
nbytes = nlines*DHS_AVP_RAWLEN;
if ( (cp=ap=(char *)Tcl_Alloc(nbytes)) == (char *)NULL ) {
(void) sprintf(result,"%s","dhsMetaDataTcl-E-bad alloc\n");
(void) Tcl_SetResult(interp,result,TCL_STATIC);
return TCL_ERROR;
}
(void) memset((void *)ap,' ',nbytes);
for ( ic=0, ik=0; ik<nlines*3; ik+=3 ) {
(void) sprintf((char *)avpName,"%32s",lsArgvD[ik]);
(void) memmove((void *)ap,avpName,DHS_AVP_NAMESIZE); ap += DHS_AVP_NAMESIZE;
(void) sprintf((char *)avpValue,"%32s",lsArgvD[ik+1]);
(void) memmove((void *)ap,avpValue,DHS_AVP_VALSIZE); ap += DHS_AVP_VALSIZE;
(void) sprintf((char *)avpComment,"%64s",lsArgvD[ik+2]);
(void) memmove((void *)ap,avpComment,DHS_AVP_COMMENT); ap += DHS_AVP_COMMENT;
}
break;
default:
(void) sprintf(result,"%s","dhsMetaDataTcl-E-bad data type\n");
(void) Tcl_SetResult(interp,result,TCL_STATIC);
return TCL_ERROR;
break;
}
/* execute the dhs function */
dhsSendMetaData(&lstat,response,eID,(void *)cp,(size_t)nbytes,&mdConfigTcl,&expID,obsID);
if ( STATUS_BAD(lstat) ) {
(void) Tcl_SetResult(interp,response,TCL_STATIC);
return TCL_ERROR;
}
#ifdef DEBUGTCL
(void) fprintf(stderr,"dhs::MetaData: lstat=%ld\n",lstat); (void) fflush(stderr);
#endif
/* return result */
(void) sprintf(result,"%ld",lstat);
(void) Tcl_SetResult(interp,result,TCL_STATIC);
(void) Tcl_Free((char *)lsArgvC);
(void) Tcl_Free((char *)lsArgvD);
(void) Tcl_Free((char *)lsArgvF);
(void) Tcl_Free((char *)lsArgvS);
(void) Tcl_Free((char *)cp);
return TCL_OK;
}
static void
setargv(
int *argcPtr, /* Filled with number of argument strings. */
char ***argvPtr)
{ /* Filled with argument strings (malloc'd). */
char *cmdLine, *p, *arg, *argSpace;
char **argv;
int argc, size, inquote, copy, slashes;
cmdLine = GetCommandLine(); /* INTL: BUG */
/*
* Precompute an overly pessimistic guess at the number of arguments
* in the command line by counting non-space spans.
*/
size = 2;
for (p = cmdLine; *p != '\0'; p++) {
if ((*p == ' ') || (*p == '\t')) { /* INTL: ISO space. */
size++;
while ((*p == ' ') || (*p == '\t')) { /* INTL: ISO space. */
p++;
}
if (*p == '\0') {
break;
}
}
}
argSpace = (char *)Tcl_Alloc(
(unsigned)(size * sizeof(char *) + strlen(cmdLine) + 1));
argv = (char **)argSpace;
argSpace += size * sizeof(char *);
size--;
p = cmdLine;
for (argc = 0; argc < size; argc++) {
argv[argc] = arg = argSpace;
while ((*p == ' ') || (*p == '\t')) { /* INTL: ISO space. */
p++;
}
if (*p == '\0') {
break;
}
inquote = 0;
slashes = 0;
while (1) {
copy = 1;
while (*p == '\\') {
slashes++;
p++;
}
if (*p == '"') {
if ((slashes & 1) == 0) {
copy = 0;
if ((inquote) && (p[1] == '"')) {
p++;
copy = 1;
} else {
inquote = !inquote;
}
}
slashes >>= 1;
}
while (slashes) {
*arg = '\\';
arg++;
slashes--;
}
if ((*p == '\0') || (!inquote && ((*p == ' ') ||
(*p == '\t')))) { /* INTL: ISO space. */
break;
}
if (copy != 0) {
*arg = *p;
arg++;
}
p++;
}
*arg = '\0';
argSpace = arg + 1;
}
argv[argc] = NULL;
*argcPtr = argc;
*argvPtr = argv;
}
/*
** The "sqlite" command below creates a new Tcl command for each
** connection it opens to an SQLite database. This routine is invoked
** whenever one of those connection-specific commands is executed
** in Tcl. For example, if you run Tcl code like this:
**
** sqlite db1 "my_database"
** db1 close
**
** The first command opens a connection to the "my_database" database
** and calls that connection "db1". The second command causes this
** subroutine to be invoked.
*/
static int DbObjCmd(void *cd, Tcl_Interp *interp, int objc,Tcl_Obj *const*objv){
SqliteDb *pDb = (SqliteDb*)cd;
int choice;
int rc = TCL_OK;
static const char *DB_strs[] = {
"authorizer", "busy", "changes",
"close", "commit_hook", "complete",
"errorcode", "eval", "function",
"last_insert_rowid", "last_statement_changes", "onecolumn",
"progress", "rekey", "timeout",
"trace",
0
};
enum DB_enum {
DB_AUTHORIZER, DB_BUSY, DB_CHANGES,
DB_CLOSE, DB_COMMIT_HOOK, DB_COMPLETE,
DB_ERRORCODE, DB_EVAL, DB_FUNCTION,
DB_LAST_INSERT_ROWID, DB_LAST_STATEMENT_CHANGES, DB_ONECOLUMN,
DB_PROGRESS, DB_REKEY, DB_TIMEOUT,
DB_TRACE
};
if( objc<2 ){
Tcl_WrongNumArgs(interp, 1, objv, "SUBCOMMAND ...");
return TCL_ERROR;
}
if( Tcl_GetIndexFromObj(interp, objv[1], DB_strs, "option", 0, &choice) ){
return TCL_ERROR;
}
switch( (enum DB_enum)choice ){
/* $db authorizer ?CALLBACK?
**
** Invoke the given callback to authorize each SQL operation as it is
** compiled. 5 arguments are appended to the callback before it is
** invoked:
**
** (1) The authorization type (ex: SQLITE_CREATE_TABLE, SQLITE_INSERT, ...)
** (2) First descriptive name (depends on authorization type)
** (3) Second descriptive name
** (4) Name of the database (ex: "main", "temp")
** (5) Name of trigger that is doing the access
**
** The callback should return on of the following strings: SQLITE_OK,
** SQLITE_IGNORE, or SQLITE_DENY. Any other return value is an error.
**
** If this method is invoked with no arguments, the current authorization
** callback string is returned.
*/
case DB_AUTHORIZER: {
if( objc>3 ){
Tcl_WrongNumArgs(interp, 2, objv, "?CALLBACK?");
}else if( objc==2 ){
if( pDb->zAuth ){
Tcl_AppendResult(interp, pDb->zAuth, 0);
}
}else{
char *zAuth;
int len;
if( pDb->zAuth ){
Tcl_Free(pDb->zAuth);
}
zAuth = Tcl_GetStringFromObj(objv[2], &len);
if( zAuth && len>0 ){
pDb->zAuth = Tcl_Alloc( len + 1 );
strcpy(pDb->zAuth, zAuth);
}else{
pDb->zAuth = 0;
}
#ifndef SQLITE_OMIT_AUTHORIZATION
if( pDb->zAuth ){
pDb->interp = interp;
sqlite_set_authorizer(pDb->db, auth_callback, pDb);
}else{
sqlite_set_authorizer(pDb->db, 0, 0);
}
#endif
}
break;
}
/* $db busy ?CALLBACK?
**
** Invoke the given callback if an SQL statement attempts to open
** a locked database file.
*/
case DB_BUSY: {
if( objc>3 ){
Tcl_WrongNumArgs(interp, 2, objv, "CALLBACK");
return TCL_ERROR;
}else if( objc==2 ){
if( pDb->zBusy ){
Tcl_AppendResult(interp, pDb->zBusy, 0);
}
}else{
char *zBusy;
int len;
if( pDb->zBusy ){
Tcl_Free(pDb->zBusy);
}
zBusy = Tcl_GetStringFromObj(objv[2], &len);
if( zBusy && len>0 ){
pDb->zBusy = Tcl_Alloc( len + 1 );
strcpy(pDb->zBusy, zBusy);
}else{
pDb->zBusy = 0;
}
if( pDb->zBusy ){
pDb->interp = interp;
sqlite_busy_handler(pDb->db, DbBusyHandler, pDb);
}else{
sqlite_busy_handler(pDb->db, 0, 0);
}
}
break;
}
/* $db progress ?N CALLBACK?
**
** Invoke the given callback every N virtual machine opcodes while executing
** queries.
*/
case DB_PROGRESS: {
if( objc==2 ){
if( pDb->zProgress ){
Tcl_AppendResult(interp, pDb->zProgress, 0);
}
}else if( objc==4 ){
char *zProgress;
int len;
int N;
if( TCL_OK!=Tcl_GetIntFromObj(interp, objv[2], &N) ){
return TCL_ERROR;
};
if( pDb->zProgress ){
Tcl_Free(pDb->zProgress);
}
zProgress = Tcl_GetStringFromObj(objv[3], &len);
if( zProgress && len>0 ){
pDb->zProgress = Tcl_Alloc( len + 1 );
strcpy(pDb->zProgress, zProgress);
}else{
pDb->zProgress = 0;
}
#ifndef SQLITE_OMIT_PROGRESS_CALLBACK
if( pDb->zProgress ){
pDb->interp = interp;
sqlite_progress_handler(pDb->db, N, DbProgressHandler, pDb);
}else{
sqlite_progress_handler(pDb->db, 0, 0, 0);
}
#endif
}else{
Tcl_WrongNumArgs(interp, 2, objv, "N CALLBACK");
return TCL_ERROR;
}
break;
}
/*
** $db changes
**
** Return the number of rows that were modified, inserted, or deleted by
** the most recent "eval".
*/
case DB_CHANGES: {
Tcl_Obj *pResult;
int nChange;
if( objc!=2 ){
Tcl_WrongNumArgs(interp, 2, objv, "");
return TCL_ERROR;
}
nChange = sqlite_changes(pDb->db);
pResult = Tcl_GetObjResult(interp);
Tcl_SetIntObj(pResult, nChange);
break;
}
/*
** $db last_statement_changes
**
** Return the number of rows that were modified, inserted, or deleted by
** the last statment to complete execution (excluding changes due to
** triggers)
*/
case DB_LAST_STATEMENT_CHANGES: {
Tcl_Obj *pResult;
int lsChange;
if( objc!=2 ){
Tcl_WrongNumArgs(interp, 2, objv, "");
return TCL_ERROR;
}
lsChange = sqlite_last_statement_changes(pDb->db);
pResult = Tcl_GetObjResult(interp);
Tcl_SetIntObj(pResult, lsChange);
break;
}
/* $db close
**
** Shutdown the database
*/
case DB_CLOSE: {
Tcl_DeleteCommand(interp, Tcl_GetStringFromObj(objv[0], 0));
break;
}
/* $db commit_hook ?CALLBACK?
**
** Invoke the given callback just before committing every SQL transaction.
** If the callback throws an exception or returns non-zero, then the
** transaction is aborted. If CALLBACK is an empty string, the callback
** is disabled.
*/
case DB_COMMIT_HOOK: {
if( objc>3 ){
Tcl_WrongNumArgs(interp, 2, objv, "?CALLBACK?");
}else if( objc==2 ){
if( pDb->zCommit ){
Tcl_AppendResult(interp, pDb->zCommit, 0);
}
}else{
char *zCommit;
int len;
if( pDb->zCommit ){
Tcl_Free(pDb->zCommit);
}
zCommit = Tcl_GetStringFromObj(objv[2], &len);
if( zCommit && len>0 ){
pDb->zCommit = Tcl_Alloc( len + 1 );
strcpy(pDb->zCommit, zCommit);
}else{
pDb->zCommit = 0;
}
if( pDb->zCommit ){
pDb->interp = interp;
sqlite_commit_hook(pDb->db, DbCommitHandler, pDb);
}else{
sqlite_commit_hook(pDb->db, 0, 0);
}
}
break;
}
/* $db complete SQL
**
** Return TRUE if SQL is a complete SQL statement. Return FALSE if
** additional lines of input are needed. This is similar to the
** built-in "info complete" command of Tcl.
*/
case DB_COMPLETE: {
Tcl_Obj *pResult;
int isComplete;
if( objc!=3 ){
Tcl_WrongNumArgs(interp, 2, objv, "SQL");
return TCL_ERROR;
}
isComplete = sqlite_complete( Tcl_GetStringFromObj(objv[2], 0) );
pResult = Tcl_GetObjResult(interp);
Tcl_SetBooleanObj(pResult, isComplete);
break;
}
/*
** $db errorcode
**
** Return the numeric error code that was returned by the most recent
** call to sqlite_exec().
*/
case DB_ERRORCODE: {
Tcl_SetObjResult(interp, Tcl_NewIntObj(pDb->rc));
break;
}
/*
** $db eval $sql ?array { ...code... }?
**
** The SQL statement in $sql is evaluated. For each row, the values are
** placed in elements of the array named "array" and ...code... is executed.
** If "array" and "code" are omitted, then no callback is every invoked.
** If "array" is an empty string, then the values are placed in variables
** that have the same name as the fields extracted by the query.
*/
case DB_EVAL: {
CallbackData cbData;
char *zErrMsg;
char *zSql;
#ifdef UTF_TRANSLATION_NEEDED
Tcl_DString dSql;
int i;
#endif
if( objc!=5 && objc!=3 ){
Tcl_WrongNumArgs(interp, 2, objv, "SQL ?ARRAY-NAME CODE?");
return TCL_ERROR;
}
pDb->interp = interp;
zSql = Tcl_GetStringFromObj(objv[2], 0);
#ifdef UTF_TRANSLATION_NEEDED
Tcl_DStringInit(&dSql);
Tcl_UtfToExternalDString(NULL, zSql, -1, &dSql);
zSql = Tcl_DStringValue(&dSql);
#endif
Tcl_IncrRefCount(objv[2]);
if( objc==5 ){
cbData.interp = interp;
cbData.once = 1;
cbData.zArray = Tcl_GetStringFromObj(objv[3], 0);
cbData.pCode = objv[4];
cbData.tcl_rc = TCL_OK;
cbData.nColName = 0;
cbData.azColName = 0;
zErrMsg = 0;
Tcl_IncrRefCount(objv[3]);
Tcl_IncrRefCount(objv[4]);
rc = sqlite_exec(pDb->db, zSql, DbEvalCallback, &cbData, &zErrMsg);
Tcl_DecrRefCount(objv[4]);
Tcl_DecrRefCount(objv[3]);
if( cbData.tcl_rc==TCL_BREAK ){ cbData.tcl_rc = TCL_OK; }
}else{
Tcl_Obj *pList = Tcl_NewObj();
cbData.tcl_rc = TCL_OK;
rc = sqlite_exec(pDb->db, zSql, DbEvalCallback2, pList, &zErrMsg);
Tcl_SetObjResult(interp, pList);
}
pDb->rc = rc;
if( rc==SQLITE_ABORT ){
if( zErrMsg ) free(zErrMsg);
rc = cbData.tcl_rc;
}else if( zErrMsg ){
Tcl_SetResult(interp, zErrMsg, TCL_VOLATILE);
free(zErrMsg);
rc = TCL_ERROR;
}else if( rc!=SQLITE_OK ){
Tcl_AppendResult(interp, sqlite_error_string(rc), 0);
rc = TCL_ERROR;
}else{
}
Tcl_DecrRefCount(objv[2]);
#ifdef UTF_TRANSLATION_NEEDED
Tcl_DStringFree(&dSql);
if( objc==5 && cbData.azColName ){
for(i=0; i<cbData.nColName; i++){
if( cbData.azColName[i] ) free(cbData.azColName[i]);
}
free(cbData.azColName);
cbData.azColName = 0;
}
#endif
return rc;
}
/*
** $db function NAME SCRIPT
**
** Create a new SQL function called NAME. Whenever that function is
** called, invoke SCRIPT to evaluate the function.
*/
case DB_FUNCTION: {
SqlFunc *pFunc;
char *zName;
char *zScript;
int nScript;
if( objc!=4 ){
Tcl_WrongNumArgs(interp, 2, objv, "NAME SCRIPT");
return TCL_ERROR;
}
zName = Tcl_GetStringFromObj(objv[2], 0);
zScript = Tcl_GetStringFromObj(objv[3], &nScript);
pFunc = (SqlFunc*)Tcl_Alloc( sizeof(*pFunc) + nScript + 1 );
if( pFunc==0 ) return TCL_ERROR;
pFunc->interp = interp;
pFunc->pNext = pDb->pFunc;
pFunc->zScript = (char*)&pFunc[1];
strcpy(pFunc->zScript, zScript);
sqlite_create_function(pDb->db, zName, -1, tclSqlFunc, pFunc);
sqlite_function_type(pDb->db, zName, SQLITE_NUMERIC);
break;
}
/*
** $db last_insert_rowid
**
** Return an integer which is the ROWID for the most recent insert.
*/
case DB_LAST_INSERT_ROWID: {
Tcl_Obj *pResult;
int rowid;
if( objc!=2 ){
Tcl_WrongNumArgs(interp, 2, objv, "");
return TCL_ERROR;
}
rowid = sqlite_last_insert_rowid(pDb->db);
pResult = Tcl_GetObjResult(interp);
Tcl_SetIntObj(pResult, rowid);
break;
}
/*
** $db onecolumn SQL
**
** Return a single column from a single row of the given SQL query.
*/
case DB_ONECOLUMN: {
char *zSql;
char *zErrMsg = 0;
if( objc!=3 ){
Tcl_WrongNumArgs(interp, 2, objv, "SQL");
return TCL_ERROR;
}
zSql = Tcl_GetStringFromObj(objv[2], 0);
rc = sqlite_exec(pDb->db, zSql, DbEvalCallback3, interp, &zErrMsg);
if( rc==SQLITE_ABORT ){
rc = SQLITE_OK;
}else if( zErrMsg ){
Tcl_SetResult(interp, zErrMsg, TCL_VOLATILE);
free(zErrMsg);
rc = TCL_ERROR;
}else if( rc!=SQLITE_OK ){
Tcl_AppendResult(interp, sqlite_error_string(rc), 0);
rc = TCL_ERROR;
}
break;
}
/*
** $db rekey KEY
**
** Change the encryption key on the currently open database.
*/
case DB_REKEY: {
int nKey;
void *pKey;
if( objc!=3 ){
Tcl_WrongNumArgs(interp, 2, objv, "KEY");
return TCL_ERROR;
}
pKey = Tcl_GetByteArrayFromObj(objv[2], &nKey);
#ifdef SQLITE_HAS_CODEC
rc = sqlite_rekey(pDb->db, pKey, nKey);
if( rc ){
Tcl_AppendResult(interp, sqlite_error_string(rc), 0);
rc = TCL_ERROR;
}
#endif
break;
}
/*
** $db timeout MILLESECONDS
**
** Delay for the number of milliseconds specified when a file is locked.
*/
case DB_TIMEOUT: {
int ms;
if( objc!=3 ){
Tcl_WrongNumArgs(interp, 2, objv, "MILLISECONDS");
return TCL_ERROR;
}
if( Tcl_GetIntFromObj(interp, objv[2], &ms) ) return TCL_ERROR;
sqlite_busy_timeout(pDb->db, ms);
break;
}
/* $db trace ?CALLBACK?
**
** Make arrangements to invoke the CALLBACK routine for each SQL statement
** that is executed. The text of the SQL is appended to CALLBACK before
** it is executed.
*/
case DB_TRACE: {
if( objc>3 ){
Tcl_WrongNumArgs(interp, 2, objv, "?CALLBACK?");
}else if( objc==2 ){
if( pDb->zTrace ){
Tcl_AppendResult(interp, pDb->zTrace, 0);
}
}else{
char *zTrace;
int len;
if( pDb->zTrace ){
Tcl_Free(pDb->zTrace);
}
zTrace = Tcl_GetStringFromObj(objv[2], &len);
if( zTrace && len>0 ){
pDb->zTrace = Tcl_Alloc( len + 1 );
strcpy(pDb->zTrace, zTrace);
}else{
pDb->zTrace = 0;
}
if( pDb->zTrace ){
pDb->interp = interp;
sqlite_trace(pDb->db, DbTraceHandler, pDb);
}else{
sqlite_trace(pDb->db, 0, 0);
}
}
break;
}
} /* End of the SWITCH statement */
return rc;
}
/*
** sqlite DBNAME FILENAME ?MODE? ?-key KEY?
**
** This is the main Tcl command. When the "sqlite" Tcl command is
** invoked, this routine runs to process that command.
**
** The first argument, DBNAME, is an arbitrary name for a new
** database connection. This command creates a new command named
** DBNAME that is used to control that connection. The database
** connection is deleted when the DBNAME command is deleted.
**
** The second argument is the name of the directory that contains
** the sqlite database that is to be accessed.
**
** For testing purposes, we also support the following:
**
** sqlite -encoding
**
** Return the encoding used by LIKE and GLOB operators. Choices
** are UTF-8 and iso8859.
**
** sqlite -version
**
** Return the version number of the SQLite library.
**
** sqlite -tcl-uses-utf
**
** Return "1" if compiled with a Tcl uses UTF-8. Return "0" if
** not. Used by tests to make sure the library was compiled
** correctly.
*/
static int DbMain(void *cd, Tcl_Interp *interp, int objc,Tcl_Obj *const*objv){
int mode;
SqliteDb *p;
void *pKey = 0;
int nKey = 0;
const char *zArg;
char *zErrMsg;
const char *zFile;
char zBuf[80];
if( objc==2 ){
zArg = Tcl_GetStringFromObj(objv[1], 0);
if( strcmp(zArg,"-encoding")==0 ){
Tcl_AppendResult(interp,sqlite_encoding,0);
return TCL_OK;
}
if( strcmp(zArg,"-version")==0 ){
Tcl_AppendResult(interp,sqlite_version,0);
return TCL_OK;
}
if( strcmp(zArg,"-has-codec")==0 ){
#ifdef SQLITE_HAS_CODEC
Tcl_AppendResult(interp,"1",0);
#else
Tcl_AppendResult(interp,"0",0);
#endif
return TCL_OK;
}
if( strcmp(zArg,"-tcl-uses-utf")==0 ){
#ifdef TCL_UTF_MAX
Tcl_AppendResult(interp,"1",0);
#else
Tcl_AppendResult(interp,"0",0);
#endif
return TCL_OK;
}
}
if( objc==5 || objc==6 ){
zArg = Tcl_GetStringFromObj(objv[objc-2], 0);
if( strcmp(zArg,"-key")==0 ){
pKey = Tcl_GetByteArrayFromObj(objv[objc-1], &nKey);
objc -= 2;
}
}
if( objc!=3 && objc!=4 ){
Tcl_WrongNumArgs(interp, 1, objv,
#ifdef SQLITE_HAS_CODEC
"HANDLE FILENAME ?-key CODEC-KEY?"
#else
"HANDLE FILENAME ?MODE?"
#endif
);
return TCL_ERROR;
}
if( objc==3 ){
mode = 0666;
}else if( Tcl_GetIntFromObj(interp, objv[3], &mode)!=TCL_OK ){
return TCL_ERROR;
}
zErrMsg = 0;
p = (SqliteDb*)Tcl_Alloc( sizeof(*p) );
if( p==0 ){
Tcl_SetResult(interp, "malloc failed", TCL_STATIC);
return TCL_ERROR;
}
memset(p, 0, sizeof(*p));
zFile = Tcl_GetStringFromObj(objv[2], 0);
#ifdef SQLITE_HAS_CODEC
p->db = sqlite_open_encrypted(zFile, pKey, nKey, 0, &zErrMsg);
#else
p->db = sqlite_open(zFile, mode, &zErrMsg);
#endif
if( p->db==0 ){
Tcl_SetResult(interp, zErrMsg, TCL_VOLATILE);
Tcl_Free((char*)p);
free(zErrMsg);
return TCL_ERROR;
}
zArg = Tcl_GetStringFromObj(objv[1], 0);
Tcl_CreateObjCommand(interp, zArg, DbObjCmd, (char*)p, DbDeleteCmd);
/* The return value is the value of the sqlite* pointer
*/
sprintf(zBuf, "%p", p->db);
if( strncmp(zBuf,"0x",2) ){
sprintf(zBuf, "0x%p", p->db);
}
Tcl_AppendResult(interp, zBuf, 0);
/* If compiled with SQLITE_TEST turned on, then register the "md5sum"
** SQL function.
*/
#ifdef SQLITE_TEST
{
extern void Md5_Register(sqlite*);
Md5_Register(p->db);
}
#endif
return TCL_OK;
}
* Side effects:
* See the user documentation.
*
*----------------------------------------------------------------------
*/
int
curlInitMultiObjCmd (ClientData clientData, Tcl_Interp *interp,
int objc,Tcl_Obj *CONST objv[]) {
Tcl_Obj *result;
struct curlMultiObjData *curlMultiData;
char *multiHandleName;
curlMultiData=(struct curlMultiObjData *)Tcl_Alloc(sizeof(struct curlMultiObjData));
if (curlMultiData==NULL) {
result=Tcl_NewStringObj("Couldn't allocate memory",-1);
Tcl_SetObjResult(interp,result);
return TCL_ERROR;
}
memset(curlMultiData, 0, sizeof(struct curlMultiObjData));
curlMultiData->interp=interp;
curlMultiData->mcurl=curl_multi_init();
if (curlMultiData->mcurl==NULL) {
result=Tcl_NewStringObj("Couldn't open curl multi handle",-1);
Tcl_SetObjResult(interp,result);
return TCL_ERROR;
int
Tcl_RecordAndEvalObj(
Tcl_Interp *interp, /* Token for interpreter in which command will
* be executed. */
Tcl_Obj *cmdPtr, /* Points to object holding the command to
* record and execute. */
int flags) /* Additional flags. TCL_NO_EVAL means record
* only: don't execute the command.
* TCL_EVAL_GLOBAL means evaluate the script
* in global variable context instead of the
* current procedure. */
{
int result, call = 1;
Tcl_CmdInfo info;
HistoryObjs *histObjsPtr =
Tcl_GetAssocData(interp, HISTORY_OBJS_KEY, NULL);
/*
* Create the references to the [::history add] command if necessary.
*/
if (histObjsPtr == NULL) {
histObjsPtr = Tcl_Alloc(sizeof(HistoryObjs));
TclNewLiteralStringObj(histObjsPtr->historyObj, "::history");
TclNewLiteralStringObj(histObjsPtr->addObj, "add");
Tcl_IncrRefCount(histObjsPtr->historyObj);
Tcl_IncrRefCount(histObjsPtr->addObj);
Tcl_SetAssocData(interp, HISTORY_OBJS_KEY, DeleteHistoryObjs,
histObjsPtr);
}
/*
* Do not call [history] if it has been replaced by an empty proc
*/
result = Tcl_GetCommandInfo(interp, "::history", &info);
if (result && (info.deleteProc == TclProcDeleteProc)) {
Proc *procPtr = (Proc *) info.objClientData;
call = (procPtr->cmdPtr->compileProc != TclCompileNoOp);
}
if (call) {
Tcl_Obj *list[3];
/*
* Do recording by eval'ing a tcl history command: history add $cmd.
*/
list[0] = histObjsPtr->historyObj;
list[1] = histObjsPtr->addObj;
list[2] = cmdPtr;
Tcl_IncrRefCount(cmdPtr);
(void) Tcl_EvalObjv(interp, 3, list, TCL_EVAL_GLOBAL);
Tcl_DecrRefCount(cmdPtr);
/*
* One possible failure mode above: exceeding a resource limit.
*/
if (Tcl_LimitExceeded(interp)) {
return TCL_ERROR;
}
}
/*
* Execute the command.
*/
result = TCL_OK;
if (!(flags & TCL_NO_EVAL)) {
result = Tcl_EvalObjEx(interp, cmdPtr, flags & TCL_EVAL_GLOBAL);
}
return result;
}
void
Tcl_RegisterConfig(
Tcl_Interp *interp, /* Interpreter the configuration command is
* registered in. */
const char *pkgName, /* Name of the package registering the
* embedded configuration. ASCII, thus in
* UTF-8 too. */
const Tcl_Config *configuration, /* Embedded configuration. */
const char *valEncoding) /* Name of the encoding used to store the
* configuration values, ASCII, thus UTF-8. */
{
Tcl_Obj *pDB, *pkgDict;
Tcl_DString cmdName;
const Tcl_Config *cfg;
QCCD *cdPtr = Tcl_Alloc(sizeof(QCCD));
cdPtr->interp = interp;
if (valEncoding) {
cdPtr->encoding = Tcl_Alloc(strlen(valEncoding)+1);
strcpy(cdPtr->encoding, valEncoding);
} else {
cdPtr->encoding = NULL;
}
cdPtr->pkg = Tcl_NewStringObj(pkgName, -1);
/*
* Phase I: Adding the provided information to the internal database of
* package meta data.
*
* Phase II: Create a command for querying this database, specific to the
* package registering its configuration. This is the approved interface
* in TIP 59. In the future a more general interface should be done, as
* follow-up to TIP 59. Simply because our database is now general across
* packages, and not a structure tied to one package.
*
* Note, the created command will have a reference through its clientdata.
*/
Tcl_IncrRefCount(cdPtr->pkg);
/*
* For venc == NULL aka bogus encoding we skip the step setting up the
* dictionaries visible at Tcl level. I.e. they are not filled
*/
pDB = GetConfigDict(interp);
/*
* Retrieve package specific configuration...
*/
if (Tcl_DictObjGet(interp, pDB, cdPtr->pkg, &pkgDict) != TCL_OK
|| (pkgDict == NULL)) {
pkgDict = Tcl_NewDictObj();
} else if (Tcl_IsShared(pkgDict)) {
pkgDict = Tcl_DuplicateObj(pkgDict);
}
/*
* Extend the package configuration...
* We cannot assume that the encodings are initialized, therefore
* store the value as-is in a byte array. See Bug [9b2e636361].
*/
for (cfg=configuration ; cfg->key!=NULL && cfg->key[0]!='\0' ; cfg++) {
Tcl_DictObjPut(interp, pkgDict, Tcl_NewStringObj(cfg->key, -1),
Tcl_NewByteArrayObj((unsigned char *)cfg->value, strlen(cfg->value)));
}
/*
* Write the changes back into the overall database.
*/
Tcl_DictObjPut(interp, pDB, cdPtr->pkg, pkgDict);
/*
* Now create the interface command for retrieval of the package
* information.
*/
Tcl_DStringInit(&cmdName);
TclDStringAppendLiteral(&cmdName, "::");
Tcl_DStringAppend(&cmdName, pkgName, -1);
/*
* The incomplete command name is the name of the namespace to place it
* in.
*/
if (Tcl_FindNamespace(interp, Tcl_DStringValue(&cmdName), NULL,
TCL_GLOBAL_ONLY) == NULL) {
if (Tcl_CreateNamespace(interp, Tcl_DStringValue(&cmdName),
NULL, NULL) == NULL) {
Tcl_Panic("%s.\n%s: %s",
Tcl_GetStringResult(interp), "Tcl_RegisterConfig",
"Unable to create namespace for package configuration.");
}
}
TclDStringAppendLiteral(&cmdName, "::pkgconfig");
if (Tcl_CreateObjCommand(interp, Tcl_DStringValue(&cmdName),
QueryConfigObjCmd, cdPtr, QueryConfigDelete) == NULL) {
Tcl_Panic("%s: %s", "Tcl_RegisterConfig",
"Unable to create query command for package configuration");
}
Tcl_DStringFree(&cmdName);
}
/* define the gmlayer command */
static int
gmlayer_TclCmd(ClientData data, Tcl_Interp *interp,
int argc, CONST char *argv[])
{
static int fitting;
CONST char *what;
#if DEBUG
int i;
for (i=0; i < argc; i++) { debug_message(argv[i]); debug_message(" ");}
debug_message("\n");
#endif
if (argc < 2) {
Tcl_AppendResult(interp,"gmlayer cmd ?args?",NULL);
return TCL_ERROR;
}
if (argc < 3) what = "";
else what = argv[2];
if (strcmp(argv[1], "halt") == 0) {
abortFit = 1;
} else if (strcmp(argv[1], "fit") == 0) {
/* XXX FIXME XXX shouldn't need 'fitting' */
Constrain = tclconstraints;
fitting = 1;
fit_callback = what;
fitReflec("FRG ");
fitting = 0;
sendfit(interp);
} else if (strcmp(argv[1], "constraints") == 0) {
if (fit_constraints != NULL) Tcl_Free(fit_constraints);
if (*what != '\0') {
fit_constraints = Tcl_Alloc(strlen(what)+1);
strcpy(fit_constraints, what);
} else {
fit_constraints = NULL;
}
} else if (strcmp(argv[1], "set") == 0) {
double *pd; int *pi;
char result[20];
if (!parsevar(what,&pi,&pd)) {
Tcl_AppendResult(interp,"gmlayer variable ",what," is not defined",NULL);
return TCL_ERROR;
}
if (argc > 3) {
if (pi != NULL && Tcl_GetInt(interp,argv[3],pi) != TCL_OK)
return TCL_ERROR;
if (pd != NULL && Tcl_GetDouble(interp,argv[3],pd) != TCL_OK)
return TCL_ERROR;
}
if (pi != NULL) { sprintf(result,"%d",*pi); }
if (pd != NULL) { sprintf(result,"%.15g",*pd); }
Tcl_SetResult(interp,result,TCL_VOLATILE);
} else if (strcmp(argv[1], "send") == 0) {
if (strcmp(what, "datafile") == 0) {
Tcl_SetResult(interp,infile,TCL_STATIC);
} else if (strcmp(what, "parfile") == 0) {
Tcl_SetResult(interp,parfile,TCL_STATIC);
} else if (strcmp(what, "constraints") == 0) {
if (argc > 3) {
cleanFree((double **)&ConstraintScript);
if (strlen(argv[3])) {
ConstraintScript = Tcl_Alloc(strlen(argv[3])+1);
if (ConstraintScript)
strcpy(ConstraintScript, argv[3]);
}
} else if (ConstraintScript != NULL)
Tcl_SetResult(interp,ConstraintScript,TCL_VOLATILE);
} else if (strcmp(what, "mkconstrain") == 0) {
#if 0
char version[15];
sprintf(version, "0x%08lx", MAJOR|MINOR);
Tcl_AppendResult(interp,makeconstrain," \"",constrainScript,
"\" \"", constrainModule,"\" ",version,
" \"", prototype, "\"", NULL);
#endif
} else if (strcmp(what, "varying") == 0) {
genva(listA, mfit, fitlist);
Tcl_SetResult(interp,fitlist,TCL_STATIC);
} else if (strcmp(what, "pars") == 0) {
sendpars(interp);
} else if (strcmp(what, "data") == 0) {
senddata(interp);
} else if (strcmp(what, "refl") == 0) {
if (fitting)
sendreflect(interp,xdat,ymod,npnts);
else if (0) {
/* Ideally, we would work on a subset of the
points until so that the user gets partial
feedback while dragging. These points would
lie in the current zoom window. When the
user stops dragging, the complete dataset would
be calculated. This has to happen without
making the rest of the interface clunky, either
with some sort of abort call or by calculating
one section at a time. For now this is too
complicated.
*/
int refinement;
if (argc>3) {
if (strcmp(argv[3], "max") == 0)
refinement = -1;
else if (Tcl_GetInt(interp, argv[3], &refinement) != TCL_OK)
return TCL_ERROR;
} else {
refinement = -1;
}
sendreflect(interp,xtemp,ytemp,npnts);
} else if (loaded) {
extend(xdat, npnts, lambda, lamdel, thedel);
genderiv(xdat, yfit, npnts, 0);
sendreflect(interp,xdat,yfit,npnts);
} else {
/* Send calculated reflectivity to GUI */
double qstep;
int j;
allocCdata(npnts); /* XXX FIXME XXX - not checking alloc failure */
qstep = (qmax - qmin) / (double) (npnts - 1);
for (j = 0; j < npnts; j++)
xtemp[j] = (double) j * qstep + qmin;
/* XXX FIXME XXX - not checking for memory allocation failure */
extend(xtemp, npnts, lambda, lamdel, thedel);
genderiv(xtemp, yfit, npnts, 0);
sendreflect(interp,xtemp,yfit,npnts);
}
} else if (strcmp(what, "chisq") == 0) {
char value[40];
double ret;
if (fitting) ret = chisq/(double)(npnts-mfit);
else if (loaded) ret=calcChiSq(npnts,yfit,ydat,srvar)/(double)(npnts-1);
else ret = -1.0;
sprintf(value,"%.15g",ret);
Tcl_AppendResult(interp,value,NULL);
} else if (strcmp(what, "prof") == 0) {
if (!fitting)
genmulti(tqcsq, mqcsq, bqcsq, tqcmsq, mqcmsq, bqcmsq,
td, md, bd, trough, mrough, brough, tmu, mmu, bmu,
nrough, ntlayer, nmlayer, nblayer, nrepeat, proftyp);
sendprofile(interp,argc>3);
} else {
Tcl_AppendResult(interp,"gmlayer send ?: expected pars, work, ...",NULL);
return TCL_ERROR;
}
} else if (strcmp(argv[1],"msg") == 0) {
printf("%s\n",what);
} else if (strcmp(argv[1],"gd") == 0) {
if (*infile) {
loadData(infile);
loaded = !failure;
}
} else {
queue = argv+1;
queued = argc-1;
failure = 0;
abortFit = 0;
mlayer();
if (failure) {
Tcl_AppendResult(interp,error_message,TCL_STATIC);
return TCL_ERROR;
}
}
return TCL_OK;
}
static void *crash_malloc(int nByte){
return (void *)Tcl_Alloc((size_t)nByte);
}
/*******************************************************************************
* dhsPixelDataTcl ( ... )
* Use: set dhsStat [dhs::PixelData <eID> <{data}> <nelms> <{cfgList}> <expID> <obsID>]
*******************************************************************************/
static int dhsPixelDataTcl ( ClientData clientData, Tcl_Interp *interp, int argc, char *argv[] ) {
/* declare local scope variable and initialize them */
char **lsArgvC=(char **)NULL, **lsArgvD=(char **)NULL;
dhsHandle eID=(dhsHandle)0;
double expID=(double)0.0;
int ival=0, ik=0, ic=0, ierror=0, nbytes=0, nelms=0, lsArgcC=0, lsArgcD=0;
long lstat=0;
XLONG *ip=(XLONG *)NULL, *dp=(XLONG *)NULL;
fpConfig_t fpConfigTcl;
char obsID[DHS_IMPL_MAXSTR];
(void) memset((void *)&fpConfigTcl,0,sizeof(fpConfig_t));
(void) memset(obsID,'\0',DHS_IMPL_MAXSTR);
/* initialize static variables */
(void) memset(response,'\0',MAXMSG);
(void) memset(result,'\0',DHS_RESULT_LEN);
/* check handle */
ival = 0;
if ( Tcl_GetInt(interp,argv[1],&ival) != TCL_OK ) {
(void) sprintf(result,"%s","dhsPixelDataTcl-E-bad handle\n");
(void) Tcl_SetResult(interp,result,TCL_STATIC);
return TCL_ERROR;
}
eID = (dhsHandle)ival;
#ifdef DEBUGTCL
(void) fprintf(stderr,"dhs::PixelData: eID=%d\n",(int)eID); (void) fflush(stderr);
#endif
/* check data list */
if ( Tcl_SplitList(interp,argv[2],&lsArgcD,(tclListP_t)&lsArgvD)!=TCL_OK ) {
(void) sprintf(result,"%s","dhsPixelDataTcl-E-bad data list\n");
(void) Tcl_SetResult(interp,result,TCL_STATIC);
return TCL_ERROR;
}
/* check nelms */
if ( Tcl_GetInt(interp,argv[3],&nelms) != TCL_OK ) {
(void) sprintf(result,"%s","dhsPixelDataTcl-E-bad nelms\n");
(void) Tcl_SetResult(interp,result,TCL_STATIC);
return TCL_ERROR;
}
#ifdef DEBUGTCL
(void) fprintf(stderr,"dhs::PixelData: nelms=%d\n",nelms); (void) fflush(stderr);
#endif
/* check configuration list */
if ( Tcl_SplitList(interp,argv[4],&lsArgcC,(tclListP_t)&lsArgvC)!=TCL_OK || lsArgcC!=11L ) {
(void) sprintf(result,"%s","dhsPixelDataTcl-E-bad configuration list\n");
(void) Tcl_SetResult(interp,result,TCL_STATIC);
return TCL_ERROR;
}
/* check expID */
if ( Tcl_GetDouble(interp,argv[5],&expID) != TCL_OK ) {
(void) sprintf(result,"%s","dhsPixelDataTcl-E-bad exposure id\n");
(void) Tcl_SetResult(interp,result,TCL_STATIC);
return TCL_ERROR;
}
#ifdef DEBUGTCL
(void) fprintf(stderr,"dhs::PixelData: expID=%lf\n",expID); (void) fflush(stderr);
#endif
/* check obsID */
for ( ic=6; ic<argc; ic++ ) { strcat(obsID,argv[ic]); strcat(obsID," "); }
obsID[strlen(obsID)-1] = '\0';
#ifdef DEBUGTCL
(void) fprintf(stderr,"dhs::PixelData: obsID=%s\n",obsID); (void) fflush(stderr);
#endif
/* set configuration */
ival=0; if ( Tcl_GetInt(interp,lsArgvC[0],&ival) != TCL_OK ) ierror = DHS_TRUE; fpConfigTcl.xSize = (XLONG)ival;
ival=0; if ( Tcl_GetInt(interp,lsArgvC[1],&ival) != TCL_OK ) ierror = DHS_TRUE; fpConfigTcl.ySize = (XLONG)ival;
ival=0; if ( Tcl_GetInt(interp,lsArgvC[2],&ival) != TCL_OK ) ierror = DHS_TRUE; fpConfigTcl.xStart = (XLONG)ival;
ival=0; if ( Tcl_GetInt(interp,lsArgvC[3],&ival) != TCL_OK ) ierror = DHS_TRUE; fpConfigTcl.yStart = (XLONG)ival;
ival=0; if ( Tcl_GetInt(interp,lsArgvC[4],&ival) != TCL_OK ) ierror = DHS_TRUE; fpConfigTcl.dataType = (XLONG)ival;
ival=0; if ( Tcl_GetInt(interp,lsArgvC[5],&ival) != TCL_OK ) ierror = DHS_TRUE; fpConfigTcl.xDir = (XLONG)ival;
ival=0; if ( Tcl_GetInt(interp,lsArgvC[6],&ival) != TCL_OK ) ierror = DHS_TRUE; fpConfigTcl.yDir = (XLONG)ival;
ival=0; if ( Tcl_GetInt(interp,lsArgvC[7],&ival) != TCL_OK ) ierror = DHS_TRUE; fpConfigTcl.xDetSz = (XLONG)ival;
ival=0; if ( Tcl_GetInt(interp,lsArgvC[8],&ival) != TCL_OK ) ierror = DHS_TRUE; fpConfigTcl.yDetSz = (XLONG)ival;
ival=0; if ( Tcl_GetInt(interp,lsArgvC[9],&ival) != TCL_OK ) ierror = DHS_TRUE; fpConfigTcl.xDetCnt = (XLONG)ival;
ival=0; if ( Tcl_GetInt(interp,lsArgvC[10],&ival) != TCL_OK ) ierror = DHS_TRUE; fpConfigTcl.yDetCnt = (XLONG)ival;
if ( ierror ) {
(void) sprintf(result,"%s","dhsPixelDataTcl-E-bad list element\n");
(void) Tcl_SetResult(interp,result,TCL_STATIC);
return TCL_ERROR;
}
#ifdef DEBUGTCL
(void) fprintf(stderr,"dhs::PixelData: fpConfigTcl.xSize =%d\n",(int)fpConfigTcl.xSize);
(void) fprintf(stderr,"dhs::PixelData: fpConfigTcl.ySize =%d\n",(int)fpConfigTcl.ySize);
(void) fprintf(stderr,"dhs::PixelData: fpConfigTcl.xStart =%d\n",(int)fpConfigTcl.xStart);
(void) fprintf(stderr,"dhs::PixelData: fpConfigTcl.yStart =%d\n",(int)fpConfigTcl.yStart);
(void) fprintf(stderr,"dhs::PixelData: fpConfigTcl.dataType =%d\n",(int)fpConfigTcl.dataType);
(void) fprintf(stderr,"dhs::PixelData: fpConfigTcl.xDir =%d\n",(int)fpConfigTcl.xDir);
(void) fprintf(stderr,"dhs::PixelData: fpConfigTcl.yDir =%d\n",(int)fpConfigTcl.yDir);
(void) fprintf(stderr,"dhs::PixelData: fpConfigTcl.xDetSz =%d\n",(int)fpConfigTcl.xDetSz);
(void) fprintf(stderr,"dhs::PixelData: fpConfigTcl.yDetSz =%d\n",(int)fpConfigTcl.yDetSz);
(void) fprintf(stderr,"dhs::PixelData: fpConfigTcl.xDetCnt =%d\n",(int)fpConfigTcl.xDetCnt);
(void) fprintf(stderr,"dhs::PixelData: fpConfigTcl.yDetCnt =%d\n",(int)fpConfigTcl.yDetCnt);
(void) fflush(stderr);
#endif
/* get memory */
nbytes = nelms * sizeof(XLONG);
if ( (ip=dp=(XLONG *)Tcl_Alloc(nbytes)) == (XLONG *)NULL ) {
(void) sprintf(result,"%s","dhsPixelDataTcl-E-bad alloc\n");
(void) Tcl_SetResult(interp,result,TCL_STATIC);
return TCL_ERROR;
}
/* extract data by re-using lsArgcC/lsArgvC */
(void) memset((void *)dp,0,nbytes);
for ( ic=0; ic<lsArgcD; ic++ ) {
if ( Tcl_SplitList(interp,lsArgvD[ic],&lsArgcC,(tclListP_t)&lsArgvC) != TCL_OK ) {
(void) sprintf(result,"%s","dhsPixelDataTcl-E-bad internal list\n");
(void) Tcl_SetResult(interp,result,TCL_STATIC);
return TCL_ERROR;
}
for ( ik=0; ik<lsArgcC; ik++ ) {
ival = 0;
if ( Tcl_GetInt(interp,lsArgvC[ik],&ival) != TCL_OK ) {
(void) sprintf(result,"%s","dhsPixelDataTcl-E-bad array data\n");
(void) Tcl_SetResult(interp,result,TCL_STATIC);
return TCL_ERROR;
}
*dp = (XLONG)ival;
dp++;
}
}
/* execute the dhs function */
dhsSendPixelData(&lstat,response,eID,(void *)ip,(size_t)nbytes,&fpConfigTcl,&expID,obsID);
if ( STATUS_BAD(lstat) ) {
(void) Tcl_SetResult(interp,response,TCL_STATIC);
return TCL_ERROR;
}
#ifdef DEBUGTCL
(void) fprintf(stderr,"dhs::PixelData: lstat=%ld\n",lstat); (void) fflush(stderr);
#endif
/* return result */
(void) sprintf(result,"%ld",lstat);
(void) Tcl_SetResult(interp,result,TCL_STATIC);
(void) Tcl_Free((char *)lsArgvC);
(void) Tcl_Free((char *)lsArgvD);
(void) Tcl_Free((char *)ip);
return TCL_OK;
}
