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