469 lines
12 KiB
C
469 lines
12 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 */
|
|
snprintf(pBueffel,sizeof(pBueffel)-1, "%s %s %f", pPriv->pSetValue, pPriv->pArray, fNew);
|
|
iRet = Tcl_Eval(pPriv->pTcl, pBueffel);
|
|
if (iRet != TCL_OK) {
|
|
strlcpy(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 */
|
|
snprintf(pBueffel,sizeof(pBueffel)-1, "%s %s", pPriv->pGetValue, pPriv->pArray);
|
|
iRet = Tcl_Eval(pPriv->pTcl, pBueffel);
|
|
if (iRet != TCL_OK) {
|
|
strlcpy(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 */
|
|
snprintf(pBueffel,sizeof(pBueffel)-1, "%s %s %s", pPriv->pSend, pPriv->pArray, pCommand);
|
|
iRet = Tcl_Eval(pPriv->pTcl, pBueffel);
|
|
if (iRet != TCL_OK) {
|
|
strlcpy(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 {
|
|
strlcpy(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) {
|
|
snprintf(pBueffel,sizeof(pBueffel)-1,
|
|
"Your Tcl-script returned a stupid answer:\n --> %s <--",
|
|
pPriv->pTcl->result);
|
|
strlcpy(pReply, pBueffel, iReplyLen);
|
|
return 1;
|
|
}
|
|
|
|
/* build command line */
|
|
snprintf(pBueffel,sizeof(pBueffel)-1, "%s %s %d", pPriv->pGetError, pPriv->pArray,
|
|
pPriv->iLastError);
|
|
iRet = Tcl_Eval(pPriv->pTcl, pBueffel);
|
|
if (iRet != TCL_OK) {
|
|
strlcpy(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 {
|
|
strlcpy(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 */
|
|
snprintf(pBueffel,sizeof(pBueffel)-1, "%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 */
|
|
snprintf(pBueffel,sizeof(pBueffel)-1, "%s %s", pPriv->pInit, pPriv->pArray);
|
|
iRet = Tcl_Eval(pPriv->pTcl, pBueffel);
|
|
if (iRet != TCL_OK) {
|
|
strlcpy(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 */
|
|
snprintf(pBueffel,sizeof(pBueffel)-1, "%s %s", pPriv->pClose, pPriv->pArray);
|
|
iRet = Tcl_Eval(pPriv->pTcl, pBueffel);
|
|
if (iRet != TCL_OK) {
|
|
strlcpy(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);
|
|
|
|
snprintf(pBueffel,sizeof(pBueffel)-1, "%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 */
|
|
snprintf(pBueffel,sizeof(pBueffel)-1, "%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);
|
|
}
|
|
}
|