- Added a means to overload or define drivable interfaces in tcl

make_gen

@@ -26,13 +26,12 @@ SOBJ =  network.o ifile.o conman.o SCinter.o splitter.o passwd.o \
        simchop.o choco.o chadapter.o  trim.o scaldate.o \
        hklscan.o xytable.o   \
        circular.o  maximize.o sicscron.o  \
-       d_sign.o d_mod.o \
+       d_sign.o d_mod.o tcldrivable.o \
        synchronize.o definealias.o  \
        hmcontrol.o userscan.o  rs232controller.o lomax.o \
        fourlib.o motreg.o motreglist.o anticollider.o \
        s_rnge.o sig_die.o gpibcontroller.o $(NIOBJ) \
-       hmdata.o  nxscript.o  \
+       hmdata.o  nxscript.o  tclintimpl.o sicsdata.o
-       tclintimpl.o sicsdata.o
  
 MOTOROBJ = motor.o  simdriv.o  
 COUNTEROBJ =  countdriv.o simcter.o counter.o

nserver.c

@@ -34,6 +34,7 @@
 #include "ofac.h"
 #include "telnet.h"
 #include "site.h"
+#include "tcldrivable.h"
 #include "nserver.h"
 
   int ServerSetupInterrupt(int iPort, pNetRead pNet, pTaskMan pTasker);
@@ -360,9 +361,6 @@
     /* Remove Status Callback */
     KillStatus(NULL);
     
-    /* close the List system */
-    LLDsystemClose();
-
     /*
       kill the site data structure
     */
@@ -372,6 +370,14 @@
       site->KillSite(site);
     }
 
+    /*
+      kill overloaded interfaces data
+    */
+    killTclDrivable();
+
+    /* close the List system */
+    LLDsystemClose();
+
     /* make fortify print his findings */
      Fortify_DumpAllMemory(iFortifyScope);
      Fortify_LeaveScope();

ofac.c

@@ -99,6 +99,7 @@
 #include "gpibcontroller.h"
 #include "nxscript.h"
 #include "tclintimpl.h"
+#include "tcldrivable.h"
 #include "sicsdata.h"
 #include "site.h"
 /*----------------------- Server options creation -------------------------*/
@@ -268,6 +269,8 @@
     AddCommand(pInter,"MakeGPIB",MakeGPIB,NULL,NULL);
     AddCommand(pInter,"MakeNXScript",MakeNXScript,NULL,NULL);
     AddCommand(pInter,"MakeTclInt",MakeTclInt,NULL,NULL);
