void
XOTclStackDump(Tcl_Interp *interp) {
Interp *iPtr = (Interp *)interp;
CallFrame *f = iPtr->framePtr, *v = iPtr->varFramePtr;
Tcl_Obj *varCmdObj;
XOTclNewObj(varCmdObj);
fprintf (stderr, " TCL STACK:\n");
if (f == 0) fprintf(stderr, "- ");
while (f) {
Tcl_Obj *cmdObj;
XOTclNewObj(cmdObj);
fprintf(stderr, "\tFrame=%p ", f);
if (f && f->isProcCallFrame && f->procPtr && f->procPtr->cmdPtr) {
fprintf(stderr,"caller %p ",Tcl_CallFrame_callerPtr(f));
fprintf(stderr,"callerV %p ",Tcl_CallFrame_callerVarPtr(f));
Tcl_GetCommandFullName(interp, (Tcl_Command) f->procPtr->cmdPtr, cmdObj);
fprintf(stderr, "%s (%p) lvl=%d\n", ObjStr(cmdObj), f->procPtr->cmdPtr, f->level);
DECR_REF_COUNT(cmdObj);
} else fprintf(stderr, "- \n");
f = f->callerPtr;
}
fprintf (stderr, " VARFRAME:\n");
fprintf(stderr, "\tFrame=%p", v);
if (v) {fprintf(stderr, "caller %p", v->callerPtr);}
if (v && v->isProcCallFrame && v->procPtr && v->procPtr->cmdPtr) {
Tcl_GetCommandFullName(interp, (Tcl_Command) v->procPtr->cmdPtr, varCmdObj);
if (varCmdObj) {
fprintf(stderr, " %s (%d)\n", ObjStr(varCmdObj), v->level);
}
} else fprintf(stderr, "- \n");
DECR_REF_COUNT(varCmdObj);
}
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);
}
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;
}
static Tcl_Obj *
Itcl_TclOOObjectName(
Tcl_Interp *interp,
Object *oPtr)
{
Tcl_Obj *namePtr;
if (oPtr->cachedNameObj) {
return oPtr->cachedNameObj;
}
namePtr = Tcl_NewObj();
Tcl_GetCommandFullName(interp, oPtr->command, namePtr);
Tcl_IncrRefCount(namePtr);
oPtr->cachedNameObj = namePtr;
return namePtr;
}
/*
* ------------------------------------------------------------------------
* 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);
}
}
/*
* ------------------------------------------------------------------------
* Itk_ArchOptConfigError()
*
* Simply utility which adds error information after a option
* configuration fails. Adds traceback information to the given
* interpreter.
* ------------------------------------------------------------------------
*/
void
Itk_ArchOptConfigError(
Tcl_Interp *interp, /* interpreter handling this object */
ArchInfo *info, /* info associated with mega-widget */
ArchOption *archOpt) /* configuration option that failed */
{
Tcl_Obj *objPtr;
objPtr = Tcl_NewStringObj((char*)NULL, 0);
Tcl_IncrRefCount(objPtr);
Tcl_AppendToObj(objPtr, "\n (while configuring option \"", -1);
Tcl_AppendToObj(objPtr, archOpt->switchName, -1);
Tcl_AppendToObj(objPtr, "\"", -1);
if (info->itclObj && info->itclObj->accessCmd) {
Tcl_AppendToObj(objPtr, " for widget \"", -1);
Tcl_GetCommandFullName(interp, info->itclObj->accessCmd, objPtr);
Tcl_AppendToObj(objPtr, "\")", -1);
}
Tcl_AddErrorInfo(interp, Tcl_GetStringFromObj(objPtr, (int*)NULL));
Tcl_DecrRefCount(objPtr);
}
/*
* ------------------------------------------------------------------------
* 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;
}
