Tcl_Obj * TkDebugColor( Tk_Window tkwin, /* The window in which the color will be used * (not currently used). */ char *name) /* Name of the desired color. */ { Tcl_HashEntry *hashPtr; Tcl_Obj *resultPtr; TkDisplay *dispPtr = ((TkWindow *) tkwin)->dispPtr; resultPtr = Tcl_NewObj(); hashPtr = Tcl_FindHashEntry(&dispPtr->colorNameTable, name); if (hashPtr != NULL) { TkColor *tkColPtr = Tcl_GetHashValue(hashPtr); if (tkColPtr == NULL) { Tcl_Panic("TkDebugColor found empty hash table entry"); } for ( ; (tkColPtr != NULL); tkColPtr = tkColPtr->nextPtr) { Tcl_Obj *objPtr = Tcl_NewObj(); Tcl_ListObjAppendElement(NULL, objPtr, Tcl_NewIntObj(tkColPtr->resourceRefCount)); Tcl_ListObjAppendElement(NULL, objPtr, Tcl_NewIntObj(tkColPtr->objRefCount)); Tcl_ListObjAppendElement(NULL, resultPtr, objPtr); } } return resultPtr; }
/* *-------------------------------------------------------------- * * mongotcl_setBsonError -- command deletion callback routine. * * Results: * ...create an error message based on bson object error fields. * ...set errorCode based on the same bson object error fields. * * return TCL_ERROR * *-------------------------------------------------------------- */ int mongotcl_setBsonError (Tcl_Interp *interp, bson *bson) { Tcl_Obj *list = Tcl_NewObj(); Tcl_Obj *errorCodeList = Tcl_NewObj(); if (bson->err & BSON_NOT_UTF8) { Tcl_AddErrorInfo (interp, "bson not utf8"); Tcl_ListObjAppendElement (interp, list, Tcl_NewStringObj("NOT_UTF8",-1)); } if (bson->err & BSON_FIELD_HAS_DOT) { Tcl_AddErrorInfo (interp, "bson field has dot"); Tcl_ListObjAppendElement (interp, list, Tcl_NewStringObj("HAS_DOT",-1)); } if (bson->err & BSON_FIELD_INIT_DOLLAR) { Tcl_AddErrorInfo (interp, "bson field has initial dollar sign"); Tcl_ListObjAppendElement (interp, list, Tcl_NewStringObj("INIT_DOLLAR",-1)); } if (bson->err & BSON_ALREADY_FINISHED) { Tcl_SetObjResult (interp, Tcl_NewStringObj ("bson already finished", -1)); Tcl_ListObjAppendElement (interp, list, Tcl_NewStringObj("ALREADY_FINISHED",-1)); } Tcl_ListObjAppendElement(interp, errorCodeList, Tcl_NewStringObj("BSON",-1)); Tcl_ListObjAppendElement(interp, errorCodeList, list); Tcl_SetObjErrorCode (interp, errorCodeList); return TCL_ERROR; }
int compare_attrs(struct directory *dp1, struct directory *dp2) { struct bu_vls vls = BU_VLS_INIT_ZERO; Tcl_Obj *obj1, *obj2; int different = 0; if (db_version(dbip1) > 4) { bu_vls_printf(&vls, "_db1 attr get %s", dp1->d_namep); if (Tcl_Eval(INTERP, bu_vls_addr(&vls)) != TCL_OK) { fprintf(stderr, "Cannot get attributes for %s\n", dp1->d_namep); fprintf(stderr, "%s\n", Tcl_GetStringResult(INTERP)); bu_exit(1, NULL); } obj1 = Tcl_DuplicateObj(Tcl_GetObjResult(INTERP)); Tcl_ResetResult(INTERP); if (dp1->d_flags & RT_DIR_REGION && verify_region_attribs) { verify_region_attrs(dp1, dbip1, obj1); } } else { obj1 = Tcl_NewObj(); } if (db_version(dbip2) > 4) { bu_vls_trunc(&vls, 0); bu_vls_printf(&vls, "_db2 attr get %s", dp1->d_namep); if (Tcl_Eval(INTERP, bu_vls_addr(&vls)) != TCL_OK) { fprintf(stderr, "Cannot get attributes for %s\n", dp1->d_namep); fprintf(stderr, "%s\n", Tcl_GetStringResult(INTERP)); bu_exit(1, NULL); } obj2 = Tcl_DuplicateObj(Tcl_GetObjResult(INTERP)); Tcl_ResetResult(INTERP); if (dp1->d_flags & RT_DIR_REGION && verify_region_attribs) { verify_region_attrs(dp2, dbip2, obj2); } } else { obj2 = Tcl_NewObj(); } if ((dp1->d_flags & RT_DIR_REGION) && (dp2->d_flags & RT_DIR_REGION)) { /* don't complain about "region" attributes */ remove_region_attrs(obj1); remove_region_attrs(obj2); } bu_vls_trunc(&vls, 0); different = do_compare(ATTRS, &vls, obj1, obj2, dp1->d_namep); printf("%s", bu_vls_addr(&vls)); bu_vls_free(&vls); return different; }
/************************************************************************* * FUNCTION : RPMTransaction_Set::RPM_callback * * ARGUMENTS : none * * RETURNS : TCL_OK or TCL_ERROR * * EXCEPTIONS : none * * PURPOSE : Set or get problem mask flags * *************************************************************************/ void *RPMTransaction_Set::RPM_callback( const void * h, const rpmCallbackType what, const unsigned long amount, const unsigned long total, fnpyKey key ) { // Build up the list of call back bits Tcl_Obj *bitstring = Tcl_NewObj(); for (unsigned i = 0; i < sizeof(bits)/sizeof(bits[0]); ++i) { if (what & bits[i].bit) { Tcl_ListObjAppendElement(_interp,bitstring,Tcl_NewStringObj(bits[i].msg,-1)); } } RPMHeader_Obj *hdr = (RPMHeader_Obj *)key; Tcl_Obj *cmd[] = { Tcl_NewStringObj("::RPM::Callback",-1), bitstring, Tcl_NewLongObj(amount), Tcl_NewLongObj(total), hdr?hdr->Get_obj():Tcl_NewObj() }; Tcl_Obj *script = Tcl_NewListObj(sizeof(cmd)/sizeof(cmd[0]),cmd); Tcl_IncrRefCount(script); Tcl_EvalObj(_interp,script); Tcl_DecrRefCount(script); // Now, handle any special operations here if (what & RPMCALLBACK_INST_OPEN_FILE) { assert(hdr); FD_t fd = hdr->Open(); if (!fd || Ferror(fd)) { if (fd) { Fclose(fd); fd = 0; } } return (void *)fd; } if (what & RPMCALLBACK_INST_CLOSE_FILE) { assert(hdr); hdr->Close(); return 0; } return 0; }
/* ** The main function for threads created with [sqlthread spawn]. */ static Tcl_ThreadCreateType tclScriptThread(ClientData pSqlThread){ Tcl_Interp *interp; Tcl_Obj *pRes; Tcl_Obj *pList; int rc; SqlThread *p = (SqlThread *)pSqlThread; extern int Sqlitetest_mutex_Init(Tcl_Interp*); interp = Tcl_CreateInterp(); Tcl_CreateObjCommand(interp, "clock_seconds", clock_seconds_proc, 0, 0); Tcl_CreateObjCommand(interp, "sqlthread", sqlthread_proc, pSqlThread, 0); #if SQLITE_OS_UNIX && defined(SQLITE_ENABLE_UNLOCK_NOTIFY) Tcl_CreateObjCommand(interp, "sqlite3_blocking_step", blocking_step_proc,0,0); Tcl_CreateObjCommand(interp, "sqlite3_blocking_prepare_v2", blocking_prepare_v2_proc, (void *)1, 0); Tcl_CreateObjCommand(interp, "sqlite3_nonblocking_prepare_v2", blocking_prepare_v2_proc, 0, 0); #endif Sqlitetest1_Init(interp); Sqlitetest_mutex_Init(interp); Sqlite3_Init(interp); rc = Tcl_Eval(interp, p->zScript); pRes = Tcl_GetObjResult(interp); pList = Tcl_NewObj(); Tcl_IncrRefCount(pList); Tcl_IncrRefCount(pRes); if( rc!=TCL_OK ){ Tcl_ListObjAppendElement(interp, pList, Tcl_NewStringObj("error", -1)); Tcl_ListObjAppendElement(interp, pList, pRes); postToParent(p, pList); Tcl_DecrRefCount(pList); pList = Tcl_NewObj(); } Tcl_ListObjAppendElement(interp, pList, Tcl_NewStringObj("set", -1)); Tcl_ListObjAppendElement(interp, pList, Tcl_NewStringObj(p->zVarname, -1)); Tcl_ListObjAppendElement(interp, pList, pRes); postToParent(p, pList); ckfree((void *)p); Tcl_DecrRefCount(pList); Tcl_DecrRefCount(pRes); Tcl_DeleteInterp(interp); while( Tcl_DoOneEvent(TCL_ALL_EVENTS|TCL_DONT_WAIT) ); Tcl_ExitThread(0); TCL_THREAD_CREATE_RETURN; }
void NsfStackDump(Tcl_Interp *interp) { Interp *iPtr = (Interp *)interp; CallFrame *f, *v; Tcl_Obj *varCmdObj; nonnull_assert(interp != NULL); f = iPtr->framePtr; v = iPtr->varFramePtr; varCmdObj = Tcl_NewObj(); fprintf (stderr, " TCL STACK:\n"); if (f == 0) { fprintf(stderr, "- "); } while (f) { Tcl_Obj *cmdObj = Tcl_NewObj(); fprintf(stderr, "\tFrame=%p ", (void *)f); if (f && f->isProcCallFrame && f->procPtr && f->procPtr->cmdPtr) { fprintf(stderr,"caller %p ", (void *)Tcl_CallFrame_callerPtr(f)); fprintf(stderr,"callerV %p ", (void *)Tcl_CallFrame_callerVarPtr(f)); Tcl_GetCommandFullName(interp, (Tcl_Command)f->procPtr->cmdPtr, cmdObj); fprintf(stderr, "%s (%p) lvl=%d\n", ObjStr(cmdObj), (void *)f->procPtr->cmdPtr, f->level); } else { if (f && f->varTablePtr) { fprintf(stderr, "var_table = %p ", (void *)f->varTablePtr); } fprintf(stderr, "- \n"); } DECR_REF_COUNT(cmdObj); f = f->callerPtr; } fprintf (stderr, " VARFRAME:\n"); fprintf(stderr, "\tFrame=%p ", (void *)v); if (v != NULL) { fprintf(stderr, "caller %p var_table %p ", (void *)v->callerPtr, (void *)v->varTablePtr); /* if (v->varTablePtr != NULL) panic(0, "testing");*/ } if (v != NULL && v->isProcCallFrame && v->procPtr && v->procPtr->cmdPtr) { Tcl_GetCommandFullName(interp, (Tcl_Command) v->procPtr->cmdPtr, varCmdObj); fprintf(stderr, " %s (%d)\n", ObjStr(varCmdObj), v->level); } else { fprintf(stderr, "- \n"); } DECR_REF_COUNT(varCmdObj); }
/* ** This is an alternative callback for database queries. Instead ** of invoking a TCL script to handle the result, this callback just ** appends each column of the result to a list. After the query ** is complete, the list is returned. */ static int DbEvalCallback2( void *clientData, /* An instance of CallbackData */ int nCol, /* Number of columns in the result */ char ** azCol, /* Data for each column */ char ** azN /* Name for each column */ ){ Tcl_Obj *pList = (Tcl_Obj*)clientData; int i; if( azCol==0 ) return 0; for(i=0; i<nCol; i++){ Tcl_Obj *pElem; if( azCol[i] && *azCol[i] ){ #ifdef UTF_TRANSLATION_NEEDED Tcl_DString dCol; Tcl_DStringInit(&dCol); Tcl_ExternalToUtfDString(NULL, azCol[i], -1, &dCol); pElem = Tcl_NewStringObj(Tcl_DStringValue(&dCol), -1); Tcl_DStringFree(&dCol); #else pElem = Tcl_NewStringObj(azCol[i], -1); #endif }else{ pElem = Tcl_NewObj(); } Tcl_ListObjAppendElement(0, pList, pElem); } return 0; }
static Tcl_Obj* create(boost::shared_ptr<Network>& network, std::size_t const index) { // instantiate new TCL object Tcl_Obj* const w = Tcl_NewObj(); w->typePtr = CircuitWrapper::type(); w->internalRep.otherValuePtr = new CircuitWrapper(network, index); return w; }
void Sv_RegisterListCommands(void) { static int initialized = 0; if (initialized == 0) { Tcl_MutexLock(&initMutex); if (initialized == 0) { /* Create list with 1 empty element. */ Tcl_Obj *listobj = Tcl_NewObj(); listobj = Tcl_NewListObj(1, &listobj); Sv_RegisterObjType(listobj->typePtr, DupListObjShared); Tcl_DecrRefCount(listobj); Sv_RegisterCommand("lpop", SvLpopObjCmd, NULL, 0); Sv_RegisterCommand("lpush", SvLpushObjCmd, NULL, 0); Sv_RegisterCommand("lappend", SvLappendObjCmd, NULL, 0); Sv_RegisterCommand("lreplace", SvLreplaceObjCmd, NULL, 0); Sv_RegisterCommand("linsert", SvLinsertObjCmd, NULL, 0); Sv_RegisterCommand("llength", SvLlengthObjCmd, NULL, 0); Sv_RegisterCommand("lindex", SvLindexObjCmd, NULL, 0); Sv_RegisterCommand("lrange", SvLrangeObjCmd, NULL, 0); Sv_RegisterCommand("lsearch", SvLsearchObjCmd, NULL, 0); Sv_RegisterCommand("lset", SvLsetObjCmd, NULL, 0); initialized = 1; } Tcl_MutexUnlock(&initMutex); } }
CommandDef (values, clientData, interp, objc, objv) { Handle *handle; DBFHandle dbfHandle; int fieldCount, i; Tcl_Obj *resultPtr, *listPtr; if (objc != 2) { Tcl_WrongNumArgs (interp, 1, objv, "filename"); return TCL_ERROR; } if (DbfGetHandleFromObj (interp, objv[1], &handle) != TCL_OK) { return TCL_ERROR; } dbfHandle = handle->dbfHandle; fieldCount = DBFGetFieldCount (dbfHandle); resultPtr = Tcl_GetObjResult (interp); for (i = 0; i < fieldCount; i++) { 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; } } return TCL_OK; }
/* ** create fft and filter windows. */ static int _command(ClientData clientData, Tcl_Interp *interp, int argc, Tcl_Obj* const *objv) { // check for usage if (argc != 3) return fw_error_obj(interp, Tcl_ObjPrintf("usage: %s type size", Tcl_GetString(objv[0]))); char *type_name = Tcl_GetString(objv[1]); int itype = -1; for (int i = 0; window_names[i] != NULL; i += 1) if (strcmp(window_names[i], type_name) == 0) { itype = i; break; } if (itype < 0) { Tcl_AppendResult(interp, "unknown window type, should be one of ", NULL); for (int i = 0; window_names[i] != NULL; i += 1) { if (i > 0) { Tcl_AppendResult(interp, ", ", NULL); if (window_names[i+1] == NULL) Tcl_AppendResult(interp, "or ", NULL); } Tcl_AppendResult(interp, window_names[i], NULL); } return TCL_ERROR; } int size; if (Tcl_GetIntFromObj(interp, objv[2], &size) != TCL_OK) return TCL_ERROR; Tcl_Obj *result = Tcl_NewObj(); float *window = (float *)Tcl_SetByteArrayLength(result, size*sizeof(float)); window_make(itype, size, window); Tcl_SetObjResult(interp, result); return TCL_OK; }
static int installConsts(Tcl_Interp *interp,struct ConstEntry *table) { struct ConstEntry *entry; if (table==NULL) return TCL_ERROR; for(entry=table+0;entry->objPtr!=NULL;entry++) { Tcl_Obj *obj; if (*entry->objPtr!=NULL) { //WARN("const %s already defined\n",entry->name); continue; } if (entry->value==NULL) obj=Tcl_NewObj(); else obj=Tcl_NewStringObj(entry->value,-1); Tcl_IncrRefCount(obj); if (entry->typePtr!=NULL && *entry->typePtr!=NULL) { if (Tcl_ConvertToType(interp,obj,*entry->typePtr)!=TCL_OK) { ERR("in convert const %s to %s",entry->name,(*entry->typePtr)->name); Tcl_DecrRefCount(obj); return TCL_ERROR; } } Tcl_IncrRefCount(obj); *entry->objPtr=obj; } return TCL_OK; }
/************************************************************************* * FUNCTION : RPMPRoblem_Obj::Get_Obj * * ARGUMENTS : none * * RETURNS : Object with refcount of 0 * * EXCEPTIONS : none * * PURPOSE : Create a Tcl_Obj from a problem * *************************************************************************/ Tcl_Obj *RPMPRoblem_Obj::Get_obj(void) { Tcl_Obj *obj = Tcl_NewObj(); obj->typePtr = &mytype; obj->internalRep.otherValuePtr = Dup(); Tcl_InvalidateStringRep(obj); return obj; }
static Tcl_Obj * newUnicodeObj (const Tcl_UniChar *pWide, int length) { if (pWide == 0) { return Tcl_NewObj(); } return Tcl_NewUnicodeObj(const_cast<Tcl_UniChar *>(pWide), length); }
Tcl_Obj *Ttk_NewStateSpecObj(unsigned int onbits, unsigned int offbits) { Tcl_Obj *objPtr = Tcl_NewObj(); Tcl_InvalidateStringRep(objPtr); objPtr->typePtr = &StateSpecObjType; objPtr->internalRep.longValue = (onbits << 16) | offbits; return objPtr; }
static int _read(_t *data, jack_nframes_t *framep, Tcl_Obj **bytes) { if (ring_buffer_items_available_to_read(&data->rb) < 3+sizeof(jack_nframes_t)+sizeof(size_t)) return 0; int n = ring_buffer_get(&data->rb, sizeof(*framep), (unsigned char *)framep); size_t size; n += ring_buffer_get(&data->rb, sizeof(size), (unsigned char *)&size); *bytes = Tcl_NewObj(); n += ring_buffer_get(&data->rb, size, Tcl_SetByteArrayLength(*bytes, size)); return n; }
int sqlite3OutstandingMallocs(Tcl_Interp *interp){ void *p; Tcl_Obj *pRes = Tcl_NewObj(); Tcl_IncrRefCount(pRes); for(p=sqlite3_pFirst; p; p=((void **)p)[1]){ Tcl_Obj *pEntry = Tcl_NewObj(); Tcl_Obj *pStack = Tcl_NewObj(); char *z; u32 iLine; int nBytes = sqlite3OsAllocationSize(p) - TESTALLOC_OVERHEAD; char *zAlloc = (char *)p; int i; Tcl_ListObjAppendElement(0, pEntry, Tcl_NewIntObj(nBytes)); z = &zAlloc[TESTALLOC_OFFSET_FILENAME(p)]; Tcl_ListObjAppendElement(0, pEntry, Tcl_NewStringObj(z, -1)); z = &zAlloc[TESTALLOC_OFFSET_LINENUMBER(p)]; memcpy(&iLine, z, sizeof(u32)); Tcl_ListObjAppendElement(0, pEntry, Tcl_NewIntObj(iLine)); z = &zAlloc[TESTALLOC_OFFSET_USER(p)]; Tcl_ListObjAppendElement(0, pEntry, Tcl_NewStringObj(z, -1)); z = &zAlloc[TESTALLOC_OFFSET_STACK(p)]; for(i=0; i<TESTALLOC_STACKFRAMES; i++){ char zHex[128]; sprintf(zHex, "%p", ((void **)z)[i]); Tcl_ListObjAppendElement(0, pStack, Tcl_NewStringObj(zHex, -1)); } Tcl_ListObjAppendElement(0, pEntry, pStack); Tcl_ListObjAppendElement(0, pRes, pEntry); } Tcl_ResetResult(interp); Tcl_SetObjResult(interp, pRes); Tcl_DecrRefCount(pRes); return TCL_OK; }
/************************************************************************* * FUNCTION : RPMPRoblem_Obj::Create_from_problem * * ARGUMENTS : ref to problem * * RETURNS : none * * EXCEPTIONS : none * * PURPOSE : Create a problem Tcl_Obj * *************************************************************************/ Tcl_Obj *RPMPRoblem_Obj::Create_from_problem(const rpmProblem_s &x) { Tcl_Obj *y = Tcl_NewObj(); assert(y); Tcl_IncrRefCount(y); Tcl_InvalidateStringRep(y); y->typePtr = &mytype; y->internalRep.otherValuePtr = new RPMPRoblem_Obj(x); return y; }
SEXP RTcl_ObjFromCharVector(SEXP args) { char *s; Tcl_DString s_ds; int count; Tcl_Obj *tclobj, *elem; int i; SEXP val, drop; Tcl_Encoding encoding; const void *vmax = vmaxget(); val = CADR(args); drop = CADDR(args); tclobj = Tcl_NewObj(); count = length(val); encoding = Tcl_GetEncoding(RTcl_interp, "utf-8"); if (count == 1 && LOGICAL(drop)[0]) { Tcl_DStringInit(&s_ds); s = Tcl_ExternalToUtfDString(encoding, translateCharUTF8(STRING_ELT(val, 0)), -1, &s_ds); Tcl_SetStringObj(tclobj, s, -1); Tcl_DStringFree(&s_ds); } else for ( i = 0 ; i < count ; i++) { elem = Tcl_NewObj(); Tcl_DStringInit(&s_ds); s = Tcl_ExternalToUtfDString(encoding, translateCharUTF8(STRING_ELT(val, i)), -1, &s_ds); Tcl_SetStringObj(elem, s, -1); Tcl_DStringFree(&s_ds); Tcl_ListObjAppendElement(RTcl_interp, tclobj, elem); } Tcl_FreeEncoding(encoding); SEXP res = makeRTclObject(tclobj); vmaxset(vmax); return res; }
static VTableDB *VTDBNew(void) { VTableDB *vtdbP = (VTableDB *) ckalloc(sizeof(*vtdbP)); vtdbP->sqliteP = NULL; vtdbP->vticP = NULL; vtdbP->dbcmd_objP = NULL; vtdbP->null_objP = Tcl_NewObj(); Tcl_IncrRefCount(vtdbP->null_objP); vtdbP->nrefs = 0; return vtdbP; }
static int _get(ClientData clientData, Tcl_Interp *interp, int argc, Tcl_Obj* const *objv) { // return the current detimed string _t *dp = (_t *)clientData; // hmm, how to avoid the buffer here, allocate a byte array? unsigned n = ring_buffer_items_available_to_read(&dp->ring); // fprintf(stderr, "%s:%d %u bytes available\n", __FILE__, __LINE__, n); Tcl_Obj *result = Tcl_NewObj(); char *buff = Tcl_SetByteArrayLength(result, n); ring_buffer_get(&dp->ring, n, buff); Tcl_SetObjResult(interp, result); return TCL_OK; }
static OSErr OpenLibraryResource( struct CFragInitBlock* initBlkPtr) { /* * The 3.0 version of the Universal headers changed CFragInitBlock * to an opaque pointer type. CFragSystem7InitBlock is now the * real pointer. */ #if !defined(UNIVERSAL_INTERFACES_VERSION) || (UNIVERSAL_INTERFACES_VERSION < 0x0300) struct CFragInitBlock *realInitBlkPtr = initBlkPtr; #else CFragSystem7InitBlock *realInitBlkPtr = (CFragSystem7InitBlock *) initBlkPtr; #endif FSSpec* fileSpec = NULL; OSErr err = noErr; if (realInitBlkPtr->fragLocator.where == kDataForkCFragLocator) { fileSpec = realInitBlkPtr->fragLocator.u.onDisk.fileSpec; } else if (realInitBlkPtr->fragLocator.where == kResourceCFragLocator) { fileSpec = realInitBlkPtr->fragLocator.u.inSegs.fileSpec; } else { err = resFNotFound; } /* * Open the resource fork for this library in read-only mode. * This will make it the current res file, ahead of the * application's own resources. */ if (fileSpec != NULL) { ourResFile = FSpOpenResFile(fileSpec, fsRdPerm); if (ourResFile == kResFileNotOpened) { err = ResError(); } else { #ifdef TCL_REGISTER_LIBRARY ourResToken = Tcl_NewObj(); Tcl_IncrRefCount(ourResToken); p2cstr(realInitBlkPtr->libName); Tcl_SetStringObj(ourResToken, (char *) realInitBlkPtr->libName, -1); c2pstr((char *) realInitBlkPtr->libName); TclMacRegisterResourceFork(ourResFile, ourResToken, TCL_RESOURCE_DONT_CLOSE); #endif SetResFileAttrs(ourResFile, mapReadOnly); } } return err; }
static int _return_list(Tcl_Interp *interp, const JSList *list) { Tcl_Obj *result = Tcl_NewObj(); while (list != NULL) { if (Tcl_ListObjAppendElement(interp, result, _make_pointer(list->data)) != TCL_OK) { Tcl_DecrRefCount(result); return TCL_ERROR; } else { list = jack_slist_next(list); } } return fw_success_obj(interp, result); }
static Tcl_Obj * convertFromUnknown (IUnknown *pUnknown, REFIID iid, Tcl_Interp *interp) { if (pUnknown == 0) { return Tcl_NewObj(); } const Interface *pInterface = InterfaceManager::instance().find(iid); return Extension::referenceHandles.newObj( interp, Reference::newReference(pUnknown, pInterface)); }
static int PlaceInfoCommand( Tcl_Interp *interp, /* Interp into which to place result. */ Tk_Window tkwin) /* Token for the window to get info on. */ { Slave *slavePtr; Tcl_Obj *infoObj; slavePtr = FindSlave(tkwin); if (slavePtr == NULL) { return TCL_OK; } infoObj = Tcl_NewObj(); if (slavePtr->masterPtr != NULL) { Tcl_AppendToObj(infoObj, "-in", -1); Tcl_ListObjAppendElement(NULL, infoObj, TkNewWindowObj(slavePtr->masterPtr->tkwin)); Tcl_AppendToObj(infoObj, " ", -1); } Tcl_AppendPrintfToObj(infoObj, "-x %d -relx %.4g -y %d -rely %.4g", slavePtr->x, slavePtr->relX, slavePtr->y, slavePtr->relY); if (slavePtr->flags & CHILD_WIDTH) { Tcl_AppendPrintfToObj(infoObj, " -width %d", slavePtr->width); } else { Tcl_AppendToObj(infoObj, " -width {}", -1); } if (slavePtr->flags & CHILD_REL_WIDTH) { Tcl_AppendPrintfToObj(infoObj, " -relwidth %.4g", slavePtr->relWidth); } else { Tcl_AppendToObj(infoObj, " -relwidth {}", -1); } if (slavePtr->flags & CHILD_HEIGHT) { Tcl_AppendPrintfToObj(infoObj, " -height %d", slavePtr->height); } else { Tcl_AppendToObj(infoObj, " -height {}", -1); } if (slavePtr->flags & CHILD_REL_HEIGHT) { Tcl_AppendPrintfToObj(infoObj, " -relheight %.4g", slavePtr->relHeight); } else { Tcl_AppendToObj(infoObj, " -relheight {}", -1); } Tcl_AppendPrintfToObj(infoObj, " -anchor %s -bordermode %s", Tk_NameOfAnchor(slavePtr->anchor), borderModeStrings[slavePtr->borderMode]); Tcl_SetObjResult(interp, infoObj); return TCL_OK; }
// // Return a list of ctable quote type names (cache it, too) // CTABLE_INTERNAL Tcl_Obj *ctable_quoteTypeList(Tcl_Interp *interp) { static Tcl_Obj *result = NULL; if (!result) { int index; result = Tcl_NewObj(); for(index = 0; ctable_quote_names[index]; index++) { Tcl_ListObjAppendElement(interp, result, Tcl_NewStringObj(ctable_quote_names[index], -1)); } Tcl_IncrRefCount(result); } return result; }
void TclpInitLibraryPath( char **valuePtr, int *lengthPtr, Tcl_Encoding *encodingPtr) { #define LIBRARY_SIZE 64 Tcl_Obj *pathPtr; char installLib[LIBRARY_SIZE]; char *bytes; pathPtr = Tcl_NewObj(); /* * Initialize the substring used when locating the script library. The * installLib variable computes the script library path relative to the * installed DLL. */ sprintf(installLib, "lib/tcl%s", TCL_VERSION); /* * Look for the library relative to the TCL_LIBRARY env variable. If the * last dirname in the TCL_LIBRARY path does not match the last dirname in * the installLib variable, use the last dir name of installLib in * addition to the orginal TCL_LIBRARY path. */ AppendEnvironment(pathPtr, installLib); /* * Look for the library in its default location. */ Tcl_ListObjAppendElement(NULL, pathPtr, TclGetProcessGlobalValue(&defaultLibraryDir)); /* * Look for the library in its source checkout location. */ Tcl_ListObjAppendElement(NULL, pathPtr, TclGetProcessGlobalValue(&sourceLibraryDir)); *encodingPtr = NULL; bytes = Tcl_GetStringFromObj(pathPtr, lengthPtr); *valuePtr = ckalloc((unsigned int)(*lengthPtr)+1); memcpy(*valuePtr, bytes, (size_t)(*lengthPtr)+1); Tcl_DecrRefCount(pathPtr); }
/* *--------------------------------------------------------------------------- * * HtmlImagePixmap -- * * Results: * Pixmap. Or zero. * * Side effects: * May change the image storage to pixmap. * *--------------------------------------------------------------------------- */ Pixmap HtmlImagePixmap(HtmlImage2 *pImage) { if (!pImage->pImageServer->pTree->options.imagepixmapify || !pImage->pImageName || !getImageCompressed(pImage) || pImage->width<=0 || pImage->height<=0 ) { return 0; } if (!pImage->isValid) { HtmlImageImage(pImage); } if (!pImage->pixmap && !HtmlImageAlphaChannel(pImage)) { Tk_Window win = pImage->pImageServer->pTree->tkwin; Tcl_Interp *interp = pImage->pImageServer->pTree->interp; Pixmap pix; int rc; Tcl_Obj *pGetData; #if 0 printf("Pixmapifying - nData = %d\n", nData); #endif pix = Tk_GetPixmap(Tk_Display(win), Tk_WindowId(win), pImage->width, pImage->height, Tk_Depth(win) ); Tk_RedrawImage( pImage->image, 0, 0, pImage->width, pImage->height, pix, 0, 0 ); pImage->pixmap = pix; pGetData = Tcl_NewObj(); Tcl_IncrRefCount(pGetData); Tcl_ListObjAppendElement(0, pGetData, Tcl_NewStringObj("image",-1)); Tcl_ListObjAppendElement(0, pGetData, Tcl_NewStringObj("create",-1)); Tcl_ListObjAppendElement(0, pGetData, Tcl_NewStringObj("photo",-1)); Tcl_ListObjAppendElement(0, pGetData, pImage->pImageName); pImage->nIgnoreChange++; rc = Tcl_EvalObjEx(interp, pGetData, TCL_EVAL_GLOBAL|TCL_EVAL_DIRECT); pImage->nIgnoreChange--; Tcl_DecrRefCount(pGetData); assert(rc==TCL_OK); } return pImage->pixmap; }
/* ** This SQLite callback records the datatype of all columns. ** ** The pArg argument is really a pointer to a TCL interpreter. The ** column names are inserted as the result of this interpreter. ** ** This routine returns non-zero which causes the query to abort. */ static int rememberDataTypes(void *pArg, int nCol, char **argv, char **colv){ int i; Tcl_Interp *interp = (Tcl_Interp*)pArg; Tcl_Obj *pList, *pElem; if( colv[nCol+1]==0 ){ return 1; } pList = Tcl_NewObj(); for(i=0; i<nCol; i++){ pElem = Tcl_NewStringObj(colv[i+nCol] ? colv[i+nCol] : "NULL", -1); Tcl_ListObjAppendElement(interp, pList, pElem); } Tcl_SetObjResult(interp, pList); return 1; }
static int TestwinclockCmd( ClientData dummy, /* Unused */ Tcl_Interp* interp, /* Tcl interpreter */ int objc, /* Argument count */ Tcl_Obj *const objv[]) /* Argument vector */ { static const FILETIME posixEpoch = { 0xD53E8000, 0x019DB1DE }; /* The Posix epoch, expressed as a Windows * FILETIME */ Tcl_Time tclTime; /* Tcl clock */ FILETIME sysTime; /* System clock */ Tcl_Obj *result; /* Result of the command */ LARGE_INTEGER t1, t2; LARGE_INTEGER p1, p2; if (objc != 1) { Tcl_WrongNumArgs(interp, 1, objv, ""); return TCL_ERROR; } QueryPerformanceCounter(&p1); Tcl_GetTime(&tclTime); GetSystemTimeAsFileTime(&sysTime); t1.LowPart = posixEpoch.dwLowDateTime; t1.HighPart = posixEpoch.dwHighDateTime; t2.LowPart = sysTime.dwLowDateTime; t2.HighPart = sysTime.dwHighDateTime; t2.QuadPart -= t1.QuadPart; QueryPerformanceCounter(&p2); result = Tcl_NewObj(); Tcl_ListObjAppendElement(interp, result, Tcl_NewIntObj((int) (t2.QuadPart / 10000000))); Tcl_ListObjAppendElement(interp, result, Tcl_NewIntObj((int) ((t2.QuadPart / 10) % 1000000))); Tcl_ListObjAppendElement(interp, result, Tcl_NewIntObj(tclTime.sec)); Tcl_ListObjAppendElement(interp, result, Tcl_NewIntObj(tclTime.usec)); Tcl_ListObjAppendElement(interp, result, Tcl_NewWideIntObj(p1.QuadPart)); Tcl_ListObjAppendElement(interp, result, Tcl_NewWideIntObj(p2.QuadPart)); Tcl_SetObjResult(interp, result); return TCL_OK; }