+    AddCommand(pInter,"TclReplaceDrivable",TclReplaceDrivable,NULL,NULL);
+    AddCommand(pInter,"DrivableInvoke", TclDrivableInvoke,NULL,NULL);
 
     /*
       install site specific commands

sicsstatus.tcl

@@ -1,3 +0,0 @@
-# Counter counter
-counter SetPreset 100.000000
-counter SetMode Monitor

tcldrivable.c

@@ -0,0 +1,638 @@
+/*-----------------------------------------------------------------------
+  The code in this file allows to override or define Drivable
+  interfaces through tcl scripts. For more details, see
+  tcldrivable.tex
+
+  copyright: see file COPYRIGHT
+  
+  Mark Koennecke, September 2003
+  ----------------------------------------------------------------------*/
+#include <stdio.h>
+#include <assert.h>
+#include "sics.h"
+#include <tcl.h>
+#include "fortify.h"
+#include "lld.h"
+#include "tcldrivable.h"
+
+/*----------------------------------------------------------------------
+The index of the list used for keeping the dictionary for mapping drivable 
+ interface functions to scripts.
+ -------------------------------------------------------------------------*/
+static int tclDrivableDictionary = -1;
+
+/*=======================================================================
+   The structure used for keeping data associated with this scheme
+ --------------------------------------------------------------------------*/
+typedef   struct{
+    void *objectPointer;
+    char *tclName;
+    char *tclHalt;
+    char *tclCheckLimits;
+    char *tclSetValue;
+    char *tclCheckStatus;
+    char *tclGetValue;
+  }TclDrivable, *pTclDrivable; 
+
+/*=========================================================================
+  book keeping and search functions for the dictionary
+  -------------------------------------------------------------------------*/
+static void clearTclDrivable(pTclDrivable pNew){
+  memset(pNew,0,sizeof(TclDrivable));
+}
+/*-----------------------------------------------------------------------*/
+static void deleteTclDrivable(pTclDrivable target){
+  if(target->tclName != NULL){
+    free(target->tclName);
+  }
+  if(target->tclHalt != NULL){
+    free(target->tclHalt);
+  }
+  if(target->tclCheckLimits != NULL){
+    free(target->tclCheckLimits);
+  }
+  if(target->tclSetValue != NULL){
+    free(target->tclSetValue);
+  }
+  if(target->tclCheckStatus != NULL){
+    free(target->tclCheckStatus);
+  }
+  if(target->tclGetValue != NULL){
+    free(target->tclGetValue);
+  }
+}
+/*-------------- compare function for lld to find key in list 
+                 Function must return 0 if found                 --------*/
+static int tclDrivableCompare(const void *p1, const void *p2){
+  pTclDrivable pt1, pt2;
+
+  pt1 = (pTclDrivable)p1;
+  pt2 = (pTclDrivable)p2;
+
+  if(pt1->objectPointer == pt2->objectPointer){
+    return 0;
+  }
+  return 1;
+}
+/*--------------- assignFunction --------------------------------------*/
+static void assignFunction(pTclDrivable self, int functionIndex, 
+			   char *script){
+  switch(functionIndex){
+  case TCLHALT:
+    if(self->tclHalt != NULL){
+      free(self->tclHalt);
+    }
+    self->tclHalt = strdup(script);
+    break;
+  case TCLCHECK:
+    if(self->tclCheckLimits != NULL){
+      free(self->tclCheckLimits);
+    }
+    self->tclCheckLimits = strdup(script);
+    break;
+  case TCLSET:
+    if(self->tclSetValue != NULL){
+      free(self->tclSetValue);
+    }
+    self->tclSetValue = strdup(script);
+    break;
+  case TCLSTATUS:
+    if(self->tclCheckStatus != NULL){
+      free(self->tclCheckStatus);
+    }
+    self->tclCheckStatus = strdup(script);
+    break;
+  case TCLGET:
+    if(self->tclGetValue != NULL){
+      free(self->tclGetValue);
+    }
+    self->tclGetValue = strdup(script);
+    break;
+  default:
+    assert(0);
+  }
+}
+/*-----------------------------------------------------------------------*/
+static int registerTclDrivableFunction(void *objectPointer, 
+				       int functionIndex, 
+				       char *script,
+				       char *tclName){
+  TclDrivable entry;
+
+  /*
+    if no list: create it
+  */
+  if(tclDrivableDictionary < 0){
+    tclDrivableDictionary = LLDcreate(sizeof(TclDrivable));
+  }
+
+  /*
+    find entry, or create a new one if it does not exist
+  */
+  LLDnodePtr2First(tclDrivableDictionary);
+  entry.objectPointer = objectPointer;
+  if(LLDnodeFind(tclDrivableDictionary,tclDrivableCompare,
+		 &entry) == 0){
+    LLDnodeDataTo(tclDrivableDictionary,&entry);
+    if(strcmp(tclName,entry.tclName) != 0){
+      return 0;
+    }
+    assignFunction(&entry,functionIndex,script);
+    LLDnodeDataFrom(tclDrivableDictionary,&entry);
+  } else {
+    clearTclDrivable(&entry);
+    entry.objectPointer = objectPointer;
+    entry.tclName = strdup(tclName);
+    assignFunction(&entry,functionIndex,script);
+    LLDnodeAppendFrom(tclDrivableDictionary,&entry);
+  }
+  return 1;
+}
+/*-----------------------------------------------------------------*/
+static char *combine(char *t1, char *t2){
+  char *result = NULL;
+  int len;
+  
+  len = strlen(t1) + strlen(t2) + 3;
+  result = (char *)malloc(len*sizeof(char));
+  if(!result){
+    return NULL;
+  }
+  memset(result,0,len);
+  strcpy(result,t1);
+  strcat(result," ");
+  strcat(result,t2);
+  return result;
+}
+/*------------------------------------------------------------------*/
+static char *getTclDrivableCommand(void *objectPointer, 
+				   int functionIndex){
+  TclDrivable entry;
+
+  assert(tclDrivableDictionary > 0);
+  LLDnodePtr2First(tclDrivableDictionary);
+  entry.objectPointer = objectPointer;
+  if(LLDnodeFind(tclDrivableDictionary,tclDrivableCompare,&entry) == 0){
+    LLDnodeDataTo(tclDrivableDictionary,&entry);
+    switch(functionIndex){
+    case TCLHALT:
+      return combine(entry.tclHalt,entry.tclName);
+      break;
+    case TCLCHECK:
+      return combine(entry.tclCheckLimits,entry.tclName);
+      break;
+    case TCLSET:
+      return combine(entry.tclSetValue,entry.tclName);
+      break;
+    case TCLSTATUS:
+      return combine(entry.tclCheckStatus,entry.tclName);
+      break;
+    case TCLGET:
+      return combine(entry.tclGetValue,entry.tclName);
+      break;
+    default:
+      assert(0);
+    }
+  } else {
+    return NULL;
+  }
+}
+/*---------------------------------------------------------------------------*/
+void killTclDrivable(){
+  TclDrivable entry;
+  int stat;
+
+  if(tclDrivableDictionary > 0){
+    stat = LLDnodePtr2First(tclDrivableDictionary);
+    while(stat != 0){
+      LLDnodeDataTo(tclDrivableDictionary,&entry);
+      deleteTclDrivable(&entry);
+      stat = LLDnodePtr2Next(tclDrivableDictionary);
+    }
+    LLDdelete(tclDrivableDictionary);
+    tclDrivableDictionary = -1;
+  }
+}
+/*--------------------------------------------------------------------------*/
+int mapDrivableFunctionNames(char *name){
+  if(strcmp(name,"halt") == 0){
+    return TCLHALT;
+  }
+  if(strcmp(name,"checklimits") == 0){
+    return TCLCHECK;
+  }
+  if(strcmp(name,"setvalue") == 0){
+    return TCLSET;
+  }
+  if(strcmp(name,"checkstatus") == 0){
+    return TCLSTATUS;
+  }
+  if(strcmp(name,"getvalue") == 0){
+    return TCLGET;
+  }
+  return -1;
+}
+/*===========================================================================
+  The functions with which to overload the original functions
+----------------------------------------------------------------------------*/
+static int TclDrivableHalt(void *data){
+  char *command = NULL;
+  Tcl_Interp *pTcl;
+  int status;
+
+  pTcl = InterpGetTcl(pServ->pSics);
+  command = getTclDrivableCommand(data,TCLHALT);
+  if(command != NULL){
+    status = Tcl_Eval(pTcl,command);
+    if(status != TCL_OK){
+      fprintf(stderr,"Tcl ERROR: while invoking %s\n\tTcl reported %s\n",
+	      command,pTcl->result);
+      status = 0 ;
+    } else {
+      status = 1;
+    }
+    free(command);
+  } else {
+    status = 0;
+    fprintf(stderr,"Tcl ERROR: trying to invoke non existent Tcl %s\n",
+	    "drivable halt function");
+  }
+  return status;
+}
+/*--------------------------------------------------------------------*/
+static int TclDrivableCheckLimits(void *data, float fVal,
+				  char *error, int errlen){
+  char *commandPart1 = NULL;
+  char *command = NULL;
+  char pNum[30];
+  Tcl_Interp *pTcl;
+  int status;
+
+  pTcl = InterpGetTcl(pServ->pSics);
+  commandPart1 = getTclDrivableCommand(data,TCLCHECK);
+  if(commandPart1 != NULL){
+    sprintf(pNum,"%f",fVal);
+    command = combine(commandPart1,pNum);
+    if(command){
+      status = Tcl_Eval(pTcl,command);
+      if(status != TCL_OK){
+	strncpy(error,pTcl->result,errlen);
+	status = 0;
+      } else {
+	status = 1;
+      }
+      free(command);
+    } else {
+      fprintf(stderr,"Out of memory creating drivable command\n");
+      status = 0;
+    }
+    free(commandPart1);
+  } else {
+    status = 0;
+    fprintf(stderr,"Tcl ERROR: trying to invoke non existent Tcl %s\n",
+	    "drivable CheckLimits function");
+  }
+  return status;
+}
+/*--------------------------------------------------------------------------*/
+static long TclDrivableSetValue(void *data, SConnection *pCon, float fVal){
+  Tcl_Interp *pTcl;
+  int status;
+  char *commandHead = NULL, *command = NULL;
+  char pNum[30];
+
+  pTcl = InterpGetTcl(pServ->pSics);
+
+  /*
+    build and check command string
+  */
+  sprintf(pNum,"%f", fVal);
+  commandHead = getTclDrivableCommand(data,TCLSET);
+  if(commandHead == NULL){
+    SCWrite(pCon,
+     "ERROR: trying to invoke non existent Tcl drivable function SetValue",
+	    eError);
+    return HWFault;
+  }
+  command = combine(commandHead,pNum);
+  if(command == NULL){
+    SCWrite(pCon,"ERROR: out of memory creating tcl drivable SetValue command",
+	    eError);
+    return HWFault;
+  }
+
+  /*
+    invoke
+  */
+  status = Tcl_Eval(pTcl,command);
+  free(command);
+  free(commandHead);
+
+  if(status != TCL_OK){
+    SCWrite(pCon,"ERROR: Tcl drivable SetValue reported",eError);
+    SCWrite(pCon,pTcl->result,eError);
+    return HWFault;
+  }
+
+  status = atoi(pTcl->result);
+  return status;
+}
+/*--------------------------------------------------------------------------*/
+static int TclDrivableCheckStatus(void *data, SConnection *pCon){
+  Tcl_Interp *pTcl;
+  int status;
+  char *command = NULL;
+
+  pTcl = InterpGetTcl(pServ->pSics);
+
+  /*
+    build and check command string
+  */
+  command = getTclDrivableCommand(data,TCLSTATUS);
+  if(command == NULL){
+    SCWrite(pCon,
+	    "ERROR: Tcl drivable CheckStatus not found!",
+	    eError);
+    return HWFault;
+  }
+
+  /*
+    invoke
+  */
+  status = Tcl_Eval(pTcl,command);
+  free(command);
+
+  if(status != TCL_OK){
+    SCWrite(pCon,"ERROR: Tcl drivable CheckStatus reported",eError);
+    SCWrite(pCon,pTcl->result,eError);
+    return HWFault;
+  }
+
+  status = atoi(pTcl->result);
+  return status;
+}
+/*--------------------------------------------------------------------------*/
+static float TclDrivableGetValue(void *data, SConnection *pCon){
+  Tcl_Interp *pTcl;
+  int status;
+  char *command = NULL;
+
+  pTcl = InterpGetTcl(pServ->pSics);
+
+  /*
+    build and check command string
+  */
+  command = getTclDrivableCommand(data,TCLGET);
+  if(command == NULL){
+    SCWrite(pCon,
+	    "ERROR: Tcl drivable GetValue not found!",
+	    eError);
+    return -999999.99;
+  }
+
+  /*
+    invoke
+  */
+  status = Tcl_Eval(pTcl,command);
+  free(command);
+
+  if(status != TCL_OK){
+    SCWrite(pCon,"ERROR: Tcl drivable GetValue reported",eError);
+    SCWrite(pCon,pTcl->result,eError);
+    return -99999.99;
+  }
+
+  return atof(pTcl->result);
+}
+/*======================================================================
+   The function for doing it alltogether
+------------------------------------------------------------------------*/
+int replaceDrivableByTcl(void *commandData, int functionIndex,
+			 char *script, char *tclName){
+  pIDrivable pDriv = NULL;
+  int status;
+
+  pDriv =  GetDrivableInterface(commandData);
+  assert(pDriv != NULL);
+
+  /*
+    register the new script
+  */
+  status = registerTclDrivableFunction(commandData,functionIndex,
+				       script,tclName);
+  if(status <= 0){
+    return status;
+  }
+
+  /*
+    replace the appropriate Drivable function
+  */
+  switch(functionIndex){
+  case TCLHALT:
+    pDriv->Halt = TclDrivableHalt;
+    break;
+  case TCLCHECK:
+    pDriv->CheckLimits  = TclDrivableCheckLimits;
+    break;
+  case TCLSET:
+    pDriv->SetValue = TclDrivableSetValue;
+    break;
+  case TCLSTATUS:
+    pDriv->CheckStatus = TclDrivableCheckStatus;
+    break;
+  case TCLGET:
+    pDriv->GetValue = TclDrivableGetValue;
+    break;
+  default:
+    assert(0);
+    break;
+  }
+  return 1;
+}
+/*=========================================================================
+            Interpreter Interface
+------------------------------------------------------------------------*/
+int TclReplaceDrivable(SConnection *pCon, SicsInterp *pSics, 
+		       void *pData, int argc, char *argv[]){
+  pIDrivable pDriv = NULL;
+  void *commandData;
+  CommandList *pCom = NULL;
+  int functionIndex, status;
+  char pBueffel[256];
+
+  /*
+    only managers can do this!
+  */
+  if(!SCMatchRights(pCon,usMugger)){
+    return 0;
+  }
+
+  /*
+    we need tons of arguments!
+  */
+  if(argc < 5){
+    SCWrite(pCon,"ERROR: not enough arguments to TclReplaceDrivable",
+	    eError);
+    return 0;
+  }
+
+  /*
+    get and check object
+  */
+  strtolower(argv[1]);
+  pDriv = FindDrivable(pSics,argv[1]);
+  if(!pDriv){
+    snprintf(pBueffel,255,"ERROR: %s is not drivable!",argv[1]);
+    SCWrite(pCon,pBueffel,eError);
+    return 0;
+  }
+  /*
+    This must work as FindDrivable could not work else 
+  */
+  pCom = FindCommand(pSics,argv[1]);
+  commandData = pCom->pData;
+
+  /*
+    convert and check function name
+  */
+  strtolower(argv[2]);
+  functionIndex = mapDrivableFunctionNames(argv[2]);
+  if(functionIndex <= 0){
+    snprintf(pBueffel,255,
+       "ERROR: %s is not a known function name for drivable",
+	     argv[2]);
+    SCWrite(pCon,pBueffel,eError);
+    return 0;
+  }
+
+  status = replaceDrivableByTcl(commandData,functionIndex,argv[3],
+				argv[4]);
+  if(status <= 0){
+    SCWrite(pCon,"ERROR mismatch in parameter tclName",eError);
+    return 0;
+  }
+  SCSendOK(pCon);
+  return 1;
+}
+/*-----------------------------------------------------------------------*/
+int TclDrivableInvoke(SConnection *pCon, SicsInterp *pSics, 
+		      void *pData, int argc, char *argv[]){
+  pIDrivable pDriv = NULL;
+  void *commandData;
+  CommandList *pCom = NULL;
+  int functionIndex, status;
+  char pBueffel[256], pError[132];
+  float fVal;
+
+  /*
+    we need tons of arguments!
+  */
+  if(argc < 3){
+    SCWrite(pCon,"ERROR: not enough arguments to TclDrivableInvoke",
+	    eError);
+    return 0;
+  }
+
+  /*
+    get and check object
+  */
+  strtolower(argv[1]);
+  pDriv = FindDrivable(pSics,argv[1]);
+  if(!pDriv){
+    snprintf(pBueffel,255,"ERROR: %s is not drivable!",argv[1]);
+    SCWrite(pCon,pBueffel,eError);
+    return 0;
+  }
+  /*
+    This must work as FindDrivable could not work else 
+  */
+  pCom = FindCommand(pSics,argv[1]);
+  commandData = pCom->pData;
+
+  /*
+    convert and check function name
+  */
+  strtolower(argv[2]);
+  functionIndex = mapDrivableFunctionNames(argv[2]);
+  if(functionIndex <= 0){
+    snprintf(pBueffel,255,
+       "ERROR: %s is not a known function name for drivable",
+	     argv[2]);
+    SCWrite(pCon,pBueffel,eError);
+    return 0;
+  }
+
+  /*
+    invoke and report
+  */
+  switch(functionIndex){
+  case TCLHALT:
+    if(!pDriv->Halt){
+      SCWrite(pCon,"ERROR: no drivable Halt function!",eError);
+      return 0;
+    }
+    status = pDriv->Halt(commandData);
+    snprintf(pBueffel,255,"Drivable Halt returned: %d",status);
+    SCWrite(pCon,pBueffel,eValue);
+    break;
+  case TCLCHECK:
+    if(!pDriv->CheckLimits){
+      SCWrite(pCon,"ERROR: no drivable CheckLimits function!",eError);
+      return 0;
+    }
+    if(argc < 4){
+      SCWrite(pCon,"ERROR: need drive target for CheckLimits",eError);
+      return 0;
+    }
+    status = pDriv->CheckLimits(commandData,atof(argv[3]),pError,131);
+    snprintf(pBueffel,255,"Drivable CheckLimits returned: %d, %s",
+	     status,pError);
+    SCWrite(pCon,pBueffel,eValue);
+    break;
+  case TCLSET:
+    if(!pDriv->SetValue){
+      SCWrite(pCon,"ERROR: no drivable SetValue function!",eError);
+      return 0;
+    }
+    if(argc < 4){
+      SCWrite(pCon,"ERROR: need drive target for SetValue",eError);
+      return 0;
+    }
+    status = (int)pDriv->SetValue(commandData,pCon,atof(argv[3]));
+    snprintf(pBueffel,255,"Drivable SetValue returned %d", status);
+    SCWrite(pCon,pBueffel,eValue);
+    break;
+  case TCLSTATUS:
+    if(!pDriv->CheckStatus){
+      SCWrite(pCon,"ERROR: no drivable CheckStatus function!",eError);
+      return 0;
+    }
+    status = pDriv->CheckStatus(commandData,pCon);
+    snprintf(pBueffel,255,"Drivable CheckStatus returned %d", status);
+    SCWrite(pCon,pBueffel,eValue);
+    break;
+  case TCLGET:
+    if(!pDriv->GetValue){
+      SCWrite(pCon,"ERROR: no drivable GetValue function!",eError);
+      return 0;
+    }
+    fVal = pDriv->GetValue(commandData,pCon);
+    snprintf(pBueffel,255,"Drivable GetValue returned: %f", fVal);
+    SCWrite(pCon,pBueffel,eValue);
+    break;
+  default:
+    /*
+      do not know how I could get here
+    */
+    assert(0);
+  }
+
+  return 1;
+}
+
+
+
+
+
+
+

