533 lines
14 KiB
C
533 lines
14 KiB
C
/*---------------------------------------------------------------------------
|
|
T C L E N V I R O N M E N T
|
|
|
|
This is the implementation file for the Tcl driver to a environment
|
|
device. For more documentation see tclev.tex or the apropriate section
|
|
in the reference manual.
|
|
|
|
copyright: see copyright.h
|
|
|
|
Mark Koennecke, February 1998
|
|
|
|
-----------------------------------------------------------------------------*/
|
|
#include <tcl.h>
|
|
#include "sics.h"
|
|
#include "splitter.h"
|
|
#include "fortify.h"
|
|
#include "obpar.h"
|
|
#include "evcontroller.h"
|
|
#include "evcontroller.i"
|
|
#include "evdriver.i"
|
|
#include "tclev.h"
|
|
#include "tclev.i"
|
|
#define STUPIDTCL -1023
|
|
/*----------------------------------------------------------------------------
|
|
The first section starts with the definition of the wrappers for all the driver
|
|
functions.
|
|
-----------------------------------------------------------------------------*/
|
|
static int TclSetValue(pEVDriver self, float fNew)
|
|
{
|
|
pTclEv pPriv = NULL;
|
|
char pBueffel[1024];
|
|
int iRet, iErrCode;
|
|
|
|
pPriv = (pTclEv)self->pPrivate;
|
|
assert(pPriv);
|
|
|
|
/* build command line */
|
|
sprintf(pBueffel,"%s %s %f",pPriv->pSetValue, pPriv->pArray, fNew);
|
|
iRet = Tcl_Eval(pPriv->pTcl,pBueffel);
|
|
if(iRet != TCL_OK)
|
|
{
|
|
strncpy(pBueffel,pPriv->pTcl->result,1023);
|
|
iRet = Tcl_GetInt(pPriv->pTcl,pBueffel,&iErrCode);
|
|
if(iRet != TCL_OK)
|
|
{
|
|
pPriv->iLastError = STUPIDTCL;
|
|
return 0;
|
|
}
|
|
pPriv->iLastError = iErrCode;
|
|
return 0;
|
|
}
|
|
return 1;
|
|
}
|
|
/*-------------------------------------------------------------------------*/
|
|
static int TclGetValue(pEVDriver self, float *fVal)
|
|
{
|
|
pTclEv pPriv = NULL;
|
|
char pBueffel[1024];
|
|
int iRet, iErrCode;
|
|
double d;
|
|
|
|
pPriv = (pTclEv)self->pPrivate;
|
|
assert(pPriv);
|
|
|
|
/* build command line */
|
|
sprintf(pBueffel,"%s %s",pPriv->pGetValue, pPriv->pArray);
|
|
iRet = Tcl_Eval(pPriv->pTcl,pBueffel);
|
|
if(iRet != TCL_OK)
|
|
{
|
|
strncpy(pBueffel,pPriv->pTcl->result,1023);
|
|
iRet = Tcl_GetInt(pPriv->pTcl,pBueffel,&iErrCode);
|
|
if(iRet != TCL_OK)
|
|
{
|
|
pPriv->iLastError = STUPIDTCL;
|
|
return 0;
|
|
}
|
|
pPriv->iLastError = iErrCode;
|
|
return 0;
|
|
}
|
|
else
|
|
{
|
|
if(strstr(pPriv->pTcl->result,"pending") != NULL)
|
|
{
|
|
*fVal = 90.;
|
|
return -1;
|
|
}
|
|
iRet = Tcl_GetDouble(pPriv->pTcl,pPriv->pTcl->result,&d);
|
|
if(iRet != TCL_OK)
|
|
{
|
|
pPriv->iLastError = STUPIDTCL;
|
|
return 0;
|
|
}
|
|
else
|
|
{
|
|
*fVal = (float)d;
|
|
return 1;
|
|
}
|
|
}
|
|
return 1;
|
|
}
|
|
/*-------------------------------------------------------------------------*/
|
|
static int TclSend(pEVDriver self, char *pCommand,
|
|
char *pReply, int iReplyLen)
|
|
{
|
|
pTclEv pPriv = NULL;
|
|
char pBueffel[1024];
|
|
int iRet, iErrCode;
|
|
double d;
|
|
|
|
pPriv = (pTclEv)self->pPrivate;
|
|
assert(pPriv);
|
|
|
|
/* build command line */
|
|
sprintf(pBueffel,"%s %s %s",pPriv->pSend, pPriv->pArray,pCommand);
|
|
iRet = Tcl_Eval(pPriv->pTcl,pBueffel);
|
|
if(iRet != TCL_OK)
|
|
{
|
|
strncpy(pBueffel,pPriv->pTcl->result,1023);
|
|
iRet = Tcl_GetInt(pPriv->pTcl,pBueffel,&iErrCode);
|
|
if(iRet != TCL_OK)
|
|
{
|
|
pPriv->iLastError = STUPIDTCL;
|
|
return 0;
|
|
}
|
|
pPriv->iLastError = iErrCode;
|
|
return 0;
|
|
}
|
|
else
|
|
{
|
|
strncpy(pReply,pPriv->pTcl->result,iReplyLen);
|
|
}
|
|
return 1;
|
|
}
|
|
/*--------------------------------------------------------------------------*/
|
|
static int TclGetError(pEVDriver self, int *iCode,
|
|
char *pReply, int iReplyLen)
|
|
{
|
|
pTclEv pPriv = NULL;
|
|
char pBueffel[1024];
|
|
int iRet, iErrCode;
|
|
double d;
|
|
|
|
pPriv = (pTclEv)self->pPrivate;
|
|
assert(pPriv);
|
|
|
|
/* do the iCode first */
|
|
*iCode = pPriv->iLastError;
|
|
|
|
/* catch the stupid Tcl thing */
|
|
if(pPriv->iLastError == STUPIDTCL)
|
|
{
|
|
sprintf(pBueffel,"Your Tcl-script returned a stupid answer:\n --> %s <--",
|
|
pPriv->pTcl->result);
|
|
strncpy(pReply,pBueffel,iReplyLen);
|
|
return 1;
|
|
}
|
|
|
|
/* build command line */
|
|
sprintf(pBueffel,"%s %s %d",pPriv->pGetError, pPriv->pArray,pPriv->iLastError);
|
|
iRet = Tcl_Eval(pPriv->pTcl,pBueffel);
|
|
if(iRet != TCL_OK)
|
|
{
|
|
strncpy(pBueffel,pPriv->pTcl->result,1023);
|
|
iRet = Tcl_GetInt(pPriv->pTcl,pPriv->pTcl->result,&iErrCode);
|
|
if(iRet != TCL_OK)
|
|
{
|
|
pPriv->iLastError = STUPIDTCL;
|
|
return 0;
|
|
}
|
|
pPriv->iLastError = iErrCode;
|
|
return 0;
|
|
}
|
|
else
|
|
{
|
|
strncpy(pReply,pPriv->pTcl->result,iReplyLen);
|
|
}
|
|
return 1;
|
|
}
|
|
/*--------------------------------------------------------------------------*/
|
|
static int TclTryFixIt(pEVDriver self, int iCode)
|
|
{
|
|
pTclEv pPriv = NULL;
|
|
char pBueffel[1024];
|
|
int iRet, iErrCode;
|
|
double d;
|
|
|
|
pPriv = (pTclEv)self->pPrivate;
|
|
assert(pPriv);
|
|
|
|
|
|
/* catch the stupid Tcl thing */
|
|
if(iCode == STUPIDTCL)
|
|
{
|
|
return DEVREDO;
|
|
}
|
|
|
|
/* build command line */
|
|
sprintf(pBueffel,"%s %s %d",pPriv->pTryFixIt, pPriv->pArray,iCode);
|
|
iRet = Tcl_Eval(pPriv->pTcl,pBueffel);
|
|
if(iRet != TCL_OK)
|
|
{
|
|
return DEVFAULT;
|
|
}
|
|
else
|
|
{
|
|
if(strcmp(pPriv->pTcl->result,"DEVFAULT") == 0)
|
|
{
|
|
return DEVFAULT;
|
|
}
|
|
else if(strcmp(pPriv->pTcl->result,"DEVREDO") == 0)
|
|
{
|
|
return DEVREDO;
|
|
}
|
|
else if(strcmp(pPriv->pTcl->result,"DEVOK") == 0)
|
|
{
|
|
return DEVOK;
|
|
}
|
|
else
|
|
{
|
|
pPriv->iLastError = STUPIDTCL;
|
|
return 0;
|
|
}
|
|
}
|
|
return 1;
|
|
}
|
|
/*-------------------------------------------------------------------------*/
|
|
static int TclInit(pEVDriver self)
|
|
{
|
|
pTclEv pPriv = NULL;
|
|
char pBueffel[1024];
|
|
int iRet, iErrCode;
|
|
|
|
pPriv = (pTclEv)self->pPrivate;
|
|
assert(pPriv);
|
|
|
|
/* build command line */
|
|
sprintf(pBueffel,"%s %s",pPriv->pInit, pPriv->pArray);
|
|
iRet = Tcl_Eval(pPriv->pTcl,pBueffel);
|
|
if(iRet != TCL_OK)
|
|
{
|
|
strncpy(pBueffel,pPriv->pTcl->result,1023);
|
|
iRet = Tcl_GetInt(pPriv->pTcl,pBueffel,&iErrCode);
|
|
if(iRet != TCL_OK)
|
|
{
|
|
pPriv->iLastError = STUPIDTCL;
|
|
return 0;
|
|
}
|
|
pPriv->iLastError = iErrCode;
|
|
return 0;
|
|
}
|
|
return 1;
|
|
}
|
|
/*--------------------------------------------------------------------------*/
|
|
static int TclClose(pEVDriver self)
|
|
{
|
|
pTclEv pPriv = NULL;
|
|
char pBueffel[1024];
|
|
int iRet, iErrCode;
|
|
|
|
pPriv = (pTclEv)self->pPrivate;
|
|
assert(pPriv);
|
|
|
|
/* build command line */
|
|
sprintf(pBueffel,"%s %s",pPriv->pClose, pPriv->pArray);
|
|
iRet = Tcl_Eval(pPriv->pTcl,pBueffel);
|
|
if(iRet != TCL_OK)
|
|
{
|
|
strncpy(pBueffel,pPriv->pTcl->result,1023);
|
|
iRet = Tcl_GetInt(pPriv->pTcl,pBueffel,&iErrCode);
|
|
if(iRet != TCL_OK)
|
|
{
|
|
pPriv->iLastError = STUPIDTCL;
|
|
return 0;
|
|
}
|
|
pPriv->iLastError = iErrCode;
|
|
return 0;
|
|
}
|
|
return 1;
|
|
}
|
|
/*---------------------------------------------------------------------------*/
|
|
static void KillPrivate(void *pData)
|
|
{
|
|
pTclEv pPriv = NULL;
|
|
|
|
pPriv = (pTclEv)pData;
|
|
assert(pPriv);
|
|
|
|
if(pPriv->pArray)
|
|
{
|
|
free(pPriv->pArray);
|
|
}
|
|
if(pPriv->pInit)
|
|
{
|
|
free(pPriv->pInit);
|
|
}
|
|
if(pPriv->pClose)
|
|
{
|
|
free(pPriv->pClose);
|
|
}
|
|
if(pPriv->pSetValue)
|
|
{
|
|
free(pPriv->pSetValue);
|
|
}
|
|
if(pPriv->pGetValue)
|
|
{
|
|
free(pPriv->pGetValue);
|
|
}
|
|
if(pPriv->pSend)
|
|
{
|
|
free(pPriv->pSend);
|
|
}
|
|
if(pPriv->pGetError)
|
|
{
|
|
free(pPriv->pGetError);
|
|
}
|
|
if(pPriv->pTryFixIt)
|
|
{
|
|
free(pPriv->pTryFixIt);
|
|
}
|
|
if(pPriv->pWrapper)
|
|
{
|
|
free(pPriv->pWrapper);
|
|
}
|
|
if(pPriv->pName)
|
|
{
|
|
free(pPriv->pName);
|
|
}
|
|
free(pPriv);
|
|
}
|
|
/*-----------------------------------------------------------------------*/
|
|
pEVDriver CreateTclDriver(int argc, char *argv[],char *pName,
|
|
SConnection *pCon)
|
|
{
|
|
pEVDriver pNew = NULL;
|
|
pTclEv pPriv = NULL;
|
|
int iRet;
|
|
/* the "const" saves us from a couple of warnings M.Z.*/
|
|
const char *pPtr = NULL;
|
|
|
|
if(argc < 1)/* we expect a Tcl array with all data */
|
|
{
|
|
return NULL;
|
|
}
|
|
|
|
pPriv = (pTclEv)malloc(sizeof(TclEv));
|
|
if(!pPriv)
|
|
{
|
|
return NULL;
|
|
}
|
|
memset(pPriv,0,sizeof(TclEv));
|
|
|
|
/* find the names of all the functions we need in the Tcl Array */
|
|
pPriv->pTcl = InterpGetTcl(pServ->pSics);
|
|
assert(pPriv->pTcl);
|
|
pPriv->pArray = strdup(argv[0]);
|
|
pPtr = Tcl_GetVar2(pPriv->pTcl,argv[0],"Init",TCL_GLOBAL_ONLY);
|
|
if(!pPtr)
|
|
{
|
|
SCWrite(pCon,"ERROR: Init script not found",eError);
|
|
KillPrivate(pPriv);
|
|
return NULL;
|
|
}
|
|
else
|
|
{
|
|
pPriv->pInit = strdup(pPtr);
|
|
}
|
|
pPtr = NULL;
|
|
pPtr = Tcl_GetVar2(pPriv->pTcl,argv[0],"Close",TCL_GLOBAL_ONLY);
|
|
if(!pPtr)
|
|
{
|
|
SCWrite(pCon,"ERROR: Close script not found",eError);
|
|
KillPrivate(pPriv);
|
|
return NULL;
|
|
}
|
|
else
|
|
{
|
|
pPriv->pClose = strdup(pPtr);
|
|
}
|
|
pPtr = NULL;
|
|
pPtr = Tcl_GetVar2(pPriv->pTcl,argv[0],"SetValue",TCL_GLOBAL_ONLY);
|
|
if(!pPtr)
|
|
{
|
|
SCWrite(pCon,"ERROR: SetValue script not found",eError);
|
|
KillPrivate(pPriv);
|
|
return NULL;
|
|
}
|
|
else
|
|
{
|
|
pPriv->pSetValue = strdup(pPtr);
|
|
}
|
|
pPtr = NULL;
|
|
pPtr = Tcl_GetVar2(pPriv->pTcl,argv[0],"GetValue",TCL_GLOBAL_ONLY);
|
|
if(!pPtr)
|
|
{
|
|
SCWrite(pCon,"ERROR: GetValue script not found",eError);
|
|
KillPrivate(pPriv);
|
|
return NULL;
|
|
}
|
|
else
|
|
{
|
|
pPriv->pGetValue = strdup(pPtr);
|
|
}
|
|
pPtr = Tcl_GetVar2(pPriv->pTcl,argv[0],"Send",TCL_GLOBAL_ONLY);
|
|
if(!pPtr)
|
|
{
|
|
SCWrite(pCon,"ERROR: Send script not found",eError);
|
|
KillPrivate(pPriv);
|
|
return NULL;
|
|
}
|
|
else
|
|
{
|
|
pPriv->pSend = strdup(pPtr);
|
|
}
|
|
pPtr = NULL;
|
|
pPtr = Tcl_GetVar2(pPriv->pTcl,argv[0],"GetError",TCL_GLOBAL_ONLY);
|
|
if(!pPtr)
|
|
{
|
|
SCWrite(pCon,"ERROR: GetError script not found",eError);
|
|
KillPrivate(pPriv);
|
|
return NULL;
|
|
}
|
|
else
|
|
{
|
|
pPriv->pGetError = strdup(pPtr);
|
|
}
|
|
pPtr = NULL;
|
|
pPtr = Tcl_GetVar2(pPriv->pTcl,argv[0],"TryFixIt",TCL_GLOBAL_ONLY);
|
|
if(!pPtr)
|
|
{
|
|
SCWrite(pCon,"ERROR: TryFixIt script not found",eError);
|
|
KillPrivate(pPriv);
|
|
return NULL;
|
|
}
|
|
else
|
|
{
|
|
pPriv->pTryFixIt = strdup(pPtr);
|
|
}
|
|
pPtr = NULL;
|
|
pPtr = Tcl_GetVar2(pPriv->pTcl,argv[0],"Wrapper",TCL_GLOBAL_ONLY);
|
|
if(!pPtr)
|
|
{
|
|
SCWrite(pCon,"ERROR: Wrapper script not found",eError);
|
|
KillPrivate(pPriv);
|
|
return NULL;
|
|
}
|
|
else
|
|
{
|
|
pPriv->pWrapper = strdup(pPtr);
|
|
}
|
|
|
|
/* well all there, do the driver */
|
|
pNew = CreateEVDriver(argc,argv);
|
|
if(!pNew)
|
|
{
|
|
KillPrivate(pPriv);
|
|
return NULL;
|
|
}
|
|
|
|
/* handle the name */
|
|
pPriv->pName = strdup(pName);
|
|
pPtr = Tcl_SetVar2(pPriv->pTcl,argv[0],"MyName",pName, TCL_GLOBAL_ONLY);
|
|
|
|
/* initialise driver and functions */
|
|
pNew->pPrivate = pPriv;
|
|
pNew->SetValue = TclSetValue;
|
|
pNew->GetValue = TclGetValue;
|
|
pNew->Send = TclSend;
|
|
pNew->GetError = TclGetError;
|
|
pNew->TryFixIt = TclTryFixIt;
|
|
pNew->Init = TclInit;
|
|
pNew->Close = TclClose;
|
|
pNew->KillPrivate = KillPrivate;
|
|
|
|
/* driver loaded, ready steady fire! */
|
|
return pNew;
|
|
}
|
|
/*-------------------------------------------------------------------------*/
|
|
int UpdateTclVariable(pEVDriver self, char *name, float fVal)
|
|
{
|
|
pTclEv pPriv = NULL;
|
|
char pBueffel[132];
|
|
const char *pPtr = NULL;
|
|
|
|
assert(self);
|
|
pPriv = (pTclEv)self->pPrivate;
|
|
assert(pPriv);
|
|
|
|
sprintf(pBueffel,"%f",fVal);
|
|
pPtr = Tcl_SetVar2(pPriv->pTcl,pPriv->pArray,name,
|
|
pBueffel,TCL_GLOBAL_ONLY);
|
|
if(pPtr == NULL)
|
|
{
|
|
return 0;
|
|
}
|
|
return 1;
|
|
}
|
|
#define MAXLEN 2048
|
|
/*--------------------------------------------------------------------------*/
|
|
int TclEnvironmentWrapper(SConnection *pCon, SicsInterp *pSics,
|
|
void *pData, int argc, char *argv[])
|
|
{
|
|
int iRet, i;
|
|
char pBueffel[MAXLEN+1];
|
|
pTclEv pPriv = NULL;
|
|
pEVControl pEv = NULL;
|
|
|
|
pEv = (pEVControl)pData;
|
|
assert(pEv);
|
|
pPriv = pEv->pDriv->pPrivate;
|
|
assert(pPriv);
|
|
|
|
/* build command line */
|
|
sprintf(pBueffel,"%s %s",pPriv->pWrapper,pPriv->pArray);
|
|
for(i = 1; i < argc; i++)
|
|
{
|
|
if((strlen(pBueffel) + strlen(argv[i])) < MAXLEN)
|
|
{
|
|
strcat(pBueffel," ");
|
|
strcat(pBueffel,argv[i]);
|
|
}
|
|
}
|
|
/* execute Tcl */
|
|
iRet = Tcl_Eval(pPriv->pTcl,pBueffel);
|
|
if(iRet == TCL_OK)
|
|
{
|
|
return 1;
|
|
}
|
|
else
|
|
{
|
|
return EVControlWrapper(pCon,pSics,pData,argc,argv);
|
|
}
|
|
}
|