int
Tcl_GetInt(
Tcl_Interp *interp, /* Interpreter to use for error reporting. */
const char *src, /* String containing a (possibly signed)
* integer in a form acceptable to
* Tcl_GetIntFromObj(). */
int *intPtr) /* Place to store converted result. */
{
Tcl_Obj obj;
int code;
obj.refCount = 1;
obj.bytes = (char *) src;
obj.length = strlen(src);
obj.typePtr = NULL;
code = Tcl_GetIntFromObj(interp, &obj, intPtr);
if (obj.refCount > 1) {
Tcl_Panic("invalid sharing of Tcl_Obj on C stack");
}
return code;
}
/*
** usage: btree_insert CSR ?KEY? VALUE
**
** Set the size of the cache used by btree $ID.
*/
static int btree_insert(
ClientData clientData,
Tcl_Interp *interp,
int objc,
Tcl_Obj *const objv[]
){
BtCursor *pCur;
int rc;
BtreePayload x;
if( objc!=4 && objc!=3 ){
Tcl_WrongNumArgs(interp, 1, objv, "?-intkey? CSR KEY VALUE");
return TCL_ERROR;
}
memset(&x, 0, sizeof(x));
if( objc==4 ){
if( Tcl_GetIntFromObj(interp, objv[2], &rc) ) return TCL_ERROR;
x.nKey = rc;
x.pData = (void*)Tcl_GetByteArrayFromObj(objv[3], &x.nData);
}else{
x.pKey = (void*)Tcl_GetByteArrayFromObj(objv[2], &rc);
x.nKey = rc;
}
pCur = (BtCursor*)sqlite3TestTextToPtr(Tcl_GetString(objv[1]));
sqlite3_mutex_enter(pCur->pBtree->db->mutex);
sqlite3BtreeEnter(pCur->pBtree);
rc = sqlite3BtreeInsert(pCur, &x, 0, 0);
sqlite3BtreeLeave(pCur->pBtree);
sqlite3_mutex_leave(pCur->pBtree->db->mutex);
Tcl_ResetResult(interp);
if( rc ){
Tcl_AppendResult(interp, sqlite3ErrName(rc), 0);
return TCL_ERROR;
}
return TCL_OK;
}
static int
response_set_status(ClientData clientData, Tcl_Interp *interp, int objc,
Tcl_Obj *const objv[])
{
ngx_http_request_t *r = getrequest(clientData);
int status;
int rc;
if (objc != 2) {
Tcl_WrongNumArgs(interp, 1, objv, "status");
return TCL_ERROR;
}
rc = Tcl_GetIntFromObj(interp, objv[1], &status);
if (rc != TCL_OK) {
return rc;
}
r->headers_out.status = status;
return TCL_OK;
}
static void parse_args_obj_set(cli_args *a, char *store, Tcl_Obj *val) {
if (a->type == ARG_OBJ) {
*((Tcl_Obj **)&store[a->offset]) = val;
} else if (a->type == ARG_STR) {
*((char **)&store[a->offset]) = Tcl_GetStringFromObj(val, NULL);
} else if (a->type == ARG_INT) {
int i;
Tcl_GetIntFromObj(NULL, val, &i);
*((int *)&store[a->offset]) = i;
} else if (a->type == ARG_FLOAT) { /* ARG_FLOAT */
double d;
Tcl_GetDoubleFromObj(NULL, val, &d);
*((float *)&store[a->offset]) = d;
} else { /* ARG_DOUBLE */
double d;
Tcl_GetDoubleFromObj(NULL, val, &d);
*((double *)&store[a->offset]) = d;
}
a->def = ""; /* mark as used */
}
/* usage: worker_loop <work type> [<keyword arg dict>]
Repeatedly run units of work from ADLB of provided type
Optional key-value arguments:
buffer_size: size of payload buffer in bytes (must be large enough
for work units)
*/
static int
Turbine_Worker_Loop_Cmd(ClientData cdata, Tcl_Interp* interp,
int objc, Tcl_Obj* const objv[])
{
TCL_CONDITION(objc == 2 || objc == 3, "Need 1 or 2 arguments");
int work_type;
int rc = TCL_OK;
rc = Tcl_GetIntFromObj(interp, objv[1], &work_type);
TCL_CHECK(rc);
int buffer_size = TURBINE_ASYNC_EXEC_DEFAULT_BUFFER_SIZE;
if (objc >= 3)
{
int buffer_count = 1; // Deliberately ignored
rc = worker_keyword_args(interp, objv, objv[2], &buffer_count,
&buffer_size);
TCL_CHECK(rc);
}
// Maintain separate buffer from xfer, since xfer may be
// used in code that we call.
void* buffer = malloc((size_t)buffer_size);
TCL_CONDITION(buffer != NULL, "Out of memory");
turbine_code code = turbine_worker_loop(interp, buffer, buffer_size,
work_type);
free(buffer);
if (code == TURBINE_ERROR_EXTERNAL)
// turbine_worker_loop() has added the error info
rc = TCL_ERROR;
else
TCL_CONDITION(code == TURBINE_SUCCESS, "Unknown worker error!");
return rc;
}
static int
move_strafe(ClientData UNUSED(clientData), Tcl_Interp *interp, int UNUSED(objc), Tcl_Obj *const *objv)
{
struct isst_s *isst;
Togl *togl;
vect_t vec, dir, up;
int flag;
if (Togl_GetToglFromObj(interp, objv[1], &togl) != TCL_OK)
return TCL_ERROR;
isst = (struct isst_s *) Togl_GetClientData(togl);
if (Tcl_GetIntFromObj(interp, objv[2], &flag) != TCL_OK)
return TCL_ERROR;
VSET(up, 0, 0, 1);
if (flag >= 0) {
VSUB2(dir, isst->camera.focus, isst->camera.pos);
VCROSS(vec, dir, up);
VSCALE(vec, vec, 0.1 * isst->tie->radius);
VADD2(isst->camera.pos, isst->camera.pos, vec);
VADD2(isst->camera.focus, isst->camera.pos, dir);
} else {
VSUB2(dir, isst->camera.focus, isst->camera.pos);
VCROSS(vec, dir, up);
VSCALE(vec, vec, -0.1 * isst->tie->radius);
VADD2(isst->camera.pos, isst->camera.pos, vec);
VADD2(isst->camera.focus, isst->camera.pos, dir);
}
isst->dirty = 1;
return TCL_OK;
}
/* void draw_circleFilled (ESContext *esContext, int16_t x, int16_t y, int16_t radius, uint8_t r, uint8_t g, uint8_t b, uint8_t a) { */
int tclcmd_draw_circleFilled (ClientData cdata, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]) {
if (objc != 8) {
Tcl_WrongNumArgs (interp, 1, objv, "{ESContext *esContext} { int16_t x} { int16_t y} { int16_t radius} { uint8_t r} { uint8_t g} { uint8_t b} { uint8_t a}");
return TCL_ERROR;
}
int16_t arg_x;
if (Tcl_GetIntFromObj(interp, objv[1], (int *)&arg_x) != TCL_OK) {
return TCL_ERROR;
}
int16_t arg_y;
if (Tcl_GetIntFromObj(interp, objv[2], (int *)&arg_y) != TCL_OK) {
return TCL_ERROR;
}
int16_t arg_radius;
if (Tcl_GetIntFromObj(interp, objv[3], (int *)&arg_radius) != TCL_OK) {
return TCL_ERROR;
}
uint8_t arg_r;
if (Tcl_GetIntFromObj(interp, objv[4], (int *)&arg_r) != TCL_OK) {
return TCL_ERROR;
}
uint8_t arg_g;
if (Tcl_GetIntFromObj(interp, objv[5], (int *)&arg_g) != TCL_OK) {
return TCL_ERROR;
}
uint8_t arg_b;
if (Tcl_GetIntFromObj(interp, objv[6], (int *)&arg_b) != TCL_OK) {
return TCL_ERROR;
}
uint8_t arg_a;
if (Tcl_GetIntFromObj(interp, objv[7], (int *)&arg_a) != TCL_OK) {
return TCL_ERROR;
}
draw_circleFilled(GlobalesContext, arg_x, arg_y, arg_radius, arg_r, arg_g, arg_b, arg_a);
return TCL_OK;
}
////////////////////////////////////////////////////
// ::bonjour::register command
////////////////////////////////////////////////////
static int bonjour_register(
ClientData clientData,
Tcl_Interp *interp,
int objc,
Tcl_Obj *const objv[]
) {
const char *serviceName = NULL;
const char *regtype = NULL;
unsigned int port;
active_registration *activeRegister;
Tcl_HashTable *registerRegistrations = (Tcl_HashTable *)clientData;
Tcl_HashEntry *hashEntry;
int newFlag = 0;
uint16_t txtLen = 0;
void *txtRecord = NULL;
static const char *options[] = { "-name", "--", NULL };
enum optionIndex { OPT_NAME, OPT_END };
// parse options
int objIndex;
for(objIndex = 1; objIndex < objc; objIndex++) {
if(Tcl_GetString(objv[objIndex])[0] != '-') {
break;
}
int index;
if(Tcl_GetIndexFromObj(interp, objv[objIndex], options, "option", 0, &index) == TCL_ERROR) {
return TCL_ERROR;
}
if(index == OPT_NAME) {
objIndex++;
serviceName = Tcl_GetString(objv[objIndex]);
}
else if(index == OPT_END) {
objIndex++;
break;
}
}
int numArgs = objc - objIndex;
if(numArgs < 2 || numArgs > 3)
{
Tcl_WrongNumArgs(interp, 1, objv, "?switches? <regtype> <port> ?txt-record-list?");
return(TCL_ERROR);
}
// retrieve the registration type (service name)
regtype = Tcl_GetString(objv[objIndex]);
// retrieve the port number
if(Tcl_GetIntFromObj(interp, objv[objIndex + 1], (int *)&port) != TCL_OK)
return TCL_ERROR;
// retrieve the txt record list, if applicable
if(numArgs == 3)
{
list2txt(objv[objIndex + 2], &txtLen, &txtRecord);
}
// attempt to create an entry in the hash table
// for this regtype
hashEntry =
Tcl_CreateHashEntry(registerRegistrations, regtype, &newFlag);
// if an entry already exists, return an error
if(!newFlag) {
Tcl_Obj *errorMsg = Tcl_NewStringObj(NULL, 0);
Tcl_AppendStringsToObj(
errorMsg, "regtype ", regtype, " is already registered", NULL);
Tcl_SetObjResult(interp, errorMsg);
return(TCL_ERROR);
}
// create the activeRegister structure
activeRegister = (active_registration *)ckalloc(sizeof(active_registration));
activeRegister->regtype = (char *)ckalloc(strlen(regtype) + 1);
strcpy(activeRegister->regtype, regtype);
// store the activeRegister structure
Tcl_SetHashValue(hashEntry, activeRegister);
DNSServiceErrorType error =
DNSServiceRegister(&activeRegister->sdRef,
0, 0,
serviceName, regtype,
NULL, NULL,
htons((uint16_t)port),
txtLen, txtRecord, // txt record stuff
NULL, NULL); // callback stuff
// free the txt record
ckfree(txtRecord);
if(error != kDNSServiceErr_NoError)
{
ckfree(activeRegister->regtype);
ckfree((void *)activeRegister);
Tcl_DeleteHashEntry(hashEntry);
Tcl_SetObjResult(interp, create_dnsservice_error(interp, "DNSServiceRegister", error));
return TCL_ERROR;
}
return TCL_OK;
}
CommandDef (get, clientData, interp, objc, objv)
{
Handle *handle;
if (objc < 2)
{
Tcl_WrongNumArgs (interp, 1, objv, "filename ?key ...?");
return TCL_ERROR;
}
if (DbfGetHandleFromObj (interp, objv[1], &handle) != TCL_OK)
{
return TCL_ERROR;
}
switch (objc)
{
case 2:
{
DBFHandle dbfHandle;
int fieldCount, i;
Tcl_Obj *listPtr;
Tcl_Obj *resultPtr;
dbfHandle = handle->dbfHandle;
fieldCount = DBFGetFieldCount (dbfHandle);
resultPtr = Tcl_GetObjResult (interp);
for (i = 0; i < fieldCount; i++)
{
if (Tcl_ListObjAppendElement
(interp, resultPtr, Dbf_NewFieldObj (dbfHandle, i)) != TCL_OK)
{
return TCL_ERROR;
}
listPtr = Tcl_NewObj ();
if (ListObjAppendField (interp, listPtr, dbfHandle, i) != TCL_OK)
{
return TCL_ERROR;
}
if (Tcl_ListObjAppendElement (interp, resultPtr, listPtr) != TCL_OK)
{
return TCL_ERROR;
}
}
}
break;
case 3:
{
DBFHandle dbfHandle;
int index;
Tcl_Obj *resultPtr;
dbfHandle = handle->dbfHandle;
if (DbfGetFieldIndexFromObj (interp, dbfHandle, objv[2], &index) !=
TCL_OK)
{
return TCL_ERROR;
}
resultPtr = Tcl_GetObjResult (interp);
if (ListObjAppendField (interp, resultPtr, dbfHandle, index) != TCL_OK)
{
return TCL_ERROR;
}
}
break;
case 4:
{
DBFHandle dbfHandle;
int fieldIndex, recordIndex;
Tcl_Obj *resultPtr;
dbfHandle = handle->dbfHandle;
if (DbfGetFieldIndexFromObj (interp, dbfHandle, objv[2], &fieldIndex) !=
TCL_OK)
{
return TCL_ERROR;
}
if (Tcl_GetIntFromObj (interp, objv[3], &recordIndex) != TCL_OK)
{
return TCL_ERROR;
}
resultPtr = Tcl_GetObjResult (interp);
SetAttributeObj (resultPtr, dbfHandle, recordIndex, fieldIndex);
break;
}
default:
Tcl_SetResult (interp, "missing value to go with key", TCL_STATIC);
Tcl_SetErrorCode (interp, "DBF", "VALUE", "DICTIONARY", NULL);
return TCL_ERROR;
}
return TCL_OK;
}
/**
Translate one key value pair into an opts entry.
Note that caller is responsible for copying any strings.
*/
static inline int
rule_opt_from_kv(Tcl_Interp* interp, Tcl_Obj *const objv[],
struct rule_opts* opts, Tcl_Obj* key, Tcl_Obj* val)
{
char* k = Tcl_GetString(key);
int rc;
switch (k[0])
{
case 'a':
if (strcmp(k, "accuracy") == 0)
{
return adlb_parse_accuracy(interp, val, &opts->opts.accuracy);
}
break;
case 'n':
if (strcmp(k, "name") == 0)
{
opts->name = Tcl_GetString(val);
return TCL_OK;
// printf("name: %s\n", opts->name);
}
break;
case 'p':
if (strcmp(k, "parallelism") == 0)
{
int t;
rc = Tcl_GetIntFromObj(interp, val, &t);
TCL_CHECK_MSG(rc, "parallelism argument must be integer");
opts->opts.parallelism = t;
return TCL_OK;
}
break;
case 't':
if (strcmp(k, "target") == 0)
{
int t;
rc = Tcl_GetIntFromObj(interp, val, &t);
TCL_CHECK_MSG(rc, "target argument must be integer");
opts->target = t;
return TCL_OK;
}
else if (strcmp(k, "type") == 0)
{
int t;
rc = Tcl_GetIntFromObj(interp, val, &t);
TCL_CHECK_MSG(rc, "type argument must be integer");
if (t == TURBINE_ADLB_WORK_TYPE_LOCAL)
{
// Ensure sent back here
opts->work_type = TURBINE_ADLB_WORK_TYPE_WORK;
opts->target = adlb_comm_rank;
opts->opts.strictness = ADLB_TGT_STRICT_HARD;
}
else
{
opts->work_type = t;
}
return TCL_OK;
}
break;
case 's':
if (strcmp(k, "strictness") == 0)
{
return adlb_parse_strictness(interp, val, &opts->opts.strictness);
}
break;
}
TCL_RETURN_ERROR("rule options: unknown key: %s", k);
return TCL_ERROR; // unreachable
}
static
int
GetPixelsFromObjEx(
Tcl_Interp *interp, /* Used for error reporting if not NULL. */
Tk_Window tkwin,
Tcl_Obj *objPtr, /* The object from which to get pixels. */
int *intPtr,
double *dblPtr) /* Places to store resulting pixels. */
{
int result, fresh;
double d;
PixelRep *pixelPtr;
static double bias[] = {
1.0, 10.0, 25.4, 0.35278 /*25.4 / 72.0*/
};
/*
* Special hacks where the type of the object is known to be something
* that is just numeric and cannot require distance conversion. This pokes
* holes in Tcl's abstractions, but they are just for optimization, not
* semantics.
*/
if (objPtr->typePtr != &pixelObjType) {
ThreadSpecificData *typeCache = GetTypeCache();
if (objPtr->typePtr == typeCache->doubleTypePtr) {
(void) Tcl_GetDoubleFromObj(interp, objPtr, &d);
if (dblPtr != NULL) {
*dblPtr = d;
}
*intPtr = (int) (d<0 ? d-0.5 : d+0.5);
return TCL_OK;
} else if (objPtr->typePtr == typeCache->intTypePtr) {
(void) Tcl_GetIntFromObj(interp, objPtr, intPtr);
if (dblPtr) {
*dblPtr = (double) (*intPtr);
}
return TCL_OK;
}
}
retry:
fresh = (objPtr->typePtr != &pixelObjType);
if (fresh) {
result = SetPixelFromAny(interp, objPtr);
if (result != TCL_OK) {
return result;
}
}
if (SIMPLE_PIXELREP(objPtr)) {
*intPtr = GET_SIMPLEPIXEL(objPtr);
if (dblPtr) {
*dblPtr = (double) (*intPtr);
}
} else {
pixelPtr = GET_COMPLEXPIXEL(objPtr);
if ((!fresh) && (pixelPtr->tkwin != tkwin)) {
/*
* In the case of exo-screen conversions of non-pixels, we force a
* recomputation from the string.
*/
FreePixelInternalRep(objPtr);
goto retry;
}
if ((pixelPtr->tkwin != tkwin) || dblPtr) {
d = pixelPtr->value;
if (pixelPtr->units >= 0) {
d *= bias[pixelPtr->units] * WidthOfScreen(Tk_Screen(tkwin));
d /= WidthMMOfScreen(Tk_Screen(tkwin));
}
pixelPtr->returnValue = (int) (d<0 ? d-0.5 : d+0.5);
pixelPtr->tkwin = tkwin;
if (dblPtr) {
*dblPtr = d;
}
}
*intPtr = pixelPtr->returnValue;
}
return TCL_OK;
}
int
Tcl_ParseArgsObjv(
Tcl_Interp *interp, /* Place to store error message. */
const Tcl_ArgvInfo *argTable,
/* Array of option descriptions. */
int *objcPtr, /* Number of arguments in objv. Modified to
* hold # args left in objv at end. */
Tcl_Obj *const *objv, /* Array of arguments to be parsed. */
Tcl_Obj ***remObjv) /* Pointer to array of arguments that were not
* processed here. Should be NULL if no return
* of arguments is desired. */
{
Tcl_Obj **leftovers; /* Array to write back to remObjv on
* successful exit. Will include the name of
* the command. */
int nrem; /* Size of leftovers.*/
register const Tcl_ArgvInfo *infoPtr;
/* Pointer to the current entry in the table
* of argument descriptions. */
const Tcl_ArgvInfo *matchPtr;
/* Descriptor that matches current argument */
Tcl_Obj *curArg; /* Current argument */
const char *str = NULL;
register char c; /* Second character of current arg (used for
* quick check for matching; use 2nd char.
* because first char. will almost always be
* '-'). */
int srcIndex; /* Location from which to read next argument
* from objv. */
int dstIndex; /* Used to keep track of current arguments
* being processed, primarily for error
* reporting. */
int objc; /* # arguments in objv still to process. */
int length; /* Number of characters in current argument */
if (remObjv != NULL) {
/*
* Then we should copy the name of the command (0th argument). The
* upper bound on the number of elements is known, and (undocumented,
* but historically true) there should be a NULL argument after the
* last result. [Bug 3413857]
*/
nrem = 1;
leftovers = ckalloc((1 + *objcPtr) * sizeof(Tcl_Obj *));
leftovers[0] = objv[0];
} else {
nrem = 0;
leftovers = NULL;
}
/*
* OK, now start processing from the second element (1st argument).
*/
srcIndex = dstIndex = 1;
objc = *objcPtr-1;
while (objc > 0) {
curArg = objv[srcIndex];
srcIndex++;
objc--;
str = Tcl_GetStringFromObj(curArg, &length);
if (length > 0) {
c = str[1];
} else {
c = 0;
}
/*
* Loop throught the argument descriptors searching for one with the
* matching key string. If found, leave a pointer to it in matchPtr.
*/
matchPtr = NULL;
infoPtr = argTable;
for (; infoPtr != NULL && infoPtr->type != TCL_ARGV_END ; infoPtr++) {
if (infoPtr->keyStr == NULL) {
continue;
}
if ((infoPtr->keyStr[1] != c)
|| (strncmp(infoPtr->keyStr, str, length) != 0)) {
continue;
}
if (infoPtr->keyStr[length] == 0) {
matchPtr = infoPtr;
goto gotMatch;
}
if (matchPtr != NULL) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"ambiguous option \"%s\"", str));
goto error;
}
matchPtr = infoPtr;
}
if (matchPtr == NULL) {
/*
* Unrecognized argument. Just copy it down, unless the caller
* prefers an error to be registered.
*/
if (remObjv == NULL) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"unrecognized argument \"%s\"", str));
goto error;
}
dstIndex++; /* This argument is now handled */
leftovers[nrem++] = curArg;
continue;
}
/*
* Take the appropriate action based on the option type
*/
gotMatch:
infoPtr = matchPtr;
switch (infoPtr->type) {
case TCL_ARGV_CONSTANT:
*((int *) infoPtr->dstPtr) = PTR2INT(infoPtr->srcPtr);
break;
case TCL_ARGV_INT:
if (objc == 0) {
goto missingArg;
}
if (Tcl_GetIntFromObj(interp, objv[srcIndex],
(int *) infoPtr->dstPtr) == TCL_ERROR) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"expected integer argument for \"%s\" but got \"%s\"",
infoPtr->keyStr, Tcl_GetString(objv[srcIndex])));
goto error;
}
srcIndex++;
objc--;
break;
case TCL_ARGV_STRING:
if (objc == 0) {
goto missingArg;
}
*((const char **) infoPtr->dstPtr) =
Tcl_GetString(objv[srcIndex]);
srcIndex++;
objc--;
break;
case TCL_ARGV_REST:
/*
* Only store the point where we got to if it's not to be written
* to NULL, so that TCL_ARGV_AUTO_REST works.
*/
if (infoPtr->dstPtr != NULL) {
*((int *) infoPtr->dstPtr) = dstIndex;
}
goto argsDone;
case TCL_ARGV_FLOAT:
if (objc == 0) {
goto missingArg;
}
if (Tcl_GetDoubleFromObj(interp, objv[srcIndex],
(double *) infoPtr->dstPtr) == TCL_ERROR) {
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"expected floating-point argument for \"%s\" but got \"%s\"",
infoPtr->keyStr, Tcl_GetString(objv[srcIndex])));
goto error;
}
srcIndex++;
objc--;
break;
case TCL_ARGV_FUNC: {
Tcl_ArgvFuncProc *handlerProc = (Tcl_ArgvFuncProc *)
infoPtr->srcPtr;
Tcl_Obj *argObj;
if (objc == 0) {
argObj = NULL;
} else {
argObj = objv[srcIndex];
}
if (handlerProc(infoPtr->clientData, argObj, infoPtr->dstPtr)) {
srcIndex++;
objc--;
}
break;
}
case TCL_ARGV_GENFUNC: {
Tcl_ArgvGenFuncProc *handlerProc = (Tcl_ArgvGenFuncProc *)
infoPtr->srcPtr;
objc = handlerProc(infoPtr->clientData, interp, objc,
&objv[srcIndex], infoPtr->dstPtr);
if (objc < 0) {
goto error;
}
break;
}
case TCL_ARGV_HELP:
PrintUsage(interp, argTable);
goto error;
default:
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"bad argument type %d in Tcl_ArgvInfo", infoPtr->type));
goto error;
}
}
/*
* If we broke out of the loop because of an OPT_REST argument, copy the
* remaining arguments down. Note that there is always at least one
* argument left over - the command name - so we always have a result if
* our caller is willing to receive it. [Bug 3413857]
*/
argsDone:
if (remObjv == NULL) {
/*
* Nothing to do.
*/
return TCL_OK;
}
if (objc > 0) {
memcpy(leftovers+nrem, objv+srcIndex, objc*sizeof(Tcl_Obj *));
nrem += objc;
}
leftovers[nrem] = NULL;
*objcPtr = nrem++;
*remObjv = ckrealloc(leftovers, nrem * sizeof(Tcl_Obj *));
return TCL_OK;
/*
* Make sure to handle freeing any temporary space we've allocated on the
* way to an error.
*/
missingArg:
Tcl_SetObjResult(interp, Tcl_ObjPrintf(
"\"%s\" option requires an additional argument", str));
error:
if (leftovers != NULL) {
ckfree(leftovers);
}
return TCL_ERROR;
}
static char *
LinkTraceProc(
ClientData clientData, /* Contains information about the link. */
Tcl_Interp *interp, /* Interpreter containing Tcl variable. */
CONST char *name1, /* First part of variable name. */
CONST char *name2, /* Second part of variable name. */
int flags) /* Miscellaneous additional information. */
{
Link *linkPtr = (Link *) clientData;
int changed, valueLength;
CONST char *value;
char **pp;
Tcl_Obj *valueObj;
int valueInt;
Tcl_WideInt valueWide;
double valueDouble;
/*
* If the variable is being unset, then just re-create it (with a trace)
* unless the whole interpreter is going away.
*/
if (flags & TCL_TRACE_UNSETS) {
if (Tcl_InterpDeleted(interp)) {
Tcl_DecrRefCount(linkPtr->varName);
ckfree((char *) linkPtr);
} else if (flags & TCL_TRACE_DESTROYED) {
Tcl_ObjSetVar2(interp, linkPtr->varName, NULL, ObjValue(linkPtr),
TCL_GLOBAL_ONLY);
Tcl_TraceVar(interp, Tcl_GetString(linkPtr->varName),
TCL_GLOBAL_ONLY|TCL_TRACE_READS|TCL_TRACE_WRITES
|TCL_TRACE_UNSETS, LinkTraceProc, (ClientData) linkPtr);
}
return NULL;
}
/*
* If we were invoked because of a call to Tcl_UpdateLinkedVar, then don't
* do anything at all. In particular, we don't want to get upset that the
* variable is being modified, even if it is supposed to be read-only.
*/
if (linkPtr->flags & LINK_BEING_UPDATED) {
return NULL;
}
/*
* For read accesses, update the Tcl variable if the C variable has
* changed since the last time we updated the Tcl variable.
*/
if (flags & TCL_TRACE_READS) {
switch (linkPtr->type) {
case TCL_LINK_INT:
case TCL_LINK_BOOLEAN:
changed = (LinkedVar(int) != linkPtr->lastValue.i);
break;
case TCL_LINK_DOUBLE:
changed = (LinkedVar(double) != linkPtr->lastValue.d);
break;
case TCL_LINK_WIDE_INT:
changed = (LinkedVar(Tcl_WideInt) != linkPtr->lastValue.w);
break;
case TCL_LINK_WIDE_UINT:
changed = (LinkedVar(Tcl_WideUInt) != linkPtr->lastValue.uw);
break;
case TCL_LINK_CHAR:
changed = (LinkedVar(char) != linkPtr->lastValue.c);
break;
case TCL_LINK_UCHAR:
changed = (LinkedVar(unsigned char) != linkPtr->lastValue.uc);
break;
case TCL_LINK_SHORT:
changed = (LinkedVar(short) != linkPtr->lastValue.s);
break;
case TCL_LINK_USHORT:
changed = (LinkedVar(unsigned short) != linkPtr->lastValue.us);
break;
case TCL_LINK_UINT:
changed = (LinkedVar(unsigned int) != linkPtr->lastValue.ui);
break;
case TCL_LINK_LONG:
changed = (LinkedVar(long) != linkPtr->lastValue.l);
break;
case TCL_LINK_ULONG:
changed = (LinkedVar(unsigned long) != linkPtr->lastValue.ul);
break;
case TCL_LINK_FLOAT:
changed = (LinkedVar(float) != linkPtr->lastValue.f);
break;
case TCL_LINK_STRING:
changed = 1;
break;
default:
return "internal error: bad linked variable type";
}
if (changed) {
Tcl_ObjSetVar2(interp, linkPtr->varName, NULL, ObjValue(linkPtr),
TCL_GLOBAL_ONLY);
}
return NULL;
}
/*
* For writes, first make sure that the variable is writable. Then convert
* the Tcl value to C if possible. If the variable isn't writable or can't
* be converted, then restore the varaible's old value and return an
* error. Another tricky thing: we have to save and restore the interp's
* result, since the variable access could occur when the result has been
* partially set.
*/
if (linkPtr->flags & LINK_READ_ONLY) {
Tcl_ObjSetVar2(interp, linkPtr->varName, NULL, ObjValue(linkPtr),
TCL_GLOBAL_ONLY);
return "linked variable is read-only";
}
valueObj = Tcl_ObjGetVar2(interp, linkPtr->varName,NULL, TCL_GLOBAL_ONLY);
if (valueObj == NULL) {
/*
* This shouldn't ever happen.
*/
return "internal error: linked variable couldn't be read";
}
switch (linkPtr->type) {
case TCL_LINK_INT:
if (Tcl_GetIntFromObj(NULL, valueObj, &linkPtr->lastValue.i)
!= TCL_OK) {
Tcl_ObjSetVar2(interp, linkPtr->varName, NULL, ObjValue(linkPtr),
TCL_GLOBAL_ONLY);
return "variable must have integer value";
}
LinkedVar(int) = linkPtr->lastValue.i;
break;
case TCL_LINK_WIDE_INT:
if (Tcl_GetWideIntFromObj(NULL, valueObj, &linkPtr->lastValue.w)
!= TCL_OK) {
Tcl_ObjSetVar2(interp, linkPtr->varName, NULL, ObjValue(linkPtr),
TCL_GLOBAL_ONLY);
return "variable must have integer value";
}
LinkedVar(Tcl_WideInt) = linkPtr->lastValue.w;
break;
case TCL_LINK_DOUBLE:
if (Tcl_GetDoubleFromObj(NULL, valueObj, &linkPtr->lastValue.d)
!= TCL_OK) {
#ifdef ACCEPT_NAN
if (valueObj->typePtr != &tclDoubleType) {
#endif
Tcl_ObjSetVar2(interp, linkPtr->varName, NULL,
ObjValue(linkPtr), TCL_GLOBAL_ONLY);
return "variable must have real value";
#ifdef ACCEPT_NAN
}
linkPtr->lastValue.d = valueObj->internalRep.doubleValue;
#endif
}
LinkedVar(double) = linkPtr->lastValue.d;
break;
case TCL_LINK_BOOLEAN:
if (Tcl_GetBooleanFromObj(NULL, valueObj, &linkPtr->lastValue.i)
!= TCL_OK) {
Tcl_ObjSetVar2(interp, linkPtr->varName, NULL, ObjValue(linkPtr),
TCL_GLOBAL_ONLY);
return "variable must have boolean value";
}
LinkedVar(int) = linkPtr->lastValue.i;
break;
case TCL_LINK_CHAR:
if (Tcl_GetIntFromObj(interp, valueObj, &valueInt) != TCL_OK
|| valueInt < SCHAR_MIN || valueInt > SCHAR_MAX) {
Tcl_ObjSetVar2(interp, linkPtr->varName, NULL, ObjValue(linkPtr),
TCL_GLOBAL_ONLY);
return "variable must have char value";
}
linkPtr->lastValue.c = (char)valueInt;
LinkedVar(char) = linkPtr->lastValue.c;
break;
case TCL_LINK_UCHAR:
if (Tcl_GetIntFromObj(interp, valueObj, &valueInt) != TCL_OK
|| valueInt < 0 || valueInt > UCHAR_MAX) {
Tcl_ObjSetVar2(interp, linkPtr->varName, NULL, ObjValue(linkPtr),
TCL_GLOBAL_ONLY);
return "variable must have unsigned char value";
}
linkPtr->lastValue.uc = (unsigned char) valueInt;
LinkedVar(unsigned char) = linkPtr->lastValue.uc;
break;
case TCL_LINK_SHORT:
if (Tcl_GetIntFromObj(interp, valueObj, &valueInt) != TCL_OK
|| valueInt < SHRT_MIN || valueInt > SHRT_MAX) {
Tcl_ObjSetVar2(interp, linkPtr->varName, NULL, ObjValue(linkPtr),
TCL_GLOBAL_ONLY);
return "variable must have short value";
}
linkPtr->lastValue.s = (short)valueInt;
LinkedVar(short) = linkPtr->lastValue.s;
break;
case TCL_LINK_USHORT:
if (Tcl_GetIntFromObj(interp, valueObj, &valueInt) != TCL_OK
|| valueInt < 0 || valueInt > USHRT_MAX) {
Tcl_ObjSetVar2(interp, linkPtr->varName, NULL, ObjValue(linkPtr),
TCL_GLOBAL_ONLY);
return "variable must have unsigned short value";
}
linkPtr->lastValue.us = (unsigned short)valueInt;
LinkedVar(unsigned short) = linkPtr->lastValue.us;
break;
case TCL_LINK_UINT:
if (Tcl_GetWideIntFromObj(interp, valueObj, &valueWide) != TCL_OK
|| valueWide < 0 || valueWide > UINT_MAX) {
Tcl_ObjSetVar2(interp, linkPtr->varName, NULL, ObjValue(linkPtr),
TCL_GLOBAL_ONLY);
return "variable must have unsigned int value";
}
linkPtr->lastValue.ui = (unsigned int)valueWide;
LinkedVar(unsigned int) = linkPtr->lastValue.ui;
break;
case TCL_LINK_LONG:
if (Tcl_GetWideIntFromObj(interp, valueObj, &valueWide) != TCL_OK
|| valueWide < LONG_MIN || valueWide > LONG_MAX) {
Tcl_ObjSetVar2(interp, linkPtr->varName, NULL, ObjValue(linkPtr),
TCL_GLOBAL_ONLY);
return "variable must have long value";
}
linkPtr->lastValue.l = (long)valueWide;
LinkedVar(long) = linkPtr->lastValue.l;
break;
case TCL_LINK_ULONG:
if (Tcl_GetWideIntFromObj(interp, valueObj, &valueWide) != TCL_OK
|| valueWide < 0 || (Tcl_WideUInt) valueWide > ULONG_MAX) {
Tcl_ObjSetVar2(interp, linkPtr->varName, NULL, ObjValue(linkPtr),
TCL_GLOBAL_ONLY);
return "variable must have unsigned long value";
}
linkPtr->lastValue.ul = (unsigned long)valueWide;
LinkedVar(unsigned long) = linkPtr->lastValue.ul;
break;
case TCL_LINK_WIDE_UINT:
/*
* FIXME: represent as a bignum.
*/
if (Tcl_GetWideIntFromObj(interp, valueObj, &valueWide) != TCL_OK) {
Tcl_ObjSetVar2(interp, linkPtr->varName, NULL, ObjValue(linkPtr),
TCL_GLOBAL_ONLY);
return "variable must have unsigned wide int value";
}
linkPtr->lastValue.uw = (Tcl_WideUInt)valueWide;
LinkedVar(Tcl_WideUInt) = linkPtr->lastValue.uw;
break;
case TCL_LINK_FLOAT:
if (Tcl_GetDoubleFromObj(interp, valueObj, &valueDouble) != TCL_OK
|| valueDouble < -FLT_MAX || valueDouble > FLT_MAX) {
Tcl_ObjSetVar2(interp, linkPtr->varName, NULL, ObjValue(linkPtr),
TCL_GLOBAL_ONLY);
return "variable must have float value";
}
linkPtr->lastValue.f = (float)valueDouble;
LinkedVar(float) = linkPtr->lastValue.f;
break;
case TCL_LINK_STRING:
value = Tcl_GetStringFromObj(valueObj, &valueLength);
valueLength++;
pp = (char **) linkPtr->addr;
*pp = ckrealloc(*pp, valueLength);
memcpy(*pp, value, (unsigned) valueLength);
break;
default:
return "internal error: bad linked variable type";
}
return NULL;
}
static int
TestlistobjCmd(
ClientData clientData, /* Not used */
Tcl_Interp *interp, /* Tcl interpreter */
int objc, /* Number of arguments */
Tcl_Obj *const objv[]) /* Argument objects */
{
/* Subcommands supported by this command */
const char* subcommands[] = {
"set",
"get",
"replace"
};
enum listobjCmdIndex {
LISTOBJ_SET,
LISTOBJ_GET,
LISTOBJ_REPLACE
};
const char* index; /* Argument giving the variable number */
int varIndex; /* Variable number converted to binary */
int cmdIndex; /* Ordinal number of the subcommand */
int first; /* First index in the list */
int count; /* Count of elements in a list */
if (objc < 3) {
Tcl_WrongNumArgs(interp, 1, objv, "option arg ?arg...?");
return TCL_ERROR;
}
index = Tcl_GetString(objv[2]);
if (GetVariableIndex(interp, index, &varIndex) != TCL_OK) {
return TCL_ERROR;
}
if (Tcl_GetIndexFromObj(interp, objv[1], subcommands, "command",
0, &cmdIndex) != TCL_OK) {
return TCL_ERROR;
}
switch(cmdIndex) {
case LISTOBJ_SET:
if ((varPtr[varIndex] != NULL) && !Tcl_IsShared(varPtr[varIndex])) {
Tcl_SetListObj(varPtr[varIndex], objc-3, objv+3);
} else {
SetVarToObj(varIndex, Tcl_NewListObj(objc-3, objv+3));
}
Tcl_SetObjResult(interp, varPtr[varIndex]);
break;
case LISTOBJ_GET:
if (objc != 3) {
Tcl_WrongNumArgs(interp, 2, objv, "varIndex");
return TCL_ERROR;
}
if (CheckIfVarUnset(interp, varIndex)) {
return TCL_ERROR;
}
Tcl_SetObjResult(interp, varPtr[varIndex]);
break;
case LISTOBJ_REPLACE:
if (objc < 5) {
Tcl_WrongNumArgs(interp, 2, objv,
"varIndex start count ?element...?");
return TCL_ERROR;
}
if (Tcl_GetIntFromObj(interp, objv[3], &first) != TCL_OK
|| Tcl_GetIntFromObj(interp, objv[4], &count) != TCL_OK) {
return TCL_ERROR;
}
if (Tcl_IsShared(varPtr[varIndex])) {
SetVarToObj(varIndex, Tcl_DuplicateObj(varPtr[varIndex]));
}
Tcl_ResetResult(interp);
return Tcl_ListObjReplace(interp, varPtr[varIndex], first, count,
objc-5, objv+5);
}
return TCL_OK;
}
/*************************************************************************
* FUNCTION : RPMPRoblem_ObjL::Problem *
* ARGUMENTS : interp, tcl args, *
* Problem object *
* index in objv of first tag we need *
* RETURNS : 0 if OK, else error *
* EXCEPTIONS : none *
* PURPOSE : Manipulate a problem entry *
* NOTES : format for this is *
* RPM [<prob>] [part [value]]* *
* where <prob> is an existing problem object - if not given, then the *
* command will create a new problem object. *
* [part] is one of the defined problem tags for a problem *
* [value] if given will set the defined part *
* *
* *
*************************************************************************/
int RPMPRoblem_Obj::Problem(Tcl_Interp *interp,int objc, Tcl_Obj *const objv[],
Tcl_Obj *prob,int first_tag
)
{
// Now, we have one of 2 possibilities here - they gave us a single tag
// to query, or a list of (tag,value) pairs
if (objc == (first_tag+1))
{
// Single tag - return the value of the tag.
int which = 0;
if (Tcl_GetIndexFromObj(interp,objv[first_tag],prob_parts,"tag",0,&which) != TCL_OK)
return TCL_ERROR;
Tcl_SetObjResult(interp,Get_part((PARTS)which)); // Return value to TCL
return TCL_OK;
}
Tcl_InvalidateStringRep(prob);
// OK, so this should be a set of (tag,value) pairs - parse them
for (int i = first_tag; i < objc; i += 2)
{
// Make sure we actually HAVE a value
if ((i+1)>objc)
return Cmd_base::Error(interp,"Need a value");
// what tag is it?
int which = 0;
if (Tcl_GetIndexFromObj(interp,objv[i],prob_parts,"tag",0,&which) != TCL_OK)
return TCL_ERROR;
switch ((PARTS)which)
{
case PACKAGE:
{
int len = 0;
char *x = Tcl_GetStringFromObj(objv[i+1],&len);
char *p = new char[len+1];
strncpy(p,x,len);
p[len] = 0;
if (problem.pkgNEVR)
delete [] problem.pkgNEVR;
problem.pkgNEVR = p;
}
break;
case ALT:
{
int len = 0;
char *x = Tcl_GetStringFromObj(objv[i+1],&len);
char *p = new char[len+1];
strncpy(p,x,len);
p[len] = 0;
if (problem.altNEVR)
delete [] problem.altNEVR;
problem.altNEVR = p;
}
break;
case KEY:
{
int value = 0;
if (Tcl_GetIntFromObj(interp,objv[i+1],&value) != TCL_OK)
return TCL_ERROR;
problem.key = (fnpyKey)value;
}
break;
case TYPE:
{
int which = 0;
if (Tcl_GetIndexFromObjStruct(interp,objv[i+1],(char **)&prob_strings[0].name,sizeof(prob_strings[0]),
"type",0,&which
) != TCL_OK)
return TCL_ERROR;
problem.type = (rpmProblemType)prob_strings[which].code;
}
break;
case IGNORE:
{
int value = 0;
if (Tcl_GetIntFromObj(interp,objv[i+1],&value) != TCL_OK)
return TCL_ERROR;
problem.ignoreProblem = value;
}
break;
case STRING:
{
int len = 0;
char *x = Tcl_GetStringFromObj(objv[i+1],&len);
char *p = new char[len+1];
strncpy(p,x,len);
p[len] = 0;
if (problem.str1)
delete [] problem.str1;
problem.str1 = p;
}
break;
case INT:
{
int value = 0;
if (Tcl_GetIntFromObj(interp,objv[i+1],&value) != TCL_OK)
return TCL_ERROR;
problem.ulong1 = value;
}
break;
}
}
Tcl_SetObjResult(interp,prob); // Return value to TCL
return TCL_OK;
}
static int
TestindexobjCmd(
ClientData clientData, /* Not used. */
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
{
int allowAbbrev, index, index2, setError, i, result;
const char **argv;
static const char *const tablePtr[] = {"a", "b", "check", NULL};
/*
* Keep this structure declaration in sync with tclIndexObj.c
*/
struct IndexRep {
void *tablePtr; /* Pointer to the table of strings. */
int offset; /* Offset between table entries. */
int index; /* Selected index into table. */
};
struct IndexRep *indexRep;
if ((objc == 3) && (strcmp(Tcl_GetString(objv[1]),
"check") == 0)) {
/*
* This code checks to be sure that the results of Tcl_GetIndexFromObj
* are properly cached in the object and returned on subsequent
* lookups.
*/
if (Tcl_GetIntFromObj(interp, objv[2], &index2) != TCL_OK) {
return TCL_ERROR;
}
Tcl_GetIndexFromObj(NULL, objv[1], tablePtr, "token", 0, &index);
indexRep = (struct IndexRep *) objv[1]->internalRep.otherValuePtr;
indexRep->index = index2;
result = Tcl_GetIndexFromObj(NULL, objv[1],
tablePtr, "token", 0, &index);
if (result == TCL_OK) {
Tcl_SetIntObj(Tcl_GetObjResult(interp), index);
}
return result;
}
if (objc < 5) {
Tcl_AppendToObj(Tcl_GetObjResult(interp), "wrong # args", -1);
return TCL_ERROR;
}
if (Tcl_GetBooleanFromObj(interp, objv[1], &setError) != TCL_OK) {
return TCL_ERROR;
}
if (Tcl_GetBooleanFromObj(interp, objv[2], &allowAbbrev) != TCL_OK) {
return TCL_ERROR;
}
argv = (const char **) ckalloc((unsigned) ((objc-3) * sizeof(char *)));
for (i = 4; i < objc; i++) {
argv[i-4] = Tcl_GetString(objv[i]);
}
argv[objc-4] = NULL;
/*
* Tcl_GetIndexFromObj assumes that the table is statically-allocated so
* that its address is different for each index object. If we accidently
* allocate a table at the same address as that cached in the index
* object, clear out the object's cached state.
*/
if (objv[3]->typePtr != NULL
&& !strcmp("index", objv[3]->typePtr->name)) {
indexRep = (struct IndexRep *) objv[3]->internalRep.otherValuePtr;
if (indexRep->tablePtr == (void *) argv) {
objv[3]->typePtr->freeIntRepProc(objv[3]);
objv[3]->typePtr = NULL;
}
}
result = Tcl_GetIndexFromObj((setError? interp : NULL), objv[3],
argv, "token", (allowAbbrev? 0 : TCL_EXACT), &index);
ckfree((char *) argv);
if (result == TCL_OK) {
Tcl_SetIntObj(Tcl_GetObjResult(interp), index);
}
return result;
}
static int
TestintobjCmd(
ClientData clientData, /* Not used. */
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
{
int intValue, varIndex, i;
long longValue;
const char *index, *subCmd, *string;
if (objc < 3) {
wrongNumArgs:
Tcl_WrongNumArgs(interp, 1, objv, "option arg ?arg ...?");
return TCL_ERROR;
}
index = Tcl_GetString(objv[2]);
if (GetVariableIndex(interp, index, &varIndex) != TCL_OK) {
return TCL_ERROR;
}
subCmd = Tcl_GetString(objv[1]);
if (strcmp(subCmd, "set") == 0) {
if (objc != 4) {
goto wrongNumArgs;
}
string = Tcl_GetString(objv[3]);
if (Tcl_GetInt(interp, string, &i) != TCL_OK) {
return TCL_ERROR;
}
intValue = i;
/*
* If the object currently bound to the variable with index varIndex
* has ref count 1 (i.e. the object is unshared) we can modify that
* object directly. Otherwise, if RC>1 (i.e. the object is shared), we
* must create a new object to modify/set and decrement the old
* formerly-shared object's ref count. This is "copy on write".
*/
if ((varPtr[varIndex] != NULL) && !Tcl_IsShared(varPtr[varIndex])) {
Tcl_SetIntObj(varPtr[varIndex], intValue);
} else {
SetVarToObj(varIndex, Tcl_NewIntObj(intValue));
}
Tcl_SetObjResult(interp, varPtr[varIndex]);
} else if (strcmp(subCmd, "set2") == 0) { /* doesn't set result */
if (objc != 4) {
goto wrongNumArgs;
}
string = Tcl_GetString(objv[3]);
if (Tcl_GetInt(interp, string, &i) != TCL_OK) {
return TCL_ERROR;
}
intValue = i;
if ((varPtr[varIndex] != NULL) && !Tcl_IsShared(varPtr[varIndex])) {
Tcl_SetIntObj(varPtr[varIndex], intValue);
} else {
SetVarToObj(varIndex, Tcl_NewIntObj(intValue));
}
} else if (strcmp(subCmd, "setlong") == 0) {
if (objc != 4) {
goto wrongNumArgs;
}
string = Tcl_GetString(objv[3]);
if (Tcl_GetInt(interp, string, &i) != TCL_OK) {
return TCL_ERROR;
}
intValue = i;
if ((varPtr[varIndex] != NULL) && !Tcl_IsShared(varPtr[varIndex])) {
Tcl_SetLongObj(varPtr[varIndex], intValue);
} else {
SetVarToObj(varIndex, Tcl_NewLongObj(intValue));
}
Tcl_SetObjResult(interp, varPtr[varIndex]);
} else if (strcmp(subCmd, "setmaxlong") == 0) {
long maxLong = LONG_MAX;
if (objc != 3) {
goto wrongNumArgs;
}
if ((varPtr[varIndex] != NULL) && !Tcl_IsShared(varPtr[varIndex])) {
Tcl_SetLongObj(varPtr[varIndex], maxLong);
} else {
SetVarToObj(varIndex, Tcl_NewLongObj(maxLong));
}
} else if (strcmp(subCmd, "ismaxlong") == 0) {
if (objc != 3) {
goto wrongNumArgs;
}
if (CheckIfVarUnset(interp, varIndex)) {
return TCL_ERROR;
}
if (Tcl_GetLongFromObj(interp, varPtr[varIndex], &longValue) != TCL_OK) {
return TCL_ERROR;
}
Tcl_AppendToObj(Tcl_GetObjResult(interp),
((longValue == LONG_MAX)? "1" : "0"), -1);
} else if (strcmp(subCmd, "get") == 0) {
if (objc != 3) {
goto wrongNumArgs;
}
if (CheckIfVarUnset(interp, varIndex)) {
return TCL_ERROR;
}
Tcl_SetObjResult(interp, varPtr[varIndex]);
} else if (strcmp(subCmd, "get2") == 0) {
if (objc != 3) {
goto wrongNumArgs;
}
if (CheckIfVarUnset(interp, varIndex)) {
return TCL_ERROR;
}
string = Tcl_GetString(varPtr[varIndex]);
Tcl_AppendToObj(Tcl_GetObjResult(interp), string, -1);
} else if (strcmp(subCmd, "inttoobigtest") == 0) {
/*
* If long ints have more bits than ints on this platform, verify that
* Tcl_GetIntFromObj returns an error if the long int held in an
* integer object's internal representation is too large to fit in an
* int.
*/
if (objc != 3) {
goto wrongNumArgs;
}
#if (INT_MAX == LONG_MAX) /* int is same size as long int */
Tcl_AppendToObj(Tcl_GetObjResult(interp), "1", -1);
#else
if ((varPtr[varIndex] != NULL) && !Tcl_IsShared(varPtr[varIndex])) {
Tcl_SetLongObj(varPtr[varIndex], LONG_MAX);
} else {
SetVarToObj(varIndex, Tcl_NewLongObj(LONG_MAX));
}
if (Tcl_GetIntFromObj(interp, varPtr[varIndex], &i) != TCL_OK) {
Tcl_ResetResult(interp);
Tcl_AppendToObj(Tcl_GetObjResult(interp), "1", -1);
return TCL_OK;
}
Tcl_AppendToObj(Tcl_GetObjResult(interp), "0", -1);
#endif
} else if (strcmp(subCmd, "mult10") == 0) {
if (objc != 3) {
goto wrongNumArgs;
}
if (CheckIfVarUnset(interp, varIndex)) {
return TCL_ERROR;
}
if (Tcl_GetIntFromObj(interp, varPtr[varIndex],
&intValue) != TCL_OK) {
return TCL_ERROR;
}
if (!Tcl_IsShared(varPtr[varIndex])) {
Tcl_SetIntObj(varPtr[varIndex], intValue * 10);
} else {
SetVarToObj(varIndex, Tcl_NewIntObj(intValue * 10));
}
Tcl_SetObjResult(interp, varPtr[varIndex]);
} else if (strcmp(subCmd, "div10") == 0) {
if (objc != 3) {
goto wrongNumArgs;
}
if (CheckIfVarUnset(interp, varIndex)) {
return TCL_ERROR;
}
if (Tcl_GetIntFromObj(interp, varPtr[varIndex],
&intValue) != TCL_OK) {
return TCL_ERROR;
}
if (!Tcl_IsShared(varPtr[varIndex])) {
Tcl_SetIntObj(varPtr[varIndex], intValue / 10);
} else {
SetVarToObj(varIndex, Tcl_NewIntObj(intValue / 10));
}
Tcl_SetObjResult(interp, varPtr[varIndex]);
} else {
Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
"bad option \"", Tcl_GetString(objv[1]),
"\": must be set, get, get2, mult10, or div10", NULL);
return TCL_ERROR;
}
return TCL_OK;
}
static int
TeststringobjCmd(
ClientData clientData, /* Not used. */
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
{
Tcl_UniChar *unicode;
int varIndex, option, i, length;
#define MAX_STRINGS 11
const char *index, *string, *strings[MAX_STRINGS+1];
TestString *strPtr;
static const char *const options[] = {
"append", "appendstrings", "get", "get2", "length", "length2",
"set", "set2", "setlength", "maxchars", "getunicode",
"appendself", "appendself2", NULL
};
if (objc < 3) {
wrongNumArgs:
Tcl_WrongNumArgs(interp, 1, objv, "option arg ?arg ...?");
return TCL_ERROR;
}
index = Tcl_GetString(objv[2]);
if (GetVariableIndex(interp, index, &varIndex) != TCL_OK) {
return TCL_ERROR;
}
if (Tcl_GetIndexFromObj(interp, objv[1], options, "option", 0, &option)
!= TCL_OK) {
return TCL_ERROR;
}
switch (option) {
case 0: /* append */
if (objc != 5) {
goto wrongNumArgs;
}
if (Tcl_GetIntFromObj(interp, objv[4], &length) != TCL_OK) {
return TCL_ERROR;
}
if (varPtr[varIndex] == NULL) {
SetVarToObj(varIndex, Tcl_NewObj());
}
/*
* If the object bound to variable "varIndex" is shared, we must
* "copy on write" and append to a copy of the object.
*/
if (Tcl_IsShared(varPtr[varIndex])) {
SetVarToObj(varIndex, Tcl_DuplicateObj(varPtr[varIndex]));
}
string = Tcl_GetString(objv[3]);
Tcl_AppendToObj(varPtr[varIndex], string, length);
Tcl_SetObjResult(interp, varPtr[varIndex]);
break;
case 1: /* appendstrings */
if (objc > (MAX_STRINGS+3)) {
goto wrongNumArgs;
}
if (varPtr[varIndex] == NULL) {
SetVarToObj(varIndex, Tcl_NewObj());
}
/*
* If the object bound to variable "varIndex" is shared, we must
* "copy on write" and append to a copy of the object.
*/
if (Tcl_IsShared(varPtr[varIndex])) {
SetVarToObj(varIndex, Tcl_DuplicateObj(varPtr[varIndex]));
}
for (i = 3; i < objc; i++) {
strings[i-3] = Tcl_GetString(objv[i]);
}
for ( ; i < 12 + 3; i++) {
strings[i - 3] = NULL;
}
Tcl_AppendStringsToObj(varPtr[varIndex], strings[0], strings[1],
strings[2], strings[3], strings[4], strings[5],
strings[6], strings[7], strings[8], strings[9],
strings[10], strings[11]);
Tcl_SetObjResult(interp, varPtr[varIndex]);
break;
case 2: /* get */
if (objc != 3) {
goto wrongNumArgs;
}
if (CheckIfVarUnset(interp, varIndex)) {
return TCL_ERROR;
}
Tcl_SetObjResult(interp, varPtr[varIndex]);
break;
case 3: /* get2 */
if (objc != 3) {
goto wrongNumArgs;
}
if (CheckIfVarUnset(interp, varIndex)) {
return TCL_ERROR;
}
string = Tcl_GetString(varPtr[varIndex]);
Tcl_AppendToObj(Tcl_GetObjResult(interp), string, -1);
break;
case 4: /* length */
if (objc != 3) {
goto wrongNumArgs;
}
Tcl_SetIntObj(Tcl_GetObjResult(interp), (varPtr[varIndex] != NULL)
? varPtr[varIndex]->length : -1);
break;
case 5: /* length2 */
if (objc != 3) {
goto wrongNumArgs;
}
if (varPtr[varIndex] != NULL) {
Tcl_ConvertToType(NULL, varPtr[varIndex],
Tcl_GetObjType("string"));
strPtr = (TestString *)
(varPtr[varIndex])->internalRep.otherValuePtr;
length = (int) strPtr->allocated;
} else {
length = -1;
}
Tcl_SetIntObj(Tcl_GetObjResult(interp), length);
break;
case 6: /* set */
if (objc != 4) {
goto wrongNumArgs;
}
/*
* If the object currently bound to the variable with index
* varIndex has ref count 1 (i.e. the object is unshared) we can
* modify that object directly. Otherwise, if RC>1 (i.e. the
* object is shared), we must create a new object to modify/set
* and decrement the old formerly-shared object's ref count. This
* is "copy on write".
*/
string = Tcl_GetStringFromObj(objv[3], &length);
if ((varPtr[varIndex] != NULL)
&& !Tcl_IsShared(varPtr[varIndex])) {
Tcl_SetStringObj(varPtr[varIndex], string, length);
} else {
SetVarToObj(varIndex, Tcl_NewStringObj(string, length));
}
Tcl_SetObjResult(interp, varPtr[varIndex]);
break;
case 7: /* set2 */
if (objc != 4) {
goto wrongNumArgs;
}
SetVarToObj(varIndex, objv[3]);
break;
case 8: /* setlength */
if (objc != 4) {
goto wrongNumArgs;
}
if (Tcl_GetIntFromObj(interp, objv[3], &length) != TCL_OK) {
return TCL_ERROR;
}
if (varPtr[varIndex] != NULL) {
Tcl_SetObjLength(varPtr[varIndex], length);
}
break;
case 9: /* maxchars */
if (objc != 3) {
goto wrongNumArgs;
}
if (varPtr[varIndex] != NULL) {
Tcl_ConvertToType(NULL, varPtr[varIndex],
Tcl_GetObjType("string"));
strPtr = (TestString *)
(varPtr[varIndex])->internalRep.otherValuePtr;
length = strPtr->maxChars;
} else {
length = -1;
}
Tcl_SetIntObj(Tcl_GetObjResult(interp), length);
break;
case 10: /* getunicode */
if (objc != 3) {
goto wrongNumArgs;
}
Tcl_GetUnicodeFromObj(varPtr[varIndex], NULL);
break;
case 11: /* appendself */
if (objc != 4) {
goto wrongNumArgs;
}
if (varPtr[varIndex] == NULL) {
SetVarToObj(varIndex, Tcl_NewObj());
}
/*
* If the object bound to variable "varIndex" is shared, we must
* "copy on write" and append to a copy of the object.
*/
if (Tcl_IsShared(varPtr[varIndex])) {
SetVarToObj(varIndex, Tcl_DuplicateObj(varPtr[varIndex]));
}
string = Tcl_GetStringFromObj(varPtr[varIndex], &length);
if (Tcl_GetIntFromObj(interp, objv[3], &i) != TCL_OK) {
return TCL_ERROR;
}
if ((i < 0) || (i > length)) {
Tcl_SetObjResult(interp, Tcl_NewStringObj(
"index value out of range", -1));
return TCL_ERROR;
}
Tcl_AppendToObj(varPtr[varIndex], string + i, length - i);
Tcl_SetObjResult(interp, varPtr[varIndex]);
break;
case 12: /* appendself2 */
if (objc != 4) {
goto wrongNumArgs;
}
if (varPtr[varIndex] == NULL) {
SetVarToObj(varIndex, Tcl_NewObj());
}
/*
* If the object bound to variable "varIndex" is shared, we must
* "copy on write" and append to a copy of the object.
*/
if (Tcl_IsShared(varPtr[varIndex])) {
SetVarToObj(varIndex, Tcl_DuplicateObj(varPtr[varIndex]));
}
unicode = Tcl_GetUnicodeFromObj(varPtr[varIndex], &length);
if (Tcl_GetIntFromObj(interp, objv[3], &i) != TCL_OK) {
return TCL_ERROR;
}
if ((i < 0) || (i > length)) {
Tcl_SetObjResult(interp, Tcl_NewStringObj(
"index value out of range", -1));
return TCL_ERROR;
}
Tcl_AppendUnicodeToObj(varPtr[varIndex], unicode + i, length - i);
Tcl_SetObjResult(interp, varPtr[varIndex]);
break;
}
return TCL_OK;
}
static int
ScaleWidgetObjCmd(
ClientData clientData, /* Information about scale widget. */
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument strings. */
{
TkScale *scalePtr = clientData;
Tcl_Obj *objPtr;
int index, result;
if (objc < 2) {
Tcl_WrongNumArgs(interp, 1, objv, "option ?arg ...?");
return TCL_ERROR;
}
result = Tcl_GetIndexFromObj(interp, objv[1], commandNames,
"option", 0, &index);
if (result != TCL_OK) {
return result;
}
Tcl_Preserve(scalePtr);
switch (index) {
case COMMAND_CGET:
if (objc != 3) {
Tcl_WrongNumArgs(interp, 1, objv, "cget option");
goto error;
}
objPtr = Tk_GetOptionValue(interp, (char *) scalePtr,
scalePtr->optionTable, objv[2], scalePtr->tkwin);
if (objPtr == NULL) {
goto error;
}
Tcl_SetObjResult(interp, objPtr);
break;
case COMMAND_CONFIGURE:
if (objc <= 3) {
objPtr = Tk_GetOptionInfo(interp, (char *) scalePtr,
scalePtr->optionTable,
(objc == 3) ? objv[2] : NULL, scalePtr->tkwin);
if (objPtr == NULL) {
goto error;
}
Tcl_SetObjResult(interp, objPtr);
} else {
result = ConfigureScale(interp, scalePtr, objc-2, objv+2);
}
break;
case COMMAND_COORDS: {
int x, y;
double value;
Tcl_Obj *coords[2];
if ((objc != 2) && (objc != 3)) {
Tcl_WrongNumArgs(interp, 1, objv, "coords ?value?");
goto error;
}
if (objc == 3) {
if (Tcl_GetDoubleFromObj(interp, objv[2], &value) != TCL_OK) {
goto error;
}
} else {
value = scalePtr->value;
}
if (scalePtr->orient == ORIENT_VERTICAL) {
x = scalePtr->vertTroughX + scalePtr->width/2
+ scalePtr->borderWidth;
y = TkScaleValueToPixel(scalePtr, value);
} else {
x = TkScaleValueToPixel(scalePtr, value);
y = scalePtr->horizTroughY + scalePtr->width/2
+ scalePtr->borderWidth;
}
coords[0] = Tcl_NewIntObj(x);
coords[1] = Tcl_NewIntObj(y);
Tcl_SetObjResult(interp, Tcl_NewListObj(2, coords));
break;
}
case COMMAND_GET: {
double value;
int x, y;
if ((objc != 2) && (objc != 4)) {
Tcl_WrongNumArgs(interp, 1, objv, "get ?x y?");
goto error;
}
if (objc == 2) {
value = scalePtr->value;
} else {
if ((Tcl_GetIntFromObj(interp, objv[2], &x) != TCL_OK) ||
(Tcl_GetIntFromObj(interp, objv[3], &y) != TCL_OK)) {
goto error;
}
value = TkScalePixelToValue(scalePtr, x, y);
}
Tcl_SetObjResult(interp, Tcl_ObjPrintf(scalePtr->format, value));
break;
}
case COMMAND_IDENTIFY: {
int x, y;
const char *zone = "";
if (objc != 4) {
Tcl_WrongNumArgs(interp, 1, objv, "identify x y");
goto error;
}
if ((Tcl_GetIntFromObj(interp, objv[2], &x) != TCL_OK)
|| (Tcl_GetIntFromObj(interp, objv[3], &y) != TCL_OK)) {
goto error;
}
switch (TkpScaleElement(scalePtr, x, y)) {
case TROUGH1:
zone = "trough1";
break;
case SLIDER:
zone = "slider";
break;
case TROUGH2:
zone = "trough2";
break;
}
Tcl_SetObjResult(interp, Tcl_NewStringObj(zone, -1));
break;
}
case COMMAND_SET: {
double value;
if (objc != 3) {
Tcl_WrongNumArgs(interp, 1, objv, "set value");
goto error;
}
if (Tcl_GetDoubleFromObj(interp, objv[2], &value) != TCL_OK) {
goto error;
}
if (scalePtr->state != STATE_DISABLED) {
TkScaleSetValue(scalePtr, value, 1, 1);
}
break;
}
}
Tcl_Release(scalePtr);
return result;
error:
Tcl_Release(scalePtr);
return TCL_ERROR;
}
static int backupTestCmd(
ClientData clientData,
Tcl_Interp *interp,
int objc,
Tcl_Obj *const*objv
){
enum BackupSubCommandEnum {
BACKUP_STEP, BACKUP_FINISH, BACKUP_REMAINING, BACKUP_PAGECOUNT
};
struct BackupSubCommand {
const char *zCmd;
enum BackupSubCommandEnum eCmd;
int nArg;
const char *zArg;
} aSub[] = {
{"step", BACKUP_STEP , 1, "npage" },
{"finish", BACKUP_FINISH , 0, "" },
{"remaining", BACKUP_REMAINING , 0, "" },
{"pagecount", BACKUP_PAGECOUNT , 0, "" },
{0, 0, 0, 0}
};
sqlite3_backup *p = (sqlite3_backup *)clientData;
int iCmd;
int rc;
rc = Tcl_GetIndexFromObjStruct(
interp, objv[1], aSub, sizeof(aSub[0]), "option", 0, &iCmd
);
if( rc!=TCL_OK ){
return rc;
}
if( objc!=(2 + aSub[iCmd].nArg) ){
Tcl_WrongNumArgs(interp, 2, objv, aSub[iCmd].zArg);
return TCL_ERROR;
}
switch( aSub[iCmd].eCmd ){
case BACKUP_FINISH: {
const char *zCmdName;
Tcl_CmdInfo cmdInfo;
zCmdName = Tcl_GetString(objv[0]);
Tcl_GetCommandInfo(interp, zCmdName, &cmdInfo);
cmdInfo.deleteProc = 0;
Tcl_SetCommandInfo(interp, zCmdName, &cmdInfo);
Tcl_DeleteCommand(interp, zCmdName);
rc = sqlite3_backup_finish(p);
Tcl_SetResult(interp, (char *)sqlite3ErrName(rc), TCL_STATIC);
break;
}
case BACKUP_STEP: {
int nPage;
if( TCL_OK!=Tcl_GetIntFromObj(interp, objv[2], &nPage) ){
return TCL_ERROR;
}
rc = sqlite3_backup_step(p, nPage);
Tcl_SetResult(interp, (char *)sqlite3ErrName(rc), TCL_STATIC);
break;
}
case BACKUP_REMAINING:
Tcl_SetObjResult(interp, Tcl_NewIntObj(sqlite3_backup_remaining(p)));
break;
case BACKUP_PAGECOUNT:
Tcl_SetObjResult(interp, Tcl_NewIntObj(sqlite3_backup_pagecount(p)));
break;
}
return TCL_OK;
}
int xBestIndex(sqlite3_vtab *sqltabP, sqlite3_index_info *infoP)
{
VTableInfo *vtabP = (VTableInfo *) sqltabP;
Tcl_Obj *objv[3];
Tcl_Interp *interp;
Tcl_Obj *constraints;
Tcl_Obj *order;
int i;
char *s;
Tcl_Obj **response;
int nobjs;
Tcl_Obj **usage;
int nusage;
if (vtabP->vtdbP == NULL || (interp = vtabP->vtdbP->vticP->interp) == NULL) {
/* Should not really happen */
SetVTableError(vtabP, gNullInterpError);
return SQLITE_ERROR;
}
constraints = Tcl_NewListObj(0, NULL);
for (i = 0; i < infoP->nConstraint; ++i) {
objv[0] = Tcl_NewIntObj(infoP->aConstraint[i].iColumn);
switch (infoP->aConstraint[i].op) {
case 2: s = "eq" ; break;
case 4: s = "gt" ; break;
case 8: s = "le" ; break;
case 16: s = "lt" ; break;
case 32: s = "ge" ; break;
case 64: s = "match"; break;
default:
SetVTableError(vtabP, "Unknown or unsupported constraint operator.");
return SQLITE_ERROR;
}
objv[1] = Tcl_NewStringObj(s, -1);
objv[2] = Tcl_NewBooleanObj(infoP->aConstraint[i].usable);
Tcl_ListObjAppendElement(interp, constraints, Tcl_NewListObj(3, objv));
}
order = Tcl_NewListObj(0, NULL);
for (i = 0; i < infoP->nOrderBy; ++i) {
objv[0] = Tcl_NewIntObj(infoP->aOrderBy[i].iColumn);
objv[1] = Tcl_NewBooleanObj(infoP->aOrderBy[i].desc);
Tcl_ListObjAppendElement(interp, order, Tcl_NewListObj(2, objv));
}
objv[0] = constraints;
objv[1] = order;
if (VTableInvokeCmd(interp, vtabP, "xBestIndex", 2, objv) != TCL_OK) {
SetVTableErrorFromInterp(vtabP, interp);
return SQLITE_ERROR;
}
/* Parse and return the response */
if (Tcl_ListObjGetElements(interp, Tcl_GetObjResult(interp),
&nobjs, &response) != TCL_OK)
goto bad_response;
if (nobjs == 0)
return SQLITE_OK;
if (nobjs != 5) {
/* If non-empty, list must have exactly five elements */
goto bad_response;
}
if (Tcl_ListObjGetElements(interp, response[0],
&nusage, &usage) != TCL_OK
|| nusage > infoP->nConstraint) {
/*
* Length of constraints used must not be greater than original
* number of constraints
* TBD - should it be exactly equal ?
*/
goto bad_response;
}
for (i = 0; i < nusage; ++i) {
Tcl_Obj **usage_constraint;
int nusage_constraint;
int argindex;
int omit;
if (Tcl_ListObjGetElements(interp, usage[i],
&nusage_constraint, &usage_constraint) != TCL_OK
|| nusage_constraint != 2
|| Tcl_GetIntFromObj(interp, usage_constraint[0], &argindex) != TCL_OK
|| Tcl_GetBooleanFromObj(interp, usage_constraint[1], &omit) != TCL_OK
) {
goto bad_response;
}
infoP->aConstraintUsage[i].argvIndex = argindex;
infoP->aConstraintUsage[i].omit = omit;
}
if (Tcl_GetIntFromObj(interp, response[1], &infoP->idxNum) != TCL_OK)
goto bad_response;
s = Tcl_GetStringFromObj(response[2], &i);
if (i) {
infoP->idxStr = sqlite3_mprintf("%s", s);
infoP->needToFreeIdxStr = 1;
}
if (Tcl_GetIntFromObj(interp, response[3], &infoP->orderByConsumed) != TCL_OK)
goto bad_response;
if (Tcl_GetDoubleFromObj(interp, response[4], &infoP->estimatedCost) != TCL_OK)
goto bad_response;
return SQLITE_OK;
bad_response:
SetVTableError(vtabP, "Malformed response from virtual table script.");
return SQLITE_ERROR;
}
static int
SetMMFromAny(
Tcl_Interp *interp, /* Used for error reporting if not NULL. */
Tcl_Obj *objPtr) /* The object to convert. */
{
ThreadSpecificData *typeCache = GetTypeCache();
const Tcl_ObjType *typePtr;
char *string, *rest;
double d;
int units;
MMRep *mmPtr;
if (objPtr->typePtr == typeCache->doubleTypePtr) {
Tcl_GetDoubleFromObj(interp, objPtr, &d);
units = -1;
} else if (objPtr->typePtr == typeCache->intTypePtr) {
Tcl_GetIntFromObj(interp, objPtr, &units);
d = (double) units;
units = -1;
/*
* In the case of ints, we need to ensure that a valid string exists
* in order for int-but-not-string objects to be converted back to
* ints again from mm obj types.
*/
(void) Tcl_GetString(objPtr);
} else {
/*
* It wasn't a known int or double, so parse it.
*/
string = Tcl_GetString(objPtr);
d = strtod(string, &rest);
if (rest == string) {
/*
* Must copy string before resetting the result in case a caller
* is trying to convert the interpreter's result to mms.
*/
error:
Tcl_AppendResult(interp, "bad screen distance \"", string,
"\"", NULL);
return TCL_ERROR;
}
while ((*rest != '\0') && isspace(UCHAR(*rest))) {
rest++;
}
switch (*rest) {
case '\0':
units = -1;
break;
case 'c':
units = 0;
break;
case 'i':
units = 1;
break;
case 'm':
units = 2;
break;
case 'p':
units = 3;
break;
default:
goto error;
}
}
/*
* Free the old internalRep before setting the new one.
*/
typePtr = objPtr->typePtr;
if ((typePtr != NULL) && (typePtr->freeIntRepProc != NULL)) {
(*typePtr->freeIntRepProc)(objPtr);
}
objPtr->typePtr = &mmObjType;
mmPtr = (MMRep *) ckalloc(sizeof(MMRep));
mmPtr->value = d;
mmPtr->units = units;
mmPtr->tkwin = NULL;
mmPtr->returnValue = d;
objPtr->internalRep.twoPtrValue.ptr1 = (VOID *) mmPtr;
return TCL_OK;
}
static int obj_Cgmap(ClientData /*UNUSED*/, Tcl_Interp *interp, int argc, Tcl_Obj * const objv[])
{
Tcl_Obj *atomselect = NULL;
Tcl_Obj *object = NULL;
Tcl_Obj *bytes = NULL;
Tcl_Obj *bytes_append = NULL;
Tcl_Obj *sel = NULL;
float *coords = NULL;
float *coords_append = NULL;
const char *blockid_field = "user";
const char *order_field = "user2";
const char *weight_field= "user3";
int nframes, natoms, ncoords, result, length;
int first, last, stride;
int molid, append_molid;
natoms = ncoords = result = 0;
molid = append_molid = 0;
first = last = 0;
stride = 1;
nframes = 1;
std::vector<float> weight;
std::vector<int> bead;
std::vector<int> index;
// Parse Arguments
int n = 1;
while (n < argc) {
const char *cmd = Tcl_GetString(objv[n]);
if (!strncmp(cmd, "-molid", 7)) {
if (Tcl_GetIntFromObj(interp,objv[n+1], &molid) != TCL_OK) {return TCL_ERROR;}
n += 2;
} else if (!strncmp(cmd, "-append", 8)) {
if (Tcl_GetIntFromObj(interp,objv[n+1], &append_molid) != TCL_OK) {return TCL_ERROR;}
n += 2;
} else if (!strncmp(cmd, "-sel", 5)) {
sel = objv[n+1];
n += 2;
} else if (!strncmp(cmd, "-first", 5)) {
if (Tcl_GetIntFromObj(interp,objv[n+1], &first) != TCL_OK) {return TCL_ERROR;}
n += 2;
} else if (!strncmp(cmd, "-last", 4)) {
if (Tcl_GetIntFromObj(interp,objv[n+1], &last) != TCL_OK) {return TCL_ERROR;}
n += 2;
} else if (!strncmp(cmd, "-stride", 6)) {
if (Tcl_GetIntFromObj(interp,objv[n+1], &stride) != TCL_OK) {return TCL_ERROR;}
n += 2;
} else if (!strncmp(cmd, "-weight", 7)) {
weight_field = Tcl_GetString(objv[n+1]);
n += 2;
} else if (!strncmp(cmd, "-blockid", 7)) {
blockid_field = Tcl_GetString(objv[n+1]);
n += 2;
} else if (!strncmp(cmd, "-order", 6)) {
order_field = Tcl_GetString(objv[n+1]);
n += 2;
} else {
Tcl_WrongNumArgs(interp,1,objv, (char *)"molid");
return TCL_ERROR;
}
}
// Create an internal selection that we can manipulate if none was defined
// Note that a passed selection overides the passed molid
if (!sel) {
Tcl_Obj *script = Tcl_ObjPrintf("atomselect %i all", molid);
if (Tcl_EvalObjEx(interp, script, TCL_EVAL_DIRECT) != TCL_OK) {
Tcl_SetResult(interp, (char *) "Cgmap: error calling atomselect", TCL_STATIC);
return TCL_ERROR;
}
atomselect = Tcl_GetObjResult(interp);
Tcl_IncrRefCount(atomselect);
} else {
// Create a internal selection that is a COPY of the passed selection
atomselect = Tcl_DuplicateObj(sel);
Tcl_IncrRefCount(atomselect);
// Get the molid
Tcl_Obj *script = Tcl_DuplicateObj(sel);
Tcl_AppendToObj(script, " molid", -1);
if(Tcl_EvalObjEx(interp, script, TCL_EVAL_DIRECT) != TCL_OK) {
Tcl_SetResult(interp, (char *) "Cgmap: error calling atomselect", TCL_STATIC);
return TCL_ERROR;
}
Tcl_Obj *molid_result = Tcl_GetObjResult(interp);
if (Tcl_GetIntFromObj(interp, molid_result, &molid) != TCL_OK) {return TCL_ERROR;}
}
// Get the number of frames
Tcl_Obj *script = Tcl_ObjPrintf("molinfo %i get numframes", molid);
if (Tcl_EvalObjEx(interp, script, TCL_EVAL_DIRECT) != TCL_OK) {
Tcl_SetResult(interp, (char *) "Cgmap: error calling molinfo for nframes", TCL_STATIC);
return TCL_ERROR;
}
object = Tcl_GetObjResult(interp);
if (Tcl_GetIntFromObj(interp, object, &nframes) != TCL_OK) {
Tcl_SetResult(interp, (char *) "Cgmap: error parsing number of frames", TCL_STATIC);
return TCL_ERROR;
}
if ( first < 0 || first >= nframes ) {
Tcl_SetResult(interp, (char *) "Cgmap: illegal value of first_frame", TCL_STATIC);
return TCL_ERROR;
}
if ( last == -1 || last > nframes || last < first ) last = nframes;
// Get the number of atoms from selection
script = Tcl_DuplicateObj(atomselect);
Tcl_AppendToObj(script, " num", -1);
if (Tcl_EvalObjEx(interp, script, TCL_EVAL_DIRECT) != TCL_OK) {
Tcl_SetResult(interp, (char *) "Cgmap: error calling atomselect", TCL_STATIC);
return TCL_ERROR;
}
object = Tcl_GetObjResult(interp);
if (Tcl_GetIntFromObj(interp, object, &natoms) != TCL_OK) {
Tcl_SetResult(interp, (char *) "Cgmap: error parsing number of atoms", TCL_STATIC);
return TCL_ERROR;
}
// Make sure we actually have some atoms
if (natoms == 0) {
Tcl_SetResult(interp, (char *) "Cgmap: Selection or molecule contains no atoms", TCL_STATIC);
return TCL_ERROR;
}
// Get the weights (mass)
script = Tcl_DuplicateObj(atomselect);
Tcl_AppendPrintfToObj (script, " get %s", weight_field);
if (Tcl_EvalObjEx(interp, script, TCL_EVAL_DIRECT) != TCL_OK) {
Tcl_SetResult(interp, (char *) "Cgmap: error calling atomselect for weights", TCL_STATIC);
return TCL_ERROR;
}
ncoords = parse_vector(Tcl_GetObjResult(interp), weight, interp);
if (ncoords == -1) {
Tcl_SetResult(interp, (char *) "Cgmap: error parsing atomselect result", TCL_STATIC);
return TCL_ERROR;
}
// Get the bead IDs
script = Tcl_DuplicateObj(atomselect);
Tcl_AppendPrintfToObj (script, " get %s", blockid_field);
if (Tcl_EvalObjEx(interp, script, TCL_EVAL_DIRECT) != TCL_OK) {
Tcl_SetResult(interp, (char *) "Cgmap: error calling atomselect for blocks", TCL_STATIC);
return TCL_ERROR;
}
ncoords = parse_ivector(Tcl_GetObjResult(interp), bead, interp, true);
if (ncoords == -1) {
Tcl_SetResult(interp, (char *) "Cgmap: error parsing atomselect result", TCL_STATIC);
return TCL_ERROR;
}
// Get the atom IDs, we use these as a map when accessing the coordinate array
// user2 is set via ::CGit::setBeadID
script = Tcl_DuplicateObj(atomselect);
Tcl_AppendPrintfToObj (script, " get %s", order_field);
if (Tcl_EvalObjEx(interp, script, TCL_EVAL_DIRECT) != TCL_OK) {
Tcl_SetResult(interp, (char *) "Cgmap: error calling atomselect for order", TCL_STATIC);
return TCL_ERROR;
}
ncoords = parse_ivector(Tcl_GetObjResult(interp), index, interp, true);
if (ncoords == -1) {
Tcl_SetResult(interp, (char *) "Cgmap: error parsing atomselect result", TCL_STATIC);
return TCL_ERROR;
}
// Get current frame of the target mol
script = Tcl_ObjPrintf("molinfo %d get frame", append_molid);
if (Tcl_EvalObjEx(interp, script, TCL_EVAL_DIRECT) != TCL_OK) {
Tcl_SetResult(interp, (char *) "Cgmap: error getting append mol's current frame", TCL_STATIC);
return TCL_ERROR;
}
int append_frame = 0;
object = Tcl_GetObjResult(interp);
if (Tcl_GetIntFromObj(interp, object, &append_frame) != TCL_OK) {
Tcl_SetResult(interp, (char *) "Cgmap: error parsing append mol's current frame", TCL_STATIC);
return TCL_ERROR;
}
//Get number of atoms in target (append) mol
script = Tcl_ObjPrintf("molinfo %i get numatoms", append_molid);
if (Tcl_EvalObjEx(interp, script, TCL_EVAL_DIRECT) != TCL_OK) {
Tcl_SetResult(interp, (char *) "Cgmap: error getting append mol's number of atoms", TCL_STATIC);
return TCL_ERROR;
}
int append_natoms = 0;
object = Tcl_GetObjResult(interp);
if (Tcl_GetIntFromObj(interp, object, &append_natoms) != TCL_OK) {
Tcl_SetResult(interp, (char *) "Cgmap: error parsing append mol's number of atoms", TCL_STATIC);
return TCL_ERROR;
}
int print = ((last - first) / 10);
if (print < 10) print = 10;
if (print > 100) print = 100;
//Loop over frames, calculate COMS, set coordinates in target mol
for (int frame = first;
frame <= last && frame < nframes;
frame += stride) {
if (frame % print == 0) {
//Tcl_Obj *msg = Tcl_ObjPrintf ("puts \"Mapping frame %i\"", frame);
Tcl_Obj *msg = Tcl_ObjPrintf ("vmdcon -info \"CGit> Mapping frame %i\"", frame);
result = Tcl_EvalObjEx(interp, msg, TCL_EVAL_DIRECT);
if (result != TCL_OK) { return TCL_ERROR; }
}
//Update the frames
Tcl_Obj *mol_chgframe = Tcl_ObjPrintf ("molinfo top set frame %i", frame);
if (Tcl_EvalObjEx(interp, mol_chgframe, TCL_EVAL_DIRECT) != TCL_OK)
return TCL_ERROR;
// Get the coordinates of the molecules in the reference mol
Tcl_Obj *get_ts = Tcl_ObjPrintf("gettimestep %d %i", molid, frame);
if (Tcl_EvalObjEx(interp, get_ts, TCL_EVAL_DIRECT) != TCL_OK) {
Tcl_SetResult(interp, (char *) "Cgmap: error getting coordinates", TCL_STATIC);
return TCL_ERROR;
}
bytes = Tcl_GetObjResult(interp);
Tcl_IncrRefCount(bytes);
Tcl_InvalidateStringRep (bytes);
coords = reinterpret_cast<float *> (Tcl_GetByteArrayFromObj(bytes, &length));
/** Create a new frame for append_mol **/
Tcl_ObjPrintf("animate dup %i", append_molid);
if (Tcl_EvalObjEx(interp, get_ts, TCL_EVAL_DIRECT) != TCL_OK) {
Tcl_SetResult(interp, (char *) "Cgmap: error adding frame to append mol", TCL_STATIC);
return TCL_ERROR;
}
append_frame++;
Tcl_Obj *setframe = Tcl_ObjPrintf("molinfo %i set frame %i; display update", molid, frame);
if (Tcl_EvalObjEx(interp, setframe, TCL_EVAL_DIRECT) != TCL_OK) {
Tcl_SetResult(interp, (char *) "Cgmap: error updating source frame", TCL_STATIC);
return TCL_ERROR;
}
// Copy PBC conditions
Tcl_Obj *setpbc = Tcl_ObjPrintf("molinfo %i set {a b c} [molinfo %i get {a b c}]", append_molid, molid);
if (Tcl_EvalObjEx(interp, setpbc, TCL_EVAL_DIRECT) != TCL_OK) {
Tcl_SetResult(interp, (char *) "Cgmap: error updating PBC", TCL_STATIC);
return TCL_ERROR;
}
// Get the coordinates of the molecules in the target (append) mol
get_ts = Tcl_ObjPrintf("gettimestep %d %i", append_molid, append_frame);
if (Tcl_EvalObjEx(interp, get_ts, TCL_EVAL_DIRECT) != TCL_OK) {
Tcl_SetResult(interp, (char *) "Cgmap: error getting coordinates", TCL_STATIC);
return TCL_ERROR;
}
bytes_append = Tcl_GetObjResult(interp);
Tcl_IncrRefCount(bytes_append);
Tcl_InvalidateStringRep(bytes_append);
coords_append = reinterpret_cast<float *> (Tcl_GetByteArrayFromObj(bytes_append, &length));
//loop over coordinates and beads, calculate COMs
int current_bead, current_atom;
current_bead = current_atom = 0;
// Nested loop to work on each bead at a time
float w,x,y,z;
int j = 0;
for (int start_atom = 0; start_atom < natoms; ) {
current_bead = bead[start_atom];
w = x = y = z = 0;
// Calculate COM for each bead
for ( current_atom = start_atom;
current_atom < natoms && bead[current_atom] == current_bead;
current_atom++) {
//Lookup the atom index from the selection
unsigned int idx = index[current_atom];
float tw = weight[current_atom];
w += tw;
x += tw * coords[3*idx];
y += tw * coords[3*idx+1];
z += tw * coords[3*idx+2];
}
if (w == 0) {
Tcl_SetResult(interp, (char *) "Cgmap: Bad weight can't total zero", TCL_STATIC);
return TCL_ERROR;
}
// Insert calculated COMS into append_mols coordinate array
// Need to figure out some kind of bounds checking here...
coords_append[3 * j ] = x / w;
coords_append[3 * j + 1] = y / w;
coords_append[3 * j + 2] = z / w;
start_atom = current_atom;
j++;
} // bead loop
// call rawtimestep to set byte array for append_mol
Tcl_Obj *set_ts[5];
set_ts[0] = Tcl_NewStringObj("rawtimestep", -1);
set_ts[1] = Tcl_ObjPrintf("%d",append_molid);
set_ts[2] = bytes_append;
set_ts[3] = Tcl_NewStringObj("-frame", -1);
set_ts[4] = Tcl_NewIntObj(append_frame);
if (Tcl_EvalObjv (interp, 5, set_ts, 0) != TCL_OK)
return TCL_ERROR;
//Cleanup
Tcl_DecrRefCount(bytes);
Tcl_DecrRefCount(bytes_append);
} // Frame loop
//Cleanup
Tcl_DecrRefCount(atomselect);
Tcl_SetResult(interp, (char *) "", TCL_STATIC);
return TCL_OK;
}
int NLEnergy_add_dihedprm(NLEnergy *p, Tcl_Interp *interp,
int objc, Tcl_Obj *const objv[]) {
ForcePrm *fprm = &(p->fprm);
DihedPrm dp;
const char *t = NULL;
int n;
Tcl_Obj **aobjv;
int aobjc;
int s;
int32 id;
TEXT("dihedprm");
if (objc != 5) return ERROR(ERR_EXPECT);
if ((s=DihedPrm_init(&dp)) != OK) return ERROR(s);
t = Tcl_GetStringFromObj(objv[0], &n);
if (n >= sizeof(AtomType) || 0==t[0]) {
return dpclean(&dp,ERROR(ERR_EXPECT));
}
strcpy(dp.atomType[0], t);
t = Tcl_GetStringFromObj(objv[1], &n);
if (n >= sizeof(AtomType) || 0==t[0]) {
return dpclean(&dp,ERROR(ERR_EXPECT));
}
strcpy(dp.atomType[1], t);
t = Tcl_GetStringFromObj(objv[2], &n);
if (n >= sizeof(AtomType) || 0==t[0]) {
return dpclean(&dp,ERROR(ERR_EXPECT));
}
strcpy(dp.atomType[2], t);
t = Tcl_GetStringFromObj(objv[3], &n);
if (n >= sizeof(AtomType) || 0==t[0]) {
return dpclean(&dp,ERROR(ERR_EXPECT));
}
strcpy(dp.atomType[3], t);
if (TCL_ERROR==Tcl_ListObjGetElements(interp, objv[4], &aobjc, &aobjv)
|| aobjc < 2) return dpclean(&dp,ERROR(ERR_EXPECT));
if (TCL_ERROR==Tcl_GetIntFromObj(interp, aobjv[0], &n)
|| n != aobjc-1) return dpclean(&dp,ERROR(ERR_EXPECT));
if ((s=DihedPrm_setmaxnum_term(&dp, n)) != OK) {
return dpclean(&dp,ERROR(s));
}
aobjv++, aobjc--;
for (n = 0; n < aobjc; n++) {
Tcl_Obj **tobjv;
int tobjc;
DihedTerm dterm;
double d;
int m;
if (TCL_ERROR==Tcl_ListObjGetElements(interp, aobjv[n],
&tobjc, &tobjv) || tobjc != 3) {
return dpclean(&dp,ERROR(ERR_EXPECT));
}
if (TCL_ERROR==Tcl_GetDoubleFromObj(interp, tobjv[0], &d) || d < 0) {
return dpclean(&dp,ERROR(ERR_EXPECT));
}
dterm.k_dihed = d * ENERGY_INTERNAL;
if (TCL_ERROR==Tcl_GetDoubleFromObj(interp, tobjv[1], &d)) {
return dpclean(&dp,ERROR(ERR_EXPECT));
}
dterm.phi0 = d * RADIANS;
if (TCL_ERROR==Tcl_GetIntFromObj(interp, tobjv[2], &m) || m <= 0) {
return dpclean(&dp,ERROR(ERR_EXPECT));
}
dterm.n = m;
if ((s=DihedPrm_add_term(&dp, &dterm)) != OK) {
return dpclean(&dp,ERROR(s));
}
}
if ((id=ForcePrm_add_dihedprm(fprm, &dp)) < OK) {
return dpclean(&dp,(id < FAIL ? ERROR(id) : FAIL));
}
if ((n=Topology_setprm_dihed_array(&(p->topo))) < FAIL) {
return dpclean(&dp,ERROR(n));
}
return dpclean(&dp,OK);
}
/*
** Array apObj[] is an array of nObj Tcl objects intended to be transformed
** into lsm_config() calls on database db.
**
** Each pair of objects in the array is treated as a key/value pair used
** as arguments to a single lsm_config() call. If there are an even number
** of objects in the array, then the interpreter result is set to the output
** value of the final lsm_config() call. Or, if there are an odd number of
** objects in the array, the final object is treated as the key for a
** read-only call to lsm_config(), the return value of which is used as
** the interpreter result. For example, the following:
**
** { safety 1 mmap 0 use_log }
**
** Results in a sequence of calls similar to:
**
** iVal = 1; lsm_config(db, LSM_CONFIG_SAFETY, &iVal);
** iVal = 0; lsm_config(db, LSM_CONFIG_MMAP, &iVal);
** iVal = -1; lsm_config(db, LSM_CONFIG_USE_LOG, &iVal);
** Tcl_SetObjResult(interp, Tcl_NewIntObj(iVal));
*/
static int testConfigureLsm(
Tcl_Interp *interp,
lsm_db *db,
int nObj,
Tcl_Obj *const* apObj
){
struct Lsmconfig {
const char *zOpt;
int eOpt;
int bInteger;
} aConfig[] = {
{ "autoflush", LSM_CONFIG_AUTOFLUSH, 1 },
{ "page_size", LSM_CONFIG_PAGE_SIZE, 1 },
{ "block_size", LSM_CONFIG_BLOCK_SIZE, 1 },
{ "safety", LSM_CONFIG_SAFETY, 1 },
{ "autowork", LSM_CONFIG_AUTOWORK, 1 },
{ "autocheckpoint", LSM_CONFIG_AUTOCHECKPOINT, 1 },
{ "mmap", LSM_CONFIG_MMAP, 1 },
{ "use_log", LSM_CONFIG_USE_LOG, 1 },
{ "automerge", LSM_CONFIG_AUTOMERGE, 1 },
{ "max_freelist", LSM_CONFIG_MAX_FREELIST, 1 },
{ "multi_proc", LSM_CONFIG_MULTIPLE_PROCESSES, 1 },
{ "set_compression", LSM_CONFIG_SET_COMPRESSION, 0 },
{ "set_compression_factory", LSM_CONFIG_SET_COMPRESSION_FACTORY, 0 },
{ "readonly", LSM_CONFIG_READONLY, 1 },
{ 0, 0, 0 }
};
int i;
int rc = TCL_OK;
for(i=0; rc==TCL_OK && i<nObj; i+=2){
int iOpt;
rc = Tcl_GetIndexFromObjStruct(
interp, apObj[i], aConfig, sizeof(aConfig[0]), "option", 0, &iOpt
);
if( rc==TCL_OK ){
if( i==(nObj-1) ){
Tcl_ResetResult(interp);
if( aConfig[iOpt].bInteger ){
int iVal = -1;
lsm_config(db, aConfig[iOpt].eOpt, &iVal);
Tcl_SetObjResult(interp, Tcl_NewIntObj(iVal));
}
}else{
if( aConfig[iOpt].eOpt==LSM_CONFIG_SET_COMPRESSION ){
rc = testConfigureSetCompression(interp, db, apObj[i+1], 0);
}
else if( aConfig[iOpt].eOpt==LSM_CONFIG_SET_COMPRESSION_FACTORY ){
rc = testConfigureSetFactory(interp, db, apObj[i+1]);
}
else {
int iVal;
rc = Tcl_GetIntFromObj(interp, apObj[i+1], &iVal);
if( rc==TCL_OK ){
lsm_config(db, aConfig[iOpt].eOpt, &iVal);
}
Tcl_SetObjResult(interp, Tcl_NewIntObj(iVal));
}
}
}
}
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;
}
/*
* TextDraw --
* Draw a text element.
* Called by TextElementDraw() and LabelElementDraw().
*/
static void TextDraw(TextElement *text, Tk_Window tkwin, Drawable d, Ttk_Box b)
{
XColor *color = Tk_GetColorFromObj(tkwin, text->foregroundObj);
int underline = -1;
XGCValues gcValues;
GC gc1, gc2;
Tk_Anchor anchor = TK_ANCHOR_CENTER;
TkRegion clipRegion = NULL;
gcValues.font = Tk_FontId(text->tkfont);
gcValues.foreground = color->pixel;
gc1 = Tk_GetGC(tkwin, GCFont | GCForeground, &gcValues);
gcValues.foreground = WhitePixelOfScreen(Tk_Screen(tkwin));
gc2 = Tk_GetGC(tkwin, GCFont | GCForeground, &gcValues);
/*
* Place text according to -anchor:
*/
Tk_GetAnchorFromObj(NULL, text->anchorObj, &anchor);
b = Ttk_AnchorBox(b, text->width, text->height, anchor);
/*
* Clip text if it's too wide:
*/
if (b.width < text->width) {
XRectangle rect;
clipRegion = TkCreateRegion();
rect.x = b.x;
rect.y = b.y;
rect.width = b.width + (text->embossed ? 1 : 0);
rect.height = b.height + (text->embossed ? 1 : 0);
TkUnionRectWithRegion(&rect, clipRegion, clipRegion);
TkSetRegion(Tk_Display(tkwin), gc1, clipRegion);
TkSetRegion(Tk_Display(tkwin), gc2, clipRegion);
#ifdef HAVE_XFT
TkUnixSetXftClipRegion(clipRegion);
#endif
}
if (text->embossed) {
Tk_DrawTextLayout(Tk_Display(tkwin), d, gc2,
text->textLayout, b.x+1, b.y+1, 0/*firstChar*/, -1/*lastChar*/);
}
Tk_DrawTextLayout(Tk_Display(tkwin), d, gc1,
text->textLayout, b.x, b.y, 0/*firstChar*/, -1/*lastChar*/);
Tcl_GetIntFromObj(NULL, text->underlineObj, &underline);
if (underline >= 0) {
if (text->embossed) {
Tk_UnderlineTextLayout(Tk_Display(tkwin), d, gc2,
text->textLayout, b.x+1, b.y+1, underline);
}
Tk_UnderlineTextLayout(Tk_Display(tkwin), d, gc1,
text->textLayout, b.x, b.y, underline);
}
if (clipRegion != NULL) {
#ifdef HAVE_XFT
TkUnixSetXftClipRegion(None);
#endif
XSetClipMask(Tk_Display(tkwin), gc1, None);
XSetClipMask(Tk_Display(tkwin), gc2, None);
TkDestroyRegion(clipRegion);
}
Tk_FreeGC(Tk_Display(tkwin), gc1);
Tk_FreeGC(Tk_Display(tkwin), gc2);
}
/*
** 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;
}
/****f* callback/create
* AUTHOR
* PGB
* SOURCE
*/
static int create ( Tcl_Interp *interp, int objc, Tcl_Obj * const objv[] )
{
GnoclOption options[] =
{
{ "-interval", GNOCL_OBJ, NULL }, /* 0 */
{ "-priority", GNOCL_INT, NULL }, /* 1 */
{ NULL }
};
const int intervalIdx = 0;
const int priorityIdx = 1;
int interval = -1;
int priority = 0;
int id;
GnoclCommandData *cs;
if ( objc < 3 )
{
Tcl_WrongNumArgs ( interp, 2, objv, "script" );
return TCL_ERROR;
}
if ( gnoclParseOptions ( interp, objc - 2, objv + 2, options ) != TCL_OK )
goto errorExit;
if ( options[priorityIdx].status == GNOCL_STATUS_CHANGED )
priority = options[priorityIdx].val.i;
/* TODO? test priority range? */
if ( options[intervalIdx].status == GNOCL_STATUS_CHANGED )
{
Tcl_Obj * const obj = options[intervalIdx].val.obj;
if ( Tcl_GetIntFromObj ( NULL, obj, &interval ) != TCL_OK )
{
if ( strcmp ( Tcl_GetString ( obj ), "idle" ) != 0 )
{
Tcl_AppendResult ( interp,
"Expected integer or \"idle\", but got \"",
Tcl_GetString ( obj ), "\"", NULL );
goto errorExit;
}
}
else if ( interval <= 0 )
{
Tcl_SetResult ( interp, "interval must be greater zero.",
TCL_STATIC );
goto errorExit;
}
}
gnoclClearOptions ( options );
cs = g_new ( GnoclCommandData, 1 );
cs->command = g_strdup ( Tcl_GetString ( objv[2] ) );
cs->interp = interp;
if ( interval <= 0 ) /* idle */
{
id = g_idle_add_full ( G_PRIORITY_DEFAULT_IDLE - priority,
doCommand, cs, destroyCmd );
}
else
{
id = g_timeout_add_full ( G_PRIORITY_DEFAULT_IDLE - priority, interval,
doCommand, cs, destroyCmd );
}
Tcl_SetObjResult ( interp, Tcl_NewIntObj ( id ) );
return TCL_OK;
errorExit:
gnoclClearOptions ( options );
return TCL_ERROR;
}
/*
turbine::async_exec_worker_loop <executor name> <adlb work type>
[<keyword arg dict>]
Optional key-value arguments:
buffer_count: number of payload buffers to allocate
buffer_size: size of payload buffers in bytes (must be large enough
for work units)
*/
static int
Async_Exec_Worker_Loop_Cmd(ClientData cdata, Tcl_Interp *interp,
int objc, Tcl_Obj *const objv[])
{
TCL_CONDITION(objc == 3 || objc == 4, "Need 2 or 3 arguments");
int rc;
turbine_code tc;
adlb_payload_buf *bufs = NULL;
const char *exec_name = Tcl_GetString(objv[1]);
turbine_executor *exec = turbine_get_async_exec(exec_name, NULL);
TCL_CONDITION(exec != NULL, "Executor %s not registered", exec_name);
int adlb_work_type;
rc = Tcl_GetIntFromObj(interp, objv[2], &adlb_work_type);
TCL_CHECK(rc);
int buffer_count = TURBINE_ASYNC_EXEC_DEFAULT_BUFFER_COUNT;
int buffer_size = TURBINE_ASYNC_EXEC_DEFAULT_BUFFER_SIZE;
if (objc >= 4)
{
DEBUG_TURBINE("Keyword args for %s: %s", exec_name,
Tcl_GetString(objv[3]));
rc = worker_keyword_args(interp, objv, objv[3], &buffer_count,
&buffer_size);
TCL_CHECK(rc);
}
DEBUG_TURBINE("Allocating %i buffers of %i bytes each for %s",
buffer_count, buffer_size, exec_name);
int max_slots;
tc = turbine_async_exec_max_slots(interp, exec, &max_slots);
TCL_CONDITION(tc == TURBINE_SUCCESS, "Executor error in %s getting "
"max slots!", exec_name);
// Only allocate as many buffers as can be used
if (max_slots >= 1 && max_slots < buffer_count) {
buffer_count = max_slots;
}
bufs = malloc(sizeof(adlb_payload_buf) *
(size_t)buffer_count);
TCL_MALLOC_CHECK(bufs);
// Initialize to allow cleanup
for (int i = 0; i < buffer_count; i++)
{
bufs[i].payload = NULL;
}
for (int i = 0; i < buffer_count; i++)
{
// Maintain separate buffers from xfer, since xfer may be
// used in code that we call.
bufs[i].payload = malloc((size_t)buffer_size);
TCL_MALLOC_CHECK_GOTO(bufs[i].payload, cleanup);
bufs[i].size = buffer_size;
}
tc = turbine_async_worker_loop(interp, exec, adlb_work_type,
bufs, buffer_count);
if (tc == TURBINE_ERROR_EXTERNAL)
{
// turbine_async_worker_loop() has added the error info
rc = TCL_ERROR;
goto cleanup;
}
else
{
TCL_CONDITION_GOTO(tc == TURBINE_SUCCESS, cleanup,
"Unknown worker error!");
}
rc = TCL_OK;
cleanup:
if (bufs != NULL)
{
for (int i = 0; i < buffer_count; i++)
{
free(bufs[i].payload);
}
free(bufs);
}
return rc;
}