tcldrivable.h

@@ -0,0 +1,53 @@
+
+/*-----------------------------------------------------------------------
+  The code in this file allows to override or define Drivable
+  interfaces through tcl scripts. More more details, see
+  tcldrivable.tex
+
+  copyright: see file COPYRIGHT
+  
+  Mark Koennecke, September 2003
+  ----------------------------------------------------------------------*/
+#ifndef SICSTCLDRIVABLE 
+#define SICSTCLDRIVABLE 
+
+/*
+  Function codes for  functionIndex
+*/
+#define TCLHALT    1
+#define TCLCHECK   2
+#define TCLSET     3
+#define TCLSTATUS  4
+#define TCLGET     5
+
+  /*
+    This installs a Tcl replacement for a drivable function
+  */
+  int TclReplaceDrivable(SConnection *pCon, SicsInterp *pSics, 
+                         void *pData, int argc, char *argv[]);
+  /*
+    This allows to invoke a replaced function for debugging
+    purposes
+  */
+  int TclDrivableInvoke(SConnection *pCon, SicsInterp *pSics, 
+                         void *pData, int argc, char *argv[]);
+  
+  /*
+    This is for use from C
+  */
+  int replaceDrivableByTcl(void *sicsObject, int functionIndex,
+                           char *scriptName, char *tclName); 
+
+  /*
+    map name to a functionIndex for use in replaceDrivableByTcl.
+    Returns 0 on failure, a usefule index > 0 in the case of success
+  */
+  int mapDrivableFunctionNames(char *name);
+
+  /*
+    This is called from StopServer/nserver.c in order to remove
+    all memory related to this class
+  */
+  void killTclDrivable(void);
+#endif
+

