src/aclvis/InterpTcl.cpp

Go to the documentation of this file.

// -*- C++ -*-
/***************************************************************************
 *
 * The IPPL Framework
 * 
 * This program was prepared by PSI. 
 * All rights in the program are reserved by PSI.
 * Neither PSI nor the author(s)
 * makes any warranty, express or implied, or assumes any liability or
 * responsibility for the use of this software
 *
 * Visit http://www.acl.lanl.gov/POOMS for more details
 *
 ***************************************************************************/

// -*- C++ -*-
/***************************************************************************
 *
 * The IPPL Framework
 * 
 *
 * Visit http://people.web.psi.ch/adelmann/ for more details
 *
 ***************************************************************************/

#include "aclvis/InterpTcl.h"
#ifdef IPPL_USE_STANDARD_HEADERS
#include <iostream>
#include <fstream>
using namespace std;
#else
#include <iostream.h>
#include <fstream.h>
#endif
#include <stdio.h>
#include <stdlib.h>
#include <unistd.h>
#include <string.h>
#include <tcl.h>


// the callback function used by all tcl commands, which will call the
// the virtual function "process" in the proper InterpCmd object
int TclCallback(ClientData data, Tcl_Interp *interp, int argc, char *argv[]) {
  // recast the clientdata back to an InterpCmd, which it must be
  InterpCmd *cmd = static_cast<InterpCmd *>(data);

  // invoke the virtual function 'process' in this InterpCmd, which will
  // then do the actual work for this command.  Give it the argc, argv, and
  // an integer status variable.  It should return a pointer to a string
  // with the return value for the command.
  bool status;
  char *infobuf = cmd->process(argc, argv, status);

  // since this is Tcl, put this return information in Tcl structures.
  if (infobuf != 0 && *infobuf != 0) {
    cout << infobuf << endl;
    Tcl_SetResult(interp, infobuf, TCL_STATIC);
  }

  // and then return the proper error code
  return (status ? TCL_OK : TCL_ERROR);
}


// constructor
InterpTcl::InterpTcl(const char *nm) : Interp(nm) {
  // create a new TCL interpreter context
  interp = Tcl_CreateInterp();
}


// destructor
InterpTcl::~InterpTcl() {
  // shut down the interpreter
  Tcl_DeleteInterp(interp);
}


// Add a new command callback to the interpreter, by providing a InterpCmd.
void InterpTcl::addCommand(InterpCmd &cmd) { 
  // create a new command - set the callback to TclCallback, and the
  // clientdata to the given cmd, so that when the callback is called,
  // it can find the context for this new command
  Tcl_CreateCommand(interp, cmd.name(), TclCallback,
                    static_cast<ClientData>(&cmd), 0);
}


// Take the given string and have the interpreter evaluate it as a command.
// Return true if OK, false if an error occurred.
bool InterpTcl::evalCommand(const char *cmdstr) {
  // make sure we have something to do
  if (cmdstr == 0 || *cmdstr == 0)
    return true;

  // evaluate the command string using TCL
  char *buf = new char[strlen(cmdstr) + 1];
  strcpy(buf, cmdstr);
  int code = Tcl_Eval(interp, buf);

  // print out the result, if possible
  if (*(interp->result) != 0)
    cout << interp->result << endl;

  // and return if there was an error
  delete [] buf;
  return (code == TCL_OK);
}


// Bind a given variable to the given string variable name ... modifying
// the interpreter variable should then modify the bound variable.
// This is available for integer and double variables.
void InterpTcl::bindVar(const char *cmdstr, int &myvar) {
  Tcl_LinkVar(interp, const_cast<char *>(cmdstr) ,
              reinterpret_cast<char *>(&myvar), TCL_LINK_INT);
}


// Bind a given variable to the given string variable name ... modifying
// the interpreter variable should then modify the bound variable.
// This is available for integer and double variables.
void InterpTcl::bindVar(const char *cmdstr, double &myvar) {
  Tcl_LinkVar(interp, const_cast<char *>(cmdstr) ,
              reinterpret_cast<char *>(&myvar), TCL_LINK_DOUBLE);
}


/***************************************************************************
 * $RCSfile: InterpTcl.cpp,v $   $Author: adelmann $
 * $Revision: 1.1.1.1 $   $Date: 2003/01/23 07:40:34 $
 * IPPL_VERSION_ID: $Id: InterpTcl.cpp,v 1.1.1.1 2003/01/23 07:40:34 adelmann Exp $ 
 ***************************************************************************/

---