static HRESULT Async( TkWinSendCom *obj, VARIANT Cmd, EXCEPINFO *pExcepInfo, UINT *puArgErr) { HRESULT hr = S_OK; int result = TCL_OK; VARIANT vCmd; VariantInit(&vCmd); hr = VariantChangeType(&vCmd, &Cmd, 0, VT_BSTR); if (FAILED(hr)) { Tcl_SetStringObj(Tcl_GetObjResult(obj->interp), "invalid args: Async(command)", -1); SetExcepInfo(obj->interp, pExcepInfo); hr = DISP_E_EXCEPTION; } if (SUCCEEDED(hr)) { if (obj->interp) { Tcl_Obj *scriptPtr = Tcl_NewUnicodeObj(vCmd.bstrVal, (int)SysStringLen(vCmd.bstrVal)); result = TkWinSend_QueueCommand(obj->interp, scriptPtr); } } VariantClear(&vCmd); return hr; }
/* sequencer device channel create for reading or writing, not both at once. */ static int alsa_sequencer_open(ClientData clientData, Tcl_Interp *interp, Tcl_Obj *port, Tcl_Obj *direction) { const char *port_name = Tcl_GetString(port), *direction_name = Tcl_GetString(direction); static snd_sequencer_t *input, **inputp; static snd_sequencer_t *output, **outputp; if (strcmp(direction_name, "r") == 0) { inputp = &input; outputp = NULL; } else if (strcmp(direction_name, "w") == 0) { inputp = NULL; outputp = &output; } else { Tcl_AppendResult(interp, "open direction must be r or w", NULL); return TCL_ERROR; } int err; if ((err = snd_sequencer_open(inputp, outputp, port_name, SND_SEQUENCER_NONBLOCK)) < 0) { Tcl_AppendPrintfToObj(Tcl_GetObjResult(interp), "cannot open port \"%s\": %s", port_name, snd_strerror(err)); return TCL_ERROR; } if (inputp) { snd_sequencer_read(input, NULL, 0); /* trigger reading */ return sequencer_make_channel(clientData, interp, input, TCL_READABLE); } if (outputp) { if ((err = snd_sequencer_nonblock(output, 0)) < 0) { Tcl_AppendResult(interp, "cannot set blocking mode: ", snd_strerror(err), NULL); snd_sequencer_close(output); return TCL_ERROR; } return sequencer_make_channel(clientData, interp, output, TCL_WRITABLE); } }
Tcl_CmdInfo *eul_tk_create_widget(char *type, char *name, LispRef listArgs) { struct infoargs infoArgs; ParseArguments2(&infoArgs, type, name, listArgs); Tcl_CmdInfo cmdInfo = FindCreationFn(type); int result = cmdInfo.proc ( cmdInfo.clientData, interp, infoArgs.argc, infoArgs.argv ); Tcl_CmdInfo *newCmdInfo = (Tcl_CmdInfo *)gc_malloc(sizeof(Tcl_CmdInfo)); *newCmdInfo = (Tcl_CmdInfo){0, NULL, 0, NULL, 0, NULL, 0, NULL}; // It isn't clear what should be returned on error so return an empty // structure allocated on free-store if (result == TCL_ERROR) { return newCmdInfo; } result = Tcl_GetCommandInfo ( interp, Tcl_GetString(Tcl_GetObjResult(interp)), newCmdInfo ); return newCmdInfo; }
/* ** Test for access permissions. Return true if the requested permission ** is available, or false otherwise. */ static int tvfsAccess( sqlite3_vfs *pVfs, const char *zPath, int flags, int *pResOut ){ Testvfs *p = (Testvfs *)pVfs->pAppData; if( p->pScript && p->mask&TESTVFS_ACCESS_MASK ){ int rc; char *zArg = 0; if( flags==SQLITE_ACCESS_EXISTS ) zArg = "SQLITE_ACCESS_EXISTS"; if( flags==SQLITE_ACCESS_READWRITE ) zArg = "SQLITE_ACCESS_READWRITE"; if( flags==SQLITE_ACCESS_READ ) zArg = "SQLITE_ACCESS_READ"; tvfsExecTcl(p, "xAccess", Tcl_NewStringObj(zPath, -1), Tcl_NewStringObj(zArg, -1), 0 ); if( tvfsResultCode(p, &rc) ){ if( rc!=SQLITE_OK ) return rc; }else{ Tcl_Interp *interp = p->interp; if( TCL_OK==Tcl_GetBooleanFromObj(0, Tcl_GetObjResult(interp), pResOut) ){ return SQLITE_OK; } } } return sqlite3OsAccess(PARENTVFS(pVfs), zPath, flags, pResOut); }
static Tcl_Obj * tk_eval(const char *cmd) { char *cmd_utf8; Tcl_DString cmd_utf8_ds; Tcl_DStringInit(&cmd_utf8_ds); cmd_utf8 = Tcl_ExternalToUtfDString(NULL, cmd, -1, &cmd_utf8_ds); if (Tcl_Eval(RTcl_interp, cmd_utf8) == TCL_ERROR) { char p[512]; if (strlen(Tcl_GetStringResult(RTcl_interp)) > 500) strcpy(p, _("tcl error.\n")); else { char *res; Tcl_DString res_ds; Tcl_DStringInit(&res_ds); res = Tcl_UtfToExternalDString(NULL, Tcl_GetStringResult(RTcl_interp), -1, &res_ds); snprintf(p, sizeof(p), "[tcl] %s.\n", res); Tcl_DStringFree(&res_ds); } error(p); } Tcl_DStringFree(&cmd_utf8_ds); return Tcl_GetObjResult(RTcl_interp); }
int NS(ProcCheck) ( Tcl_Interp * interp, struct Tcl_Obj * cmdObj, char const * const wrongNrStr ) { int ret,len; Tcl_DString cmd; if (!Tcl_GetCommandFromObj (interp, cmdObj)) { Tcl_WrongNumArgs (interp, 0, NULL, wrongNrStr); return TCL_ERROR; } Tcl_DStringInit(&cmd); Tcl_DStringAppendElement(&cmd,"info"); Tcl_DStringAppendElement(&cmd,"args"); Tcl_DStringAppendElement(&cmd,Tcl_GetString(cmdObj)); ret = Tcl_EvalEx(interp, Tcl_DStringValue(&cmd), Tcl_DStringLength(&cmd), TCL_EVAL_GLOBAL); Tcl_DStringFree(&cmd); TclErrorCheck(ret); TclErrorCheck(Tcl_ListObjLength(interp, Tcl_GetObjResult(interp), &len)); if (len != 1) { Tcl_DString msg; Tcl_DStringInit(&msg); Tcl_DStringAppend(&msg,"wrong # args: ", -1); if (len > 1) Tcl_DStringAppend(&msg,"only ", -1); Tcl_DStringAppend(&msg,"one argument for procedure \"", -1); Tcl_DStringAppend(&msg,Tcl_GetString(cmdObj), -1); Tcl_DStringAppend(&msg,"\" is required", -1); Tcl_DStringResult(interp, &msg); Tcl_DStringFree(&msg); return TCL_ERROR; } return TCL_OK; }
static AP_Result tcl_coerce_number(AP_World *w, AP_Obj interp_name, AP_Obj item, AP_Obj atom) { Tcl_Interp *interp; AP_Obj result; interp = GetInterp(w, interp_name); if (!interp) return AP_EXCEPTION; if (AP_ObjType(w, item) == AP_INTEGER || AP_ObjType(w, item) == AP_FLOAT) result = item; else { Tcl_Obj *tcl_obj = PrologToTclObj(w, item, interp); int r; r = Tcl_ConvertToType(interp, tcl_obj, tcl_integer_type); if (r != TCL_OK) r = Tcl_ConvertToType(interp, tcl_obj, tcl_double_type); if (r != TCL_OK) return AP_SetException(w, AP_NewInitStructure(w, AP_NewSymbolFromStr(w, "error"), 2, AP_NewInitStructure(w, AP_NewSymbolFromStr(w, "tcl_error"), 1, TclToPrologObj(interp, Tcl_GetObjResult(interp), w, NULL)), AP_UNBOUND_OBJ)); result = TclToPrologObj(interp, tcl_obj, w, NULL); Tcl_DecrRefCount(tcl_obj); } return AP_Unify(w, result, atom); }
int Tcl_AppInit(Tcl_Interp *interp) { if (Tcl_Init(interp) == TCL_ERROR) return TCL_ERROR; if (tcl_interface_init(interp, &debug) != TCL_OK) { fprintf(stderr, "%s, tcl interface init error", __FUNCTION__); return TCL_ERROR; } if (strlen(script) && Tcl_EvalFile(interp, script) != TCL_OK) { char *result; result = Tcl_GetStringFromObj(Tcl_GetObjResult(interp), NULL); if (result) { printf("*************\n"); Tcl_Eval(interp, "puts $::errorInfo"); printf("*************\n"); } return TCL_ERROR; } return TCL_OK; }
int TclpListVolumes( Tcl_Interp *interp) /* Interpreter to which to pass the volume list */ { Tcl_Obj *resultPtr, *elemPtr; char buf[4]; int i; resultPtr = Tcl_GetObjResult(interp); buf[1] = ':'; buf[2] = '/'; buf[3] = '\0'; /* * On Win32s: * GetLogicalDriveStrings() isn't implemented. * GetLogicalDrives() returns incorrect information. */ for (i = 0; i < 26; i++) { buf[0] = (char) ('a' + i); if (GetVolumeInformation(buf, NULL, 0, NULL, NULL, NULL, NULL, 0) || (GetLastError() == ERROR_NOT_READY)) { elemPtr = Tcl_NewStringObj(buf, -1); Tcl_ListObjAppendElement(NULL, resultPtr, elemPtr); } } return TCL_OK; }
/** * Load a new transformation matrix. This will be followed by * many calls to plot_draw(). */ HIDDEN int plot_loadMatrix(struct dm *dmp, fastf_t *mat, int which_eye) { Tcl_Obj *obj; if (!dmp) return TCL_ERROR; obj = Tcl_GetObjResult(dmp->dm_interp); if (Tcl_IsShared(obj)) obj = Tcl_DuplicateObj(obj); if (((struct plot_vars *)dmp->dm_vars.priv_vars)->debug) { struct bu_vls tmp_vls = BU_VLS_INIT_ZERO; Tcl_AppendStringsToObj(obj, "plot_loadMatrix()\n", (char *)NULL); bu_vls_printf(&tmp_vls, "which eye = %d\t", which_eye); bu_vls_printf(&tmp_vls, "transformation matrix = \n"); bu_vls_printf(&tmp_vls, "%g %g %g %g\n", mat[0], mat[4], mat[8], mat[12]); bu_vls_printf(&tmp_vls, "%g %g %g %g\n", mat[1], mat[5], mat[9], mat[13]); bu_vls_printf(&tmp_vls, "%g %g %g %g\n", mat[2], mat[6], mat[10], mat[14]); bu_vls_printf(&tmp_vls, "%g %g %g %g\n", mat[3], mat[7], mat[11], mat[15]); Tcl_AppendStringsToObj(obj, bu_vls_addr(&tmp_vls), (char *)NULL); bu_vls_free(&tmp_vls); } MAT_COPY(plotmat, mat); Tcl_SetObjResult(dmp->dm_interp, obj); return TCL_OK; }
static int DBus_EventHandler(Tcl_Event *evPtr, int flags) { Tcl_DBusEvent *ev; DBusMessageIter iter; Tcl_Obj *script, *result; int rc; if (!(flags & TCL_IDLE_EVENTS)) return 0; ev = (Tcl_DBusEvent *) evPtr; script = ev->script; if (Tcl_IsShared(script)) script = Tcl_DuplicateObj(script); Tcl_ListObjAppendElement(ev->interp, script, DBus_MessageInfo(ev->interp, ev->msg)); /* read the parameters and append to the script */ if (dbus_message_iter_init(ev->msg, &iter)) { Tcl_ListObjAppendList(ev->interp, script, DBus_IterList(ev->interp, &iter, (ev->flags & DBUSFLAG_DETAILS) != 0)); } /* Excute the constructed Tcl command */ rc = Tcl_EvalObjEx(ev->interp, script, TCL_EVAL_GLOBAL); if (rc != TCL_ERROR) { /* Report success only if noreply == 0 and async == 0 */ if (!(ev->flags & DBUSFLAG_NOREPLY) && !(ev->flags & DBUSFLAG_ASYNC)) { /* read the parameters and append to the script */; result = Tcl_GetObjResult(ev->interp); DBus_SendMessage(ev->interp, ev->conn, DBUS_MESSAGE_TYPE_METHOD_RETURN, NULL, NULL, NULL, dbus_message_get_sender(ev->msg), dbus_message_get_serial(ev->msg), NULL, 1, &result); } } else { /* Always report failures if noreply == 0 */ if (!(ev->flags & DBUSFLAG_NOREPLY)) { result = Tcl_GetObjResult(ev->interp); DBus_Error(ev->interp, ev->conn, NULL, dbus_message_get_sender(ev->msg), dbus_message_get_serial(ev->msg), Tcl_GetString(result)); } } dbus_message_unref(ev->msg); Tcl_DecrRefCount(ev->script); /* The event structure will be cleaned up by Tcl_ServiceEvent */ return 1; }
SEXP dotTclObjv(SEXP args) { SEXP t, avec = CADR(args), nm = getAttrib(avec, R_NamesSymbol); int objc, i, result; Tcl_Obj **objv; const void *vmax = vmaxget(); for (objc = 0, i = 0; i < length(avec); i++){ if (!isNull(VECTOR_ELT(avec, i))) objc++; if (!isNull(nm) && strlen(translateChar(STRING_ELT(nm, i)))) objc++; } objv = (Tcl_Obj **) R_alloc(objc, sizeof(Tcl_Obj *)); for (objc = i = 0; i < length(avec); i++){ const char *s; char *tmp; if (!isNull(nm) && strlen(s = translateChar(STRING_ELT(nm, i)))){ tmp = calloc(strlen(s)+2, sizeof(char)); *tmp = '-'; strcpy(tmp+1, s); objv[objc++] = Tcl_NewStringObj(tmp, -1); free(tmp); } if (!isNull(t = VECTOR_ELT(avec, i))) objv[objc++] = (Tcl_Obj *) R_ExternalPtrAddr(t); } for (i = objc; i--; ) Tcl_IncrRefCount(objv[i]); result = Tcl_EvalObjv(RTcl_interp, objc, objv, 0); for (i = objc; i--; ) Tcl_DecrRefCount(objv[i]); if (result == TCL_ERROR) { char p[512]; if (strlen(Tcl_GetStringResult(RTcl_interp)) > 500) strcpy(p, _("tcl error.\n")); else { char *res; Tcl_DString res_ds; Tcl_DStringInit(&res_ds); res = Tcl_UtfToExternalDString(NULL, Tcl_GetStringResult(RTcl_interp), -1, &res_ds); snprintf(p, sizeof(p), "[tcl] %s.\n", res); Tcl_DStringFree(&res_ds); } error(p); } SEXP res = makeRTclObject(Tcl_GetObjResult(RTcl_interp)); vmaxset(vmax); return res; }
int TnmSetConfig(Tcl_Interp *interp, TnmConfig *config, ClientData object, int objc, Tcl_Obj *const objv[]) { int i, option, code; TnmTable *elemPtr; Tcl_Obj *listPtr; Tcl_Obj *objPtr; if (objc % 2) { Tcl_WrongNumArgs(interp, 2, objv, "?option value? ?option value? ..."); return TCL_ERROR; } /* * First scan through the list of options to make sure that * we don't run on an unknown option later when we have * already modified the object. */ for (i = 2; i < objc; i += 2) { option = TnmGetTableKeyFromObj(interp, config->optionTable, objv[i], "option"); if (option < 0) { return TCL_ERROR; } } /* * Now call the function to actually modify the object. Note, * this version does not rollback changes so an object might * end up in a half modified state. */ for (i = 2; i < objc; i += 2) { option = TnmGetTableKeyFromObj(interp, config->optionTable, objv[i], "option"); code = (config->setOption)(interp, object, option, objv[i+1]); if (code != TCL_OK) { return TCL_ERROR; } } /* * Create a new list which contains all the configuration * options and their current values. */ listPtr = Tcl_GetObjResult(interp); for (elemPtr = config->optionTable; elemPtr->value; elemPtr++) { objPtr = (config->getOption)(interp, object, (int) elemPtr->key); if (objPtr) { Tcl_ListObjAppendElement(interp, listPtr, Tcl_NewStringObj(elemPtr->value, -1)); Tcl_ListObjAppendElement(interp, listPtr, objPtr); } } return TCL_OK; }
int fbsql_numrows(Tcl_Interp *interp, int sql_number, int argc, char **argv) { Tcl_Obj *obj_result; /* set result object pointer */ obj_result = Tcl_GetObjResult(interp); Tcl_SetIntObj(obj_result,connection[sql_number].NUMROWS); return TCL_OK; }
static void setStringsResult (Tcl_Interp *interp, ...) { Tcl_ResetResult(interp); va_list arguments; va_start(arguments, interp); Tcl_AppendStringsToObjVA(Tcl_GetObjResult(interp), arguments); va_end(arguments); }
/* * ------------------------------------------------------------------------ * Itk_ArchOptAccessError() * * Simply utility which adds error information after an option * value access fails. Adds traceback information to the given * interpreter. * ------------------------------------------------------------------------ */ void Itk_ArchOptAccessError( Tcl_Interp *interp, /* interpreter handling this object */ ArchInfo *info, /* info associated with mega-widget */ ArchOption *archOpt) /* option that couldn't be accessed */ { Tcl_ResetResult(interp); Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), "internal error: cannot access itk_option(", archOpt->switchName, ")", (char*)NULL); if (info->itclObj->accessCmd) { Tcl_Obj *resultPtr = Tcl_GetObjResult(interp); Tcl_AppendToObj(resultPtr, " in widget \"", -1); Tcl_GetCommandFullName(interp, info->itclObj->accessCmd, resultPtr); Tcl_AppendToObj(resultPtr, "\"", -1); } }
static void windows_error (Tcl_Interp *interp, const char *fn) { char buf[20]; sprintf (buf, "%lu", (unsigned long) GetLastError ()); Tcl_ResetResult (interp); Tcl_AppendStringsToObj (Tcl_GetObjResult (interp), "Windows error in ", fn, ": ", buf, (char *) NULL); }
char * TkWin_getWindowID(void) { Tcl_Obj *result; if (Tcl_Eval(interp, "winfo id .screen") == TCL_ERROR) return NULL; result = Tcl_GetObjResult(interp); return Tcl_GetStringFromObj(result, NULL); }
static void StatError( Tcl_Interp *interp, /* The interp that has the error */ CONST char *fileName) /* The name of the file which caused the * error. */ { TclWinConvertError(GetLastError()); Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), "could not read \"", fileName, "\": ", Tcl_PosixError(interp), (char *) NULL); }
static int GetFileFinderAttributes( Tcl_Interp *interp, /* The interp to report errors with. */ int objIndex, /* The index of the attribute option. */ char *fileName, /* The name of the file. */ Tcl_Obj **attributePtrPtr) /* A pointer to return the object with. */ { OSErr err; FSSpec fileSpec; FInfo finfo; err = FSpLocationFromPath(strlen(fileName), fileName, &fileSpec); if (err == noErr) { err = FSpGetFInfo(&fileSpec, &finfo); } if (err == noErr) { switch (objIndex) { case MAC_CREATOR_ATTRIBUTE: *attributePtrPtr = Tcl_NewOSTypeObj(finfo.fdCreator); break; case MAC_HIDDEN_ATTRIBUTE: *attributePtrPtr = Tcl_NewBooleanObj(finfo.fdFlags & kIsInvisible); break; case MAC_TYPE_ATTRIBUTE: *attributePtrPtr = Tcl_NewOSTypeObj(finfo.fdType); break; } } else if (err == fnfErr) { long dirID; Boolean isDirectory = 0; err = FSpGetDirectoryID(&fileSpec, &dirID, &isDirectory); if ((err == noErr) && isDirectory) { if (objIndex == MAC_HIDDEN_ATTRIBUTE) { *attributePtrPtr = Tcl_NewBooleanObj(0); } else { *attributePtrPtr = Tcl_NewOSTypeObj('Fldr'); } } } if (err != noErr) { errno = TclMacOSErrorToPosixError(err); Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), "couldn't get attributes for file \"", fileName, "\": ", Tcl_PosixError(interp), (char *) NULL); return TCL_ERROR; } return TCL_OK; }
static void Prompt( Tcl_Interp *interp, /* Interpreter to use for prompting. */ int partial) /* Non-zero means there already exists a * partial command, so use the secondary * prompt. */ { Tcl_Obj *promptCmd; int code; Tcl_Channel outChannel, errChannel; promptCmd = Tcl_GetVar2Ex(interp, partial ? "tcl_prompt2" : "tcl_prompt1", NULL, TCL_GLOBAL_ONLY); if (promptCmd == NULL) { defaultPrompt: if (!partial) { /* * We must check that outChannel is a real channel - it is * possible that someone has transferred stdout out of this * interpreter with "interp transfer". */ outChannel = Tcl_GetChannel(interp, "stdout", NULL); if (outChannel != (Tcl_Channel) NULL) { Tcl_WriteChars(outChannel, "% ", 2); } } } else { code = Tcl_EvalObjEx(interp, promptCmd, TCL_EVAL_GLOBAL); if (code != TCL_OK) { Tcl_AddErrorInfo(interp, "\n (script that generates prompt)"); /* * We must check that errChannel is a real channel - it is * possible that someone has transferred stderr out of this * interpreter with "interp transfer". */ errChannel = Tcl_GetChannel(interp, "stderr", NULL); if (errChannel != (Tcl_Channel) NULL) { Tcl_WriteObj(errChannel, Tcl_GetObjResult(interp)); Tcl_WriteChars(errChannel, "\n", 1); } goto defaultPrompt; } } outChannel = Tcl_GetChannel(interp, "stdout", NULL); if (outChannel != (Tcl_Channel) NULL) { Tcl_Flush(outChannel); } }
static int CannotSetAttribute( Tcl_Interp *interp, /* The interp we are using for errors. */ int objIndex, /* The index of the attribute. */ char *fileName, /* The name of the file. */ Tcl_Obj *attributePtr) /* The new value of the attribute. */ { Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), "cannot set attribute \"", tclpFileAttrStrings[objIndex], "\" for file \"", fileName, "\" : attribute is readonly", (char *) NULL); return TCL_ERROR; }
static int GetOp(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *const *objv) { Tk_Window tkwin = clientData; char *string; int buffer; int nBytes; buffer = 0; if (objc == 3) { if (GetCutNumberFromObj(interp, objv[2], &buffer) != TCL_OK) { return TCL_ERROR; } } string = XFetchBuffer(Tk_Display(tkwin), &nBytes, buffer); if (string != NULL) { int limit; char *p; int i; if (string[nBytes - 1] == '\0') { limit = nBytes - 1; } else { limit = nBytes; } for (p = string, i = 0; i < limit; i++, p++) { int c; c = (unsigned char)*p; if (c == 0) { *p = ' '; /* Convert embedded NUL bytes */ } } if (limit == nBytes) { char *newPtr; /* * Need to copy the string into a bigger buffer so we can * add a NUL byte on the end. */ newPtr = Blt_AssertMalloc(nBytes + 1); memcpy(newPtr, string, nBytes); newPtr[nBytes] = '\0'; Blt_Free(string); string = newPtr; } Tcl_SetStringObj(Tcl_GetObjResult(interp), string, nBytes); } return TCL_OK; }
static void AttributesPosixError( Tcl_Interp *interp, /* The interp that has the error */ int objIndex, /* The attribute which caused the problem. */ char *fileName, /* The name of the file which caused the * error. */ int getOrSet) /* 0 for get; 1 for set */ { TclWinConvertError(GetLastError()); Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), "cannot ", getOrSet ? "set" : "get", " attribute \"", tclpFileAttrStrings[objIndex], "\" for file \"", fileName, "\": ", Tcl_PosixError(interp), (char *) NULL); }
static void Prompt( Tcl_Interp *interp, /* Interpreter to use for prompting. */ InteractiveState *isPtr) /* InteractiveState. Filled with PROMPT_NONE * after a prompt is printed. */ { Tcl_Obj *promptCmdPtr; int code; Tcl_Channel chan; if (isPtr->prompt == PROMPT_NONE) { return; } promptCmdPtr = Tcl_GetVar2Ex(interp, (isPtr->prompt==PROMPT_CONTINUE ? "tcl_prompt2" : "tcl_prompt1"), NULL, TCL_GLOBAL_ONLY); if (Tcl_InterpDeleted(interp)) { return; } if (promptCmdPtr == NULL) { defaultPrompt: if (isPtr->prompt == PROMPT_START) { chan = Tcl_GetStdChannel(TCL_STDOUT); if (chan != NULL) { Tcl_WriteChars(chan, DEFAULT_PRIMARY_PROMPT, strlen(DEFAULT_PRIMARY_PROMPT)); } } } else { code = Tcl_EvalObjEx(interp, promptCmdPtr, TCL_EVAL_GLOBAL); if (code != TCL_OK) { Tcl_AddErrorInfo(interp, "\n (script that generates prompt)"); chan = Tcl_GetStdChannel(TCL_STDERR); if (chan != NULL) { Tcl_WriteObj(chan, Tcl_GetObjResult(interp)); Tcl_WriteChars(chan, "\n", 1); } goto defaultPrompt; } } chan = Tcl_GetStdChannel(TCL_STDOUT); if (chan != NULL) { Tcl_Flush(chan); } isPtr->prompt = PROMPT_NONE; }
void DupStatCmdTests::getempty() { registerCmd(); int stat = Tcl_Eval(m_pNativeInterp, "dupstat get"); EQ(TCL_OK, stat); CTCLObject result(Tcl_GetObjResult(m_pNativeInterp)); result.Bind(m_pInterp); EQ(2, result.llength()); EQ(0, (int)(result.lindex(0))); EQ(std::string(""), std::string(result.lindex(1))); }
static void Prompt( Tcl_Interp *interp, /* Interpreter to use for prompting. */ PromptType *promptPtr) /* Points to type of prompt to print. Filled * with PROMPT_NONE after a prompt is * printed. */ { Tcl_Obj *promptCmdPtr; int code; Tcl_Channel outChannel, errChannel; if (*promptPtr == PROMPT_NONE) { return; } promptCmdPtr = Tcl_GetVar2Ex(interp, ((*promptPtr == PROMPT_CONTINUE) ? "tcl_prompt2" : "tcl_prompt1"), NULL, TCL_GLOBAL_ONLY); if (Tcl_InterpDeleted(interp)) { return; } if (promptCmdPtr == NULL) { defaultPrompt: outChannel = Tcl_GetStdChannel(TCL_STDOUT); if ((*promptPtr == PROMPT_START) && (outChannel != (Tcl_Channel) NULL)) { Tcl_WriteChars(outChannel, DEFAULT_PRIMARY_PROMPT, strlen(DEFAULT_PRIMARY_PROMPT)); } } else { code = Tcl_EvalObjEx(interp, promptCmdPtr, TCL_EVAL_GLOBAL); if (code != TCL_OK) { Tcl_AddErrorInfo(interp, "\n (script that generates prompt)"); errChannel = Tcl_GetStdChannel(TCL_STDERR); if (errChannel != (Tcl_Channel) NULL) { Tcl_WriteObj(errChannel, Tcl_GetObjResult(interp)); Tcl_WriteChars(errChannel, "\n", 1); } goto defaultPrompt; } } outChannel = Tcl_GetStdChannel(TCL_STDOUT); if (outChannel != (Tcl_Channel) NULL) { Tcl_Flush(outChannel); } *promptPtr = PROMPT_NONE; }
/* ** 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; }
/* * ------------------------------------------------------------------------ * Itk_GetArchInfo() * * Finds the extra Archetype info associated with the given object. * Returns TCL_OK and a pointer to the info if found. Returns * TCL_ERROR along with an error message in interp->result if not. * ------------------------------------------------------------------------ */ int Itk_GetArchInfo( Tcl_Interp *interp, /* interpreter handling this object */ ItclObject *contextObj, /* object with desired data */ ArchInfo **infoPtr) /* returns: pointer to extra info */ { Tcl_HashTable *objsWithArchInfo; Tcl_HashEntry *entry; /* * If there is any problem finding the info, return an error. */ objsWithArchInfo = ItkGetObjsWithArchInfo(interp); entry = Tcl_FindHashEntry(objsWithArchInfo, (char*)contextObj); if (!entry) { Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), "internal error: no Archetype information for widget", (char*)NULL); if (contextObj->accessCmd) { Tcl_Obj *resultPtr = Tcl_GetObjResult(interp); Tcl_AppendToObj(resultPtr, " \"", -1); Tcl_GetCommandFullName(interp, contextObj->accessCmd, resultPtr); Tcl_AppendToObj(resultPtr, "\"", -1); } return TCL_ERROR; } /* * Otherwise, return the requested info. */ *infoPtr = (ArchInfo*)Tcl_GetHashValue(entry); return TCL_OK; }
int ComObject::eval (TclObject script, TclObject *pResult) { int completionCode = #if TCL_MINOR_VERSION >= 1 Tcl_EvalObjEx(m_interp, script, TCL_EVAL_DIRECT | TCL_EVAL_GLOBAL); #else Tcl_GlobalEvalObj(m_interp, script); #endif if (pResult != 0) { *pResult = Tcl_GetObjResult(m_interp); } return completionCode; }