static void plustot_env_evalfile(t_plustot_env *x, t_symbol *fname)
{
char buf1[MAXPDSTRING], buf2[MAXPDSTRING], *nameptr, *dir;
int fd;
dir = canvas_getdir(x->x_glist)->s_name;
if ((fd = open_via_path(dir, fname->s_name, "",
buf1, &nameptr, MAXPDSTRING, 0)) < 0)
{
loud_error((t_pd *)x, "file '%s' not found", fname->s_name);
}
else
{
Tcl_Interp *interp = plustin_getinterp(x->x_tin);
FILE *fp;
close(fd);
strcpy(buf2, buf1);
strcat(buf2, "/");
strcat(buf2, nameptr);
sys_bashfilename(buf2, buf2);
Tcl_Preserve(interp);
if (Tcl_EvalFile(interp, buf2) != TCL_OK)
{
strcpy(buf1, "evaluation failed (");
strncat(buf1, buf2, MAXPDSTRING - strlen(buf1) - 2);
strcat(buf1, ")");
plusloud_tclerror((t_pd *)x, interp, buf1);
}
Tcl_Release(interp);
}
}
int NpInitInterp(Tcl_Interp *interp, int install_tk) {
Tcl_Preserve((ClientData) interp);
/*
* Set sharedlib in interp while we are here. This will be used to
* base the location of the default pluginX.Y package in the stardll
* usage scenario.
*/
if (Tcl_SetVar2(interp, "plugin", "sharedlib", dllName, TCL_GLOBAL_ONLY)
== NULL) {
NpPlatformMsg("Failed to set plugin(sharedlib)!", "NpInitInterp");
return TCL_ERROR;
}
/*
* The plugin doesn't directly call Tk C APIs - it's all managed at
* the Tcl level, so we can just pkg req Tk here instead of calling
* Tk_InitStubs.
*/
if (TCL_OK != Tcl_Init(interp)) {
CONST char *msg = Tcl_GetVar(interp, "errorInfo", TCL_GLOBAL_ONLY);
fprintf(stderr, "GTKWAVE | Tcl_Init error: %s\n", msg) ;
exit(EXIT_FAILURE);
}
if (install_tk) {
NpLog("Tcl_PkgRequire(\"Tk\", \"%s\", 0)\n", TK_VERSION);
if (1 && Tcl_PkgRequire(interp, "Tk", TK_VERSION, 0) == NULL) {
CONST char *msg = Tcl_GetVar(interp, "errorInfo", TCL_GLOBAL_ONLY);
NpPlatformMsg(msg, "NpInitInterp Tcl_PkgRequire(Tk)");
NpPlatformMsg("Failed to create initialize Tk", "NpInitInterp");
return TCL_ERROR;
}
}
return TCL_OK;
}
int
ItclVarsAndCommandResolveInit(
Tcl_Interp *interp)
{
#ifdef NEW_PROTO_RESOLVER
ItclResolvingInfo *iriPtr;
/*
* Create the top-level data structure for tracking objects.
* Store this as "associated data" for easy access, but link
* it to the itcl namespace for ownership.
*/
iriPtr = (ItclResolvingInfo*)ckalloc(sizeof(ItclResolvingInfo));
memset(iriPtr, 0, sizeof(ItclResolvingInfo));
iriPtr->interp = interp;
Tcl_InitHashTable(&iriPtr->resolveVars, TCL_ONE_WORD_KEYS);
Tcl_InitHashTable(&iriPtr->resolveCmds, TCL_ONE_WORD_KEYS);
Tcl_InitHashTable(&iriPtr->objectVarsTables, TCL_ONE_WORD_KEYS);
Tcl_InitHashTable(&iriPtr->objectCmdsTables, TCL_ONE_WORD_KEYS);
Tcl_SetAssocData(interp, ITCL_RESOLVE_DATA,
(Tcl_InterpDeleteProc*)ItclDeleteResolveInfo, (ClientData)iriPtr);
Tcl_Preserve((ClientData)iriPtr);
Itcl_SetClassCommandProtectionCallback(interp, NULL,
Itcl_CheckClassCommandProtection);
Itcl_SetClassVariableProtectionCallback(interp, NULL,
Itcl_CheckClassVariableProtection);
#endif
return TCL_OK;
}
int
TkWinSend_QueueCommand(
Tcl_Interp *interp,
Tcl_Obj *cmdPtr)
{
SendEvent *evPtr;
TRACE("SendQueueCommand()\n");
evPtr = ckalloc(sizeof(SendEvent));
evPtr->header.proc = SendEventProc;
evPtr->header.nextPtr = NULL;
evPtr->interp = interp;
Tcl_Preserve(evPtr->interp);
if (Tcl_IsShared(cmdPtr)) {
evPtr->cmdPtr = Tcl_DuplicateObj(cmdPtr);
} else {
evPtr->cmdPtr = cmdPtr;
Tcl_IncrRefCount(evPtr->cmdPtr);
}
Tcl_QueueEvent((Tcl_Event *)evPtr, TCL_QUEUE_TAIL);
return 0;
}
static void
CmdDeleteProc(
ClientData clientData)
{
RegisteredInterp *riPtr = (RegisteredInterp *)clientData;
/*
* Lock the package structure in memory.
*/
Tcl_Preserve(clientData);
/*
* Revoke the ROT registration.
*/
RevokeObjectRegistration(riPtr);
/*
* Release the registration object.
*/
riPtr->obj->lpVtbl->Release(riPtr->obj);
riPtr->obj = NULL;
Tcl_DeleteAssocData(riPtr->interp, "tkWinSend::ri");
/*
* Unlock the package data structure.
*/
Tcl_Release(clientData);
ckfree(clientData);
}
static void
LostSelection(
ClientData clientData) /* Pointer to LostCommand structure. */
{
LostCommand *lostPtr = clientData;
Tcl_Interp *interp = lostPtr->interp;
Tcl_InterpState savedState;
int code;
Tcl_Preserve(interp);
/*
* Execute the command. Save the interpreter's result, if any, and restore
* it after executing the command.
*/
savedState = Tcl_SaveInterpState(interp, TCL_OK);
Tcl_ResetResult(interp);
code = Tcl_EvalObjEx(interp, lostPtr->cmdObj, TCL_EVAL_GLOBAL);
if (code != TCL_OK) {
Tcl_BackgroundException(interp, code);
}
(void) Tcl_RestoreInterpState(interp, savedState);
/*
* Free the storage for the command, since we're done with it now.
*/
Tcl_DecrRefCount(lostPtr->cmdObj);
ckfree(lostPtr);
Tcl_Release(interp);
}
static int
InterpreterObjCmd(
ClientData clientData, /* */
Tcl_Interp *interp, /* Current interpreter */
int objc, /* Number of arguments */
Tcl_Obj *const objv[]) /* Argument objects */
{
int index, result = TCL_OK;
static const char *const options[] = {"eval", "record", NULL};
enum option {OTHER_EVAL, OTHER_RECORD};
ConsoleInfo *info = clientData;
Tcl_Interp *otherInterp = info->interp;
if (objc < 2) {
Tcl_WrongNumArgs(interp, 1, objv, "option arg");
return TCL_ERROR;
}
if (Tcl_GetIndexFromObj(interp, objv[1], options, "option", 0, &index)
!= TCL_OK) {
return TCL_ERROR;
}
if (objc != 3) {
Tcl_WrongNumArgs(interp, 2, objv, "script");
return TCL_ERROR;
}
if ((otherInterp == NULL) || Tcl_InterpDeleted(otherInterp)) {
Tcl_AppendResult(interp, "no active master interp", NULL);
return TCL_ERROR;
}
Tcl_Preserve(otherInterp);
switch ((enum option) index) {
case OTHER_EVAL:
result = Tcl_GlobalEvalObj(otherInterp, objv[2]);
/*
* TODO: Should exceptions be filtered here?
*/
Tcl_SetReturnOptions(interp,
Tcl_GetReturnOptions(otherInterp, result));
Tcl_SetObjResult(interp, Tcl_GetObjResult(otherInterp));
break;
case OTHER_RECORD:
Tcl_RecordAndEvalObj(otherInterp, objv[2], TCL_EVAL_GLOBAL);
/*
* By not setting result, we discard any exceptions or errors here and
* always return TCL_OK. All the caller wants is the interp result to
* display, whether that's result or error message.
*/
Tcl_SetObjResult(interp, Tcl_GetObjResult(otherInterp));
break;
}
Tcl_Release(otherInterp);
return result;
}
static void
IvyDirectMsgCB(IvyClientPtr app,
void *user_data,
int id,
char *msg)
{
filter_struct *filter = (filter_struct *) user_data;
int result, size;
char *script_to_call;
char int_buffer[INTEGER_SPACE];
sprintf(int_buffer, "%d", id);
size = strlen(filter->script) + 1;
size += strlen(int_buffer) + 1;
size += strlen(msg) + 1;
script_to_call = ckalloc(size);
strcpy(script_to_call, filter->script);
strcat(script_to_call, " ");
strcat(script_to_call, int_buffer);
strcat(script_to_call, " \"");
strcat(script_to_call, msg);
strcat(script_to_call, "\"");
Tcl_Preserve(filter->interp);
result = Tcl_GlobalEval(filter->interp, script_to_call);
ckfree(script_to_call);
if (result != TCL_OK) {
Tcl_BackgroundError(filter->interp);
}
Tcl_Release(filter->interp);
}
static void
IvyDieCB(IvyClientPtr app,
void *user_data, /* script a appeler */
int id)
{
filter_struct *filter = (filter_struct *) user_data;
int result, size;
char idstr[INTEGER_SPACE];
char *script_to_call;
sprintf(idstr, "%d", id);
size = strlen(filter->script) + INTEGER_SPACE + 1;
script_to_call = ckalloc(size);
strcpy(script_to_call, filter->script);
strcat(script_to_call, " \"");
strcat(script_to_call, idstr);
strcat(script_to_call, "\"");
Tcl_Preserve(filter->interp);
result = Tcl_GlobalEval(filter->interp, script_to_call);
ckfree(script_to_call);
if (result != TCL_OK) {
Tcl_BackgroundError(filter->interp);
}
Tcl_Release(filter->interp);
}
static int
MenuButtonWidgetObjCmd(
ClientData clientData, /* Information about button widget. */
Tcl_Interp *interp, /* Current interpreter. */
int objc, /* Number of arguments. */
Tcl_Obj *const objv[]) /* Argument objects. */
{
register TkMenuButton *mbPtr = clientData;
int result, index;
Tcl_Obj *objPtr;
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(mbPtr);
switch (index) {
case COMMAND_CGET:
if (objc != 3) {
Tcl_WrongNumArgs(interp, 1, objv, "cget option");
goto error;
}
objPtr = Tk_GetOptionValue(interp, (char *) mbPtr,
mbPtr->optionTable, objv[2], mbPtr->tkwin);
if (objPtr == NULL) {
goto error;
}
Tcl_SetObjResult(interp, objPtr);
break;
case COMMAND_CONFIGURE:
if (objc <= 3) {
objPtr = Tk_GetOptionInfo(interp, (char *) mbPtr,
mbPtr->optionTable, (objc == 3) ? objv[2] : NULL,
mbPtr->tkwin);
if (objPtr == NULL) {
goto error;
}
Tcl_SetObjResult(interp, objPtr);
} else {
result = ConfigureMenuButton(interp, mbPtr, objc-2, objv+2);
}
break;
}
Tcl_Release(mbPtr);
return result;
error:
Tcl_Release(mbPtr);
return TCL_ERROR;
}
void
TkWmProtocolEventProc(
TkWindow *winPtr, /* Window to which the event was sent. */
XEvent *eventPtr) /* X event. */
{
WmInfo *wmPtr;
ProtocolHandler *protPtr;
Tcl_Interp *interp;
Atom protocol;
int result;
wmPtr = winPtr->wmInfoPtr;
if (wmPtr == NULL) {
return;
}
protocol = (Atom) eventPtr->xclient.data.l[0];
for (protPtr = wmPtr->protPtr; protPtr != NULL;
protPtr = protPtr->nextPtr) {
if (protocol == protPtr->protocol) {
Tcl_Preserve(protPtr);
interp = protPtr->interp;
Tcl_Preserve(interp);
result = Tcl_EvalEx(interp, protPtr->command, -1, TCL_EVAL_GLOBAL);
if (result != TCL_OK) {
Tcl_AddErrorInfo(interp, "\n (command for \"");
Tcl_AddErrorInfo(interp,
Tk_GetAtomName((Tk_Window) winPtr, protocol));
Tcl_AddErrorInfo(interp, "\" window manager protocol)");
Tcl_BackgroundError(interp);
}
Tcl_Release(interp);
Tcl_Release(protPtr);
return;
}
}
/*
* No handler was present for this protocol. If this is a WM_DELETE_WINDOW
* message then just destroy the window.
*/
if (protocol == Tk_InternAtom((Tk_Window) winPtr, "WM_DELETE_WINDOW")) {
Tk_DestroyWindow((Tk_Window) winPtr);
}
}
static void
IvyAppCB(IvyClientPtr app,
void *user_data, /* script a appeler */
IvyApplicationEvent event)
{
static const char *app_event_str[] = {
"Connected", "Disconnected" };
filter_struct *filter = (filter_struct *) user_data;
int result, size, dummy;
char *script_to_call;
Tcl_HashEntry *entry;
entry = Tcl_FindHashEntry(&app_table, IvyGetApplicationName(app));
if (event == IvyApplicationConnected) {
if (!entry) {
entry = Tcl_CreateHashEntry(&app_table, IvyGetApplicationName(app), &dummy);
Tcl_SetHashValue(entry, (ClientData) app);
}
}
size = strlen(filter->script) + INTEGER_SPACE;
if (entry) {
size += strlen(IvyGetApplicationName(app)) + 3;
}
else {
size += 4;
}
script_to_call = ckalloc(size);
strcpy(script_to_call, filter->script);
strcat(script_to_call, " ");
if (entry) {
strcat(script_to_call, " \"");
strcat(script_to_call, IvyGetApplicationName(app));
strcat(script_to_call, "\"");
}
else {
strcat(script_to_call, "???");
}
strcat(script_to_call, " \"");
strcat(script_to_call, app_event_str[event%2]);
strcat(script_to_call, "\"");
Tcl_Preserve(filter->interp);
result = Tcl_GlobalEval(filter->interp, script_to_call);
ckfree(script_to_call);
if (result != TCL_OK) {
Tcl_BackgroundError(filter->interp);
}
Tcl_Release(filter->interp);
if (event == IvyApplicationDisconnected) {
if (entry) {
Tcl_DeleteHashEntry(entry);
}
}
}
static int
PreprocessMenu(
TkMenu *menuPtr)
{
int index, result, finished;
ThreadSpecificData *tsdPtr = (ThreadSpecificData *)
Tcl_GetThreadData(&dataKey, sizeof(ThreadSpecificData));
Tcl_Preserve((ClientData) menuPtr);
/*
* First, let's process the post command on ourselves. If this command
* destroys this menu, or if there was an error, we are done.
*/
result = TkPostCommand(menuPtr);
if ((result != TCL_OK) || (menuPtr->tkwin == NULL)) {
goto done;
}
/*
* Now, we go through structure and process all of the commands. Since the
* structure is changing, we stop after we do one command, and start over.
* When we get through without doing any, we are done.
*/
do {
finished = 1;
for (index = 0; index < menuPtr->numEntries; index++) {
register TkMenuEntry *entryPtr = menuPtr->entries[index];
if ((entryPtr->type == CASCADE_ENTRY)
&& (entryPtr->namePtr != NULL)
&& (entryPtr->childMenuRefPtr != NULL)
&& (entryPtr->childMenuRefPtr->menuPtr != NULL)) {
TkMenu *cascadeMenuPtr = entryPtr->childMenuRefPtr->menuPtr;
if (cascadeMenuPtr->postCommandGeneration !=
tsdPtr->postCommandGeneration) {
cascadeMenuPtr->postCommandGeneration =
tsdPtr->postCommandGeneration;
result = PreprocessMenu(cascadeMenuPtr);
if (result != TCL_OK) {
goto done;
}
finished = 0;
break;
}
}
}
} while (!finished);
done:
Tcl_Release((ClientData) menuPtr);
return result;
}
static int
ThreadEventProc(
Tcl_Event *evPtr, /* Really ThreadEvent */
int mask)
{
ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);
ThreadEvent *threadEventPtr = (ThreadEvent *)evPtr;
ThreadEventResult *resultPtr = threadEventPtr->resultPtr;
Tcl_Interp *interp = tsdPtr->interp;
int code;
const char *result, *errorCode, *errorInfo;
if (interp == NULL) {
code = TCL_ERROR;
result = "no target interp!";
errorCode = "THREAD";
errorInfo = "";
} else {
Tcl_Preserve((ClientData) interp);
Tcl_ResetResult(interp);
Tcl_CreateThreadExitHandler(ThreadFreeProc,
(ClientData) threadEventPtr->script);
code = Tcl_GlobalEval(interp, threadEventPtr->script);
Tcl_DeleteThreadExitHandler(ThreadFreeProc,
(ClientData) threadEventPtr->script);
if (code != TCL_OK) {
errorCode = Tcl_GetVar(interp, "errorCode", TCL_GLOBAL_ONLY);
errorInfo = Tcl_GetVar(interp, "errorInfo", TCL_GLOBAL_ONLY);
} else {
errorCode = errorInfo = NULL;
}
result = Tcl_GetStringResult(interp);
}
ckfree(threadEventPtr->script);
if (resultPtr) {
Tcl_MutexLock(&threadMutex);
resultPtr->code = code;
resultPtr->result = ckalloc(strlen(result) + 1);
strcpy(resultPtr->result, result);
if (errorCode != NULL) {
resultPtr->errorCode = ckalloc(strlen(errorCode) + 1);
strcpy(resultPtr->errorCode, errorCode);
}
if (errorInfo != NULL) {
resultPtr->errorInfo = ckalloc(strlen(errorInfo) + 1);
strcpy(resultPtr->errorInfo, errorInfo);
}
Tcl_ConditionNotify(&resultPtr->done);
Tcl_MutexUnlock(&threadMutex);
}
if (interp != NULL) {
Tcl_Release((ClientData) interp);
}
return 1;
}
static int ThreadEventProc(Tcl_Event *event, int mask)
{
int code;
ThreadEvent *data = (ThreadEvent *)event; /* event is really a ThreadEvent */
Tcl_Preserve(data->interpreter);
code = Tcl_EvalEx(data->interpreter, data->script, -1, TCL_EVAL_GLOBAL);
Tcl_Free(data->script);
if (code != TCL_OK) {
ThreadErrorProc(data->interpreter);
}
Tcl_Release(data->interpreter);
return 1;
}
/* UpdateScrollbarBG --
* Idle handler to update the scrollbar.
*/
static void UpdateScrollbarBG(ClientData clientData)
{
ScrollHandle h = (ScrollHandle)clientData;
Tcl_Interp *interp = h->corePtr->interp;
int code;
h->flags &= ~SCROLL_UPDATE_PENDING;
Tcl_Preserve((ClientData) interp);
code = UpdateScrollbar(interp, h);
if (code == TCL_ERROR && !Tcl_InterpDeleted(interp)) {
Tcl_BackgroundError(interp);
}
Tcl_Release((ClientData) interp);
}
static int stateHandlerInvoke(Tcl_Event* p, int flags) {
/* called from Tcl event loop, when the connection status changes */
connectionEvent *cev =(connectionEvent *) p;
pvInfo *info = cev->info;
Tcl_Obj *script = Tcl_DuplicateObj(info->connectprefix);
Tcl_IncrRefCount(script);
/* append cmd of PV and up/down */
Tcl_Obj *cmdname = Tcl_NewObj();
Tcl_GetCommandFullName(info->interp, info->cmd, cmdname);
int code = Tcl_ListObjAppendElement(info->interp, script, cmdname);
if (code != TCL_OK) {
goto bgerr;
}
if (cev->op == CA_OP_CONN_UP) {
info->connected = 1;
/* Retrieve information about type and number of elements */
info->nElem = ca_element_count(info->id);
info->type = ca_field_type(info->id);
} else {
info->connected = 0;
}
code = Tcl_ListObjAppendElement(info->interp, script, Tcl_NewBooleanObj(info->connected));
if (code != TCL_OK) {
goto bgerr;
}
Tcl_Preserve(info->interp);
code = Tcl_EvalObjEx(info->interp, script, TCL_EVAL_GLOBAL);
if (code != TCL_OK) { goto bgerr; }
Tcl_Release(info->interp);
Tcl_DecrRefCount(script);
/* this event was successfully handled */
return 1;
bgerr:
/* put error in background */
Tcl_AddErrorInfo(info->interp, "\n (epics connection callback script)");
Tcl_BackgroundException(info->interp, code);
/* this event was successfully handled */
return 1;
}
Tcl_Interp *EM_CreateInterp(void) {
Tcl_Interp *interp;
#if WITH_DEBUGGING_INIT
ErrorLogger( NO_ERR_START, LOC, _proc_EM_CreateInterp, NULL);
#endif
interp = Tcl_CreateInterp();
/*
* avoid freeing storage when in use
*/
Tcl_Preserve(interp);
return interp;
} /** End of 'EM_CreateInterp' **/
int
TkClipInit(
Tcl_Interp *interp, /* Interpreter to use for error reporting. */
register TkDisplay *dispPtr)/* Display to initialize. */
{
XSetWindowAttributes atts;
dispPtr->clipTargetPtr = NULL;
dispPtr->clipboardActive = 0;
dispPtr->clipboardAppPtr = NULL;
/*
* Create the window used for clipboard ownership and selection retrieval,
* and set up an event handler for it.
*/
dispPtr->clipWindow = Tk_CreateWindow(interp, NULL, "_clip",
DisplayString(dispPtr->display));
if (dispPtr->clipWindow == NULL) {
return TCL_ERROR;
}
Tcl_Preserve(dispPtr->clipWindow);
atts.override_redirect = True;
Tk_ChangeWindowAttributes(dispPtr->clipWindow, CWOverrideRedirect, &atts);
Tk_MakeWindowExist(dispPtr->clipWindow);
if (dispPtr->multipleAtom == None) {
/*
* Need to invoke selection initialization to make sure that atoms we
* depend on below are defined.
*/
TkSelInit(dispPtr->clipWindow);
}
/*
* Create selection handlers for types TK_APPLICATION and TK_WINDOW on
* this window. Can't use the default handlers for these types because
* this isn't a full-fledged window.
*/
Tk_CreateSelHandler(dispPtr->clipWindow, dispPtr->clipboardAtom,
dispPtr->applicationAtom, ClipboardAppHandler, dispPtr,XA_STRING);
Tk_CreateSelHandler(dispPtr->clipWindow, dispPtr->clipboardAtom,
dispPtr->windowAtom, ClipboardWindowHandler, dispPtr, XA_STRING);
return TCL_OK;
}
pure_expr *tk(const char *s)
{
char *result = NULL;
if (tk_start(&result)) {
bool res;
/* Make sure that we don't pull the rug under ourselves. */
Tcl_Interp* _interp = interp;
Tcl_Preserve(_interp);
res = tk_eval(s, &result);
Tcl_Release(_interp);
if (res)
return (result&&*result)?pure_string(result):pure_tuplel(0);
else
return tk_error(result);
} else
return tk_error(result);
}
static pascal void
ScaleActionProc(
ControlRef theControl, /* Handle to scrollbat control */
ControlPartCode partCode) /* Part of scrollbar that was "hit" */
{
int value;
TkScale *scalePtr = (TkScale *) GetControlReference(theControl);
#ifdef TK_MAC_DEBUG_SCALE
TkMacOSXDbgMsg("ScaleActionProc");
#endif
value = GetControlValue(theControl);
TkScaleSetValue(scalePtr, value, 1, 1);
Tcl_Preserve((ClientData) scalePtr);
TkMacOSXRunTclEventLoop();
Tcl_Release((ClientData) scalePtr);
}
static void
AfterProc(
ClientData clientData) /* Describes command to execute. */
{
AfterInfo *afterPtr = clientData;
AfterAssocData *assocPtr = afterPtr->assocPtr;
AfterInfo *prevPtr;
int result;
Tcl_Interp *interp;
/*
* First remove the callback from our list of callbacks; otherwise someone
* could delete the callback while it's being executed, which could cause
* a core dump.
*/
if (assocPtr->firstAfterPtr == afterPtr) {
assocPtr->firstAfterPtr = afterPtr->nextPtr;
} else {
for (prevPtr = assocPtr->firstAfterPtr; prevPtr->nextPtr != afterPtr;
prevPtr = prevPtr->nextPtr) {
/* Empty loop body. */
}
prevPtr->nextPtr = afterPtr->nextPtr;
}
/*
* Execute the callback.
*/
interp = assocPtr->interp;
Tcl_Preserve(interp);
result = Tcl_EvalObjEx(interp, afterPtr->commandPtr, TCL_EVAL_GLOBAL);
if (result != TCL_OK) {
Tcl_AddErrorInfo(interp, "\n (\"after\" script)");
Tcl_BackgroundException(interp, result);
}
Tcl_Release(interp);
/*
* Free the memory for the callback.
*/
Tcl_DecrRefCount(afterPtr->commandPtr);
ckfree(afterPtr);
}
static HRESULT
Send(
TkWinSendCom *obj,
VARIANT vCmd,
VARIANT *pvResult,
EXCEPINFO *pExcepInfo,
UINT *puArgErr)
{
HRESULT hr = S_OK;
int result = TCL_OK;
VARIANT v;
register Tcl_Interp *interp = obj->interp;
Tcl_Obj *scriptPtr;
if (interp == NULL) {
return S_OK;
}
VariantInit(&v);
hr = VariantChangeType(&v, &vCmd, 0, VT_BSTR);
if (!SUCCEEDED(hr)) {
return hr;
}
scriptPtr = Tcl_NewUnicodeObj(v.bstrVal, (int) SysStringLen(v.bstrVal));
Tcl_Preserve(interp);
Tcl_IncrRefCount(scriptPtr);
result = Tcl_EvalObjEx(interp, scriptPtr,
TCL_EVAL_DIRECT | TCL_EVAL_GLOBAL);
Tcl_DecrRefCount(scriptPtr);
if (pvResult != NULL) {
VariantInit(pvResult);
pvResult->vt = VT_BSTR;
pvResult->bstrVal = SysAllocString(Tcl_GetUnicode(
Tcl_GetObjResult(interp)));
}
if (result == TCL_ERROR) {
hr = DISP_E_EXCEPTION;
TkWinSend_SetExcepInfo(interp, pExcepInfo);
}
Tcl_Release(interp);
VariantClear(&v);
return hr;
}
int
TkBackgroundEvalObjv(
Tcl_Interp *interp,
int objc,
Tcl_Obj *const *objv,
int flags)
{
Tcl_InterpState state;
int n, r = TCL_OK;
/*
* Record the state of the interpreter.
*/
Tcl_Preserve(interp);
state = Tcl_SaveInterpState(interp, TCL_OK);
/*
* Evaluate the command and handle any error.
*/
for (n = 0; n < objc; ++n) {
Tcl_IncrRefCount(objv[n]);
}
r = Tcl_EvalObjv(interp, objc, objv, flags);
for (n = 0; n < objc; ++n) {
Tcl_DecrRefCount(objv[n]);
}
if (r == TCL_ERROR) {
Tcl_AddErrorInfo(interp, "\n (background event handler)");
Tcl_BackgroundException(interp, r);
}
/*
* Restore the state of the interpreter.
*/
(void) Tcl_RestoreInterpState(interp, state);
Tcl_Release(interp);
return r;
}
int
TnmSnmpEvalBinding(Tcl_Interp *interp, TnmSnmp *session, TnmSnmpPdu *pdu, int event)
{
int code = TCL_OK;
TnmSnmpBinding *bindPtr = session->bindPtr;
while (bindPtr) {
if (bindPtr->event == event) break;
bindPtr = bindPtr->nextPtr;
}
if (bindPtr && bindPtr->command) {
Tcl_Preserve((ClientData) session);
code = TnmSnmpEvalCallback(interp, session, pdu, bindPtr->command,
NULL, NULL, NULL, NULL);
Tcl_Release((ClientData) session);
}
return code;
}
/* UpdateScrollbar --
* Call the -scrollcommand callback to sync the scrollbar.
* Returns: Whatever the -scrollcommand does.
*/
static int UpdateScrollbar(Tcl_Interp *interp, ScrollHandle h)
{
Scrollable *s = h->scrollPtr;
WidgetCore *corePtr = h->corePtr;
char arg1[TCL_DOUBLE_SPACE + 2];
char arg2[TCL_DOUBLE_SPACE + 2];
int code;
h->flags &= ~SCROLL_UPDATE_REQUIRED;
if (s->scrollCmd == NULL) {
return TCL_OK;
}
arg1[0] = arg2[0] = ' ';
Tcl_PrintDouble(interp, (double)s->first / s->total, arg1+1);
Tcl_PrintDouble(interp, (double)s->last / s->total, arg2+1);
Tcl_Preserve(corePtr);
code = Tcl_VarEval(interp, s->scrollCmd, arg1, arg2, NULL);
if (WidgetDestroyed(corePtr)) {
Tcl_Release(corePtr);
return TCL_ERROR;
}
Tcl_Release(corePtr);
if (code != TCL_OK && !Tcl_InterpDeleted(interp)) {
/* Disable the -scrollcommand, add to stack trace:
*/
ckfree(s->scrollCmd);
s->scrollCmd = 0;
Tcl_AddErrorInfo(interp, /* @@@ "horizontal" / "vertical" */
"\n (scrolling command executed by ");
Tcl_AddErrorInfo(interp, Tk_PathName(h->corePtr->tkwin));
Tcl_AddErrorInfo(interp, ")");
}
return code;
}
static void
IvyMsgCB(IvyClientPtr app,
void *user_data,
int argc,
char **argv)
{
filter_struct *filter = (filter_struct *) user_data;
int result, i, size;
char *script_to_call;
size = strlen(filter->script) + 3;
for (i = 0; i < argc; i++) {
size += strlen(argv[i]) + 3;
}
size ++;
size += strlen(IvyGetApplicationName(app))+4;
script_to_call = ckalloc(size);
strcpy(script_to_call, filter->script);
strcat(script_to_call, " \"");
strcat(script_to_call, IvyGetApplicationName(app));
strcat(script_to_call, "\"");
/* strcat(script_to_call, " {"); */
for (i = 0; i < argc; i++) {
strcat(script_to_call, " \"");
strcat(script_to_call, argv[i]);
strcat(script_to_call, "\"");
}
/* strcat(script_to_call, " }"); */
Tcl_Preserve(filter->interp);
result = Tcl_GlobalEval(filter->interp, script_to_call);
ckfree(script_to_call);
if (result != TCL_OK) {
Tcl_BackgroundError(filter->interp);
}
Tcl_Release(filter->interp);
}
static void
LostSelection(
ClientData clientData) /* Pointer to LostCommand structure. */
{
LostCommand *lostPtr = clientData;
Tcl_Obj *objPtr;
Tcl_Interp *interp;
int code;
interp = lostPtr->interp;
Tcl_Preserve(interp);
/*
* Execute the command. Save the interpreter's result, if any, and restore
* it after executing the command.
*/
objPtr = Tcl_GetObjResult(interp);
Tcl_IncrRefCount(objPtr);
Tcl_ResetResult(interp);
code = TkCopyAndGlobalEval(interp, lostPtr->command);
if (code != TCL_OK) {
Tcl_BackgroundException(interp, code);
}
Tcl_SetObjResult(interp, objPtr);
Tcl_DecrRefCount(objPtr);
Tcl_Release(interp);
/*
* Free the storage for the command, since we're done with it now.
*/
ckfree((char *) lostPtr);
}
static int
ConsoleObjCmd(
ClientData clientData, /* Access to the console interp */
Tcl_Interp *interp, /* Current interpreter */
int objc, /* Number of arguments */
Tcl_Obj *const objv[]) /* Argument objects */
{
int index, result;
static const char *const options[] = {"eval", "hide", "show", "title", NULL};
enum option {CON_EVAL, CON_HIDE, CON_SHOW, CON_TITLE};
Tcl_Obj *cmd = NULL;
ConsoleInfo *info = (ConsoleInfo *) clientData;
Tcl_Interp *consoleInterp = info->consoleInterp;
if (objc < 2) {
Tcl_WrongNumArgs(interp, 1, objv, "option ?arg?");
return TCL_ERROR;
}
if (Tcl_GetIndexFromObj(interp, objv[1], options, "option", 0, &index)
!= TCL_OK) {
return TCL_ERROR;
}
switch ((enum option) index) {
case CON_EVAL:
if (objc != 3) {
Tcl_WrongNumArgs(interp, 2, objv, "script");
return TCL_ERROR;
}
cmd = objv[2];
break;
case CON_HIDE:
if (objc != 2) {
Tcl_WrongNumArgs(interp, 2, objv, NULL);
return TCL_ERROR;
}
cmd = Tcl_NewStringObj("wm withdraw .", -1);
break;
case CON_SHOW:
if (objc != 2) {
Tcl_WrongNumArgs(interp, 2, objv, NULL);
return TCL_ERROR;
}
cmd = Tcl_NewStringObj("wm deiconify .", -1);
break;
case CON_TITLE:
if (objc > 3) {
Tcl_WrongNumArgs(interp, 2, objv, "?title?");
return TCL_ERROR;
}
cmd = Tcl_NewStringObj("wm title .", -1);
if (objc == 3) {
Tcl_ListObjAppendElement(NULL, cmd, objv[2]);
}
break;
}
Tcl_IncrRefCount(cmd);
if (consoleInterp && !Tcl_InterpDeleted(consoleInterp)) {
Tcl_Preserve(consoleInterp);
result = Tcl_GlobalEvalObj(consoleInterp, cmd);
Tcl_SetReturnOptions(interp,
Tcl_GetReturnOptions(consoleInterp, result));
Tcl_SetObjResult(interp, Tcl_GetObjResult(consoleInterp));
Tcl_Release(consoleInterp);
} else {
Tcl_AppendResult(interp, "no active console interp", NULL);
result = TCL_ERROR;
}
Tcl_DecrRefCount(cmd);
return result;
}
int
Tk_CreateConsoleWindow(
Tcl_Interp *interp) /* Interpreter to use for prompting. */
{
Tcl_Channel chan;
ConsoleInfo *info;
Tk_Window mainWindow;
Tcl_Command token;
int result = TCL_OK;
int haveConsoleChannel = 1;
/* Init an interp with Tcl and Tk */
Tcl_Interp *consoleInterp = Tcl_CreateInterp();
if (Tcl_Init(consoleInterp) != TCL_OK) {
goto error;
}
if (Tk_Init(consoleInterp) != TCL_OK) {
goto error;
}
/*
* Fetch the instance data from whatever std channel is a
* console channel. If none, create fresh instance data.
*/
if (Tcl_GetChannelType(chan = Tcl_GetStdChannel(TCL_STDIN))
== &consoleChannelType) {
} else if (Tcl_GetChannelType(chan = Tcl_GetStdChannel(TCL_STDOUT))
== &consoleChannelType) {
} else if (Tcl_GetChannelType(chan = Tcl_GetStdChannel(TCL_STDERR))
== &consoleChannelType) {
} else {
haveConsoleChannel = 0;
}
if (haveConsoleChannel) {
ChannelData *data = (ChannelData *) Tcl_GetChannelInstanceData(chan);
info = data->info;
if (info->consoleInterp) {
/* New ConsoleInfo for a new console window */
info = (ConsoleInfo *) ckalloc(sizeof(ConsoleInfo));
info->refCount = 0;
/* Update any console channels to make use of the new console */
if (Tcl_GetChannelType(chan = Tcl_GetStdChannel(TCL_STDIN))
== &consoleChannelType) {
data = (ChannelData *) Tcl_GetChannelInstanceData(chan);
data->info->refCount--;
data->info = info;
data->info->refCount++;
}
if (Tcl_GetChannelType(chan = Tcl_GetStdChannel(TCL_STDOUT))
== &consoleChannelType) {
data = (ChannelData *) Tcl_GetChannelInstanceData(chan);
data->info->refCount--;
data->info = info;
data->info->refCount++;
}
if (Tcl_GetChannelType(chan = Tcl_GetStdChannel(TCL_STDERR))
== &consoleChannelType) {
data = (ChannelData *) Tcl_GetChannelInstanceData(chan);
data->info->refCount--;
data->info = info;
data->info->refCount++;
}
}
} else {
info = (ConsoleInfo *) ckalloc(sizeof(ConsoleInfo));
info->refCount = 0;
}
info->consoleInterp = consoleInterp;
info->interp = interp;
Tcl_CallWhenDeleted(consoleInterp, InterpDeleteProc, info);
info->refCount++;
Tcl_CreateThreadExitHandler(DeleteConsoleInterp, consoleInterp);
/*
* Add console commands to the interp
*/
token = Tcl_CreateObjCommand(interp, "console", ConsoleObjCmd, info,
ConsoleDeleteProc);
info->refCount++;
/*
* We don't have to count the ref held by the [consoleinterp] command
* in the consoleInterp. The ref held by the consoleInterp delete
* handler takes care of us.
*/
Tcl_CreateObjCommand(consoleInterp, "consoleinterp", InterpreterObjCmd,
info, NULL);
mainWindow = Tk_MainWindow(interp);
if (mainWindow) {
Tk_CreateEventHandler(mainWindow, StructureNotifyMask,
ConsoleEventProc, info);
info->refCount++;
}
Tcl_Preserve(consoleInterp);
result = Tcl_GlobalEval(consoleInterp, "source $tk_library/console.tcl");
if (result == TCL_ERROR) {
Tcl_SetReturnOptions(interp,
Tcl_GetReturnOptions(consoleInterp, result));
Tcl_SetObjResult(interp, Tcl_GetObjResult(consoleInterp));
}
Tcl_Release(consoleInterp);
if (result == TCL_ERROR) {
Tcl_DeleteCommandFromToken(interp, token);
mainWindow = Tk_MainWindow(interp);
if (mainWindow) {
Tk_DeleteEventHandler(mainWindow, StructureNotifyMask,
ConsoleEventProc, info);
if (--info->refCount <= 0) {
ckfree((char *) info);
}
}
goto error;
}
return TCL_OK;
error:
Tcl_AddErrorInfo(interp, "\n (creating console window)");
if (!Tcl_InterpDeleted(consoleInterp)) {
Tcl_DeleteInterp(consoleInterp);
}
return TCL_ERROR;
}