tcldrivable.w

@@ -0,0 +1,119 @@
+\subsection{Tcl Drivable Interface}
+This is a module which allows to override or specify a drivable
+interface through Tcl procedures. The corresponding member function
+of the drivable interface will be replaced by a function which does
+the following things:
+\begin{itemize}
+\item Given the object pointer as key, it will find a data structure
+which holds the name of the Tcl procedure to invoke and a user
+specified name (general to this interface) which the Tcl procedure can
+use in order to locate instance specific data. 
+\item With this data, a Tcl command is constructed.
+\item This Tcl command is then invoked.
+\item Suitable Tcl commands return the numeric equivalents of the HW*
+codes returned by the equivalent ANSII C functions. 
+\end{itemize} 
+Overrriding a drivable interface functions is done by a call like:
+\begin{verbatim}
+DrivableTclReplace objectName functionName tclReplaceProcedure tclName
+\end{verbatim} 
+
+In order to implement a drivable completely in Tcl, create an empty
+object with MakeTclInt and assign functions with
+DrivableTclReplace. Please note that SICS will die if any of the
+required functions is left out!
+
+The first thing needed in order to implement this scheme is a data
+structure holding the necessary information. This data structure also
+doubles as an entry into the dictionary for mapping object pointers to
+the corresponding data structure. This dictionary is implemented on
+top of the general linked list package used within SICS. The index to
+this linked list is kept as a module static within the implementation
+file for this object. This is also where the original for this data
+structure is placed. 
+
+\begin{verbatim}
+  struct{
+    void *objectPointer;
+    char *tclName;
+    char *tclHalt;
+    char *tclCheckLimits;
+    char *tclSetValue;
+    char *tclCheckStatus;
+    char *tclGetValue;
+  }TclDrivable, *pTclDrivable; 
+\end{verbatim}
+
+The fields in this data structure:
+\begin{description}
+\item[objectPointer] A pointer to the SICS object this overloaded
+interface belongs to. Also used as key in searches.
+\item[tclName] The name passed over to the Tcl procedures in order to
+allow them to find application specific data.
+\item[tclHalt] A replacement Halt Tcl script.
+\item[tclCheckLimits] A Tcl script for replacing the CheckLimits
+function.
+\item[tclSetvalue] A replacement for the Setvalue function.
+\item[tclCheckStatus] a replacement for the CheckStatus function.
+\item[tclGetValue] a replacement for the GetValue function. 
+\end{description}
+
+The interface of this module to SICS is mainly its interpreter
+functions. In order to allow for configuring Tcl functions from C  a
+function is provided.
+
+@o tcldrivable.h @{
+/*-----------------------------------------------------------------------
+  The code in this file allows to override or define Drivable
+  interfaces through tcl scripts. More more details, see
+  tcldrivable.tex
+
+  copyright: see file COPYRIGHT
+  
+  Mark Koennecke, September 2003
+  ----------------------------------------------------------------------*/
+#ifndef SICSTCLDRIVABLE 
+#define SICSTCLDRIVABLE 
+
+/*
+  Function codes for  functionIndex
+*/
+#define TCLHALT    1
+#define TCLCHECK   2
+#define TCLSET     3
+#define TCLSTATUS  4
+#define TCLGET     5
+
+  /*
+    This installs a Tcl replacement for a drivable function
+  */
+  int TclReplaceDrivable(SConnection *pCon, SicsInterp *pSics, 
+			 void *pData, int argc, char *argv[]);
+  /*
+    This allows to invoke a replaced function for debugging
+    purposes
+  */
+  int TclDrivableInvoke(SConnection *pCon, SicsInterp *pSics, 
+			 void *pData, int argc, char *argv[]);
+  
+  /*
+    This is for use from C
+  */
+  int replaceDrivableByTcl(void *sicsObject, int functionIndex,
+			   char *scriptName, char *tclName); 
+
+  /*
+    map name to a functionIndex for use in replaceDrivableByTcl.
+    Returns 0 on failure, a usefule index > 0 in the case of success
+  */
+  int mapDrivableFunctionNames(char *name);
+
+  /*
+    This is called from StopServer/nserver.c in order to remove
+    all memory related to this class
+  */
+  void killTclDrivable(void);
+#endif
+
+@} 
+

