Initial revision
This commit is contained in:
cvs
530
tclev.c
Normal file
530
tclev.c
Normal file
@@ -0,0 +1,530 @@
|
||||
/*---------------------------------------------------------------------------
|
||||
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;
|
||||
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 = pCon->pSics->pTcl;
|
||||
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];
|
||||
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);
|
||||
}
|
||||
}
|
||||
Reference in New Issue
Block a user