Ejemplo n.º 1
0
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);
}
Ejemplo n.º 2
0
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);
}
Ejemplo n.º 3
0
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;
}
Ejemplo n.º 4
0
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;
}
Ejemplo n.º 5
0
/*
 * ------------------------------------------------------------------------
 *  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);
    }
}
Ejemplo n.º 6
0
/*
 * ------------------------------------------------------------------------
 *  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);
}
Ejemplo n.º 7
0
/*
 * ------------------------------------------------------------------------
 *  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;
}