tclintimpl.c

@@ -19,6 +19,7 @@
 /*================== our data structure ===================================*/
 typedef struct {
   pObjectDescriptor pDes;
+  pIDrivable pDriv;
   char *saveScript;
   FILE *fd;
 } tclInt, *pTclInt;
@@ -48,6 +49,20 @@ static int TclSaveStatus(void *pData, char *name, FILE *fd){
 
   return 1;
 }
+/*-----------------------------------------------------------------------*/
+static void *TclGetInterface(void *pData, int id){
+  pTclInt self = NULL;
+  self = (pTclInt)pData;
+  if(self == NULL){
+    return NULL;
+  }
+
+  if(id == DRIVEID){
+    return self->pDriv;
+  } else {
+    return NULL;
+  }
+}
 /*======================== data structure creation and deletion ==========*/
 static pTclInt MakeTclIntData(void){
   pTclInt pNew = NULL;
@@ -59,7 +74,9 @@ static pTclInt MakeTclIntData(void){
   memset(pNew,0,sizeof(tclInt));
   pNew->pDes = CreateDescriptor("SICS Interfaces in Tcl");
   pNew->pDes->SaveStatus = TclSaveStatus;
-  if(!pNew->pDes){
+  pNew->pDes->GetInterface = TclGetInterface;
+  pNew->pDriv = CreateDrivableInterface();
+  if(!pNew->pDes || !pNew->pDriv){
     free(pNew);
     return NULL;
   }
@@ -80,6 +97,9 @@ static void KillTclInt(void *pData){
   if(self->saveScript != NULL){
     free(self->saveScript);
   }
+  if(self->pDriv){
+    free(self->pDriv);
+  }
   free(self);
 }
 /*=============== interpreter interface + helper functions =============*/
@@ -154,3 +174,4 @@ int TclIntAction(SConnection *pCon, SicsInterp *pSics, void *pData,
 
   return 1;
 }
+