cpptcl.cc

cpptcl library for ns2

{
     obj_ = Tcl_NewIntObj(i);
     Tcl_IncrRefCount(obj_);
}

object::object(long l)
     : interp_(0)
{
     obj_ = Tcl_NewLongObj(l);
     Tcl_IncrRefCount(obj_);
}

object::object(char const *s)
     : interp_(0)
{
     obj_ = Tcl_NewStringObj(s, -1);
     Tcl_IncrRefCount(obj_);
}

object::object(string const &s)
     : interp_(0)
{
     obj_ = Tcl_NewStringObj(s.data(), static_cast<int>(s.size()));
     Tcl_IncrRefCount(obj_);
}

object::object(Tcl_Obj *o, bool shared)
     : interp_(0)
{
     init(o, shared);
}

object::object(object const &other, bool shared)
     : interp_(other.get_interp())
{
     init(other.obj_, shared);
}

void object::init(Tcl_Obj *o, bool shared)
{
     if (shared)
     {
          obj_ = o;
     }
     else
     {
          obj_ = Tcl_DuplicateObj(o);
     }
     Tcl_IncrRefCount(obj_);
}

object::~object()
{
     Tcl_DecrRefCount(obj_);
}

object & object::assign(bool b)
{
     Tcl_SetBooleanObj(obj_, b);
     return *this;
}

object & object::resize(size_t size)
{
     Tcl_SetByteArrayLength(obj_, static_cast<int>(size));
     return *this;
}

object & object::assign(char const *buf, size_t size)
{
     Tcl_SetByteArrayObj(obj_,
          reinterpret_cast<unsigned char const *>(buf),
          static_cast<int>(size));
     return *this;
}

object & object::assign(double d)
{
     Tcl_SetDoubleObj(obj_, d);
     return *this;
}

object & object::assign(int i)
{
     Tcl_SetIntObj(obj_, i);
     return *this;
}

object & object::assign(long l)
{
     Tcl_SetLongObj(obj_, l);
     return *this;
}

object & object::assign(char const *s)
{
     Tcl_SetStringObj(obj_, s, -1);
     return *this;
}

object & object::assign(string const &s)
{
     Tcl_SetStringObj(obj_, s.data(), static_cast<int>(s.size()));
     return *this;
}

object & object::assign(object const &other)
{
     object(other).swap(*this);
     return *this;
}

object & object::assign(Tcl_Obj *o)
{
     object(o).swap(*this);
     return *this;
}

object & object::swap(object &other)
{
     std::swap(obj_, other.obj_);
     std::swap(interp_, other.interp_);
     return *this;
}

template <>
bool object::get<bool>(interpreter &i) const
{
     int retVal;
     int res = Tcl_GetBooleanFromObj(i.get(), obj_, &retVal);
     if (res != TCL_OK)
     {
          throw tcl_error(i.get());
     }

     return static_cast<bool>(retVal);
}

template <>
vector<char> object::get<vector<char> >(interpreter &) const
{
     size_t size;
     char const *buf = get(size);
     return vector<char>(buf, buf + size);
}

template <>
double object::get<double>(interpreter &i) const
{
     double retVal;
     int res = Tcl_GetDoubleFromObj(i.get(), obj_, &retVal);
     if (res != TCL_OK)
     {
          throw tcl_error(i.get());
     }

     return retVal;
}

template <>
int object::get<int>(interpreter &i) const
{
     int retVal;

     int res = Tcl_GetIntFromObj(i.get(), obj_, &retVal);
     if (res != TCL_OK)
     {
          throw tcl_error(i.get());
     }

     return retVal;
}

template <>
long object::get<long>(interpreter &i) const
{
     long retVal;
     int res = Tcl_GetLongFromObj(i.get(), obj_, &retVal);
     if (res != TCL_OK)
     {
          throw tcl_error(i.get());
     }

     return retVal;
}

template <>
char const * object::get<char const *>(interpreter &) const
{
     return get();
}

template <>
string object::get<string>(interpreter &) const
{
     int len;
     char const *buf = Tcl_GetStringFromObj(obj_, &len);
     return string(buf, buf + len);
}

char const * object::get() const
{
     return Tcl_GetString(obj_);
}

char const * object::get(size_t &size) const
{
     int len;
     unsigned char *buf = Tcl_GetByteArrayFromObj(obj_, &len);
     size = len;
     return const_cast<char const *>(reinterpret_cast<char *>(buf));
}

size_t object::length(interpreter &i) const
{
     int len;
     int res = Tcl_ListObjLength(i.get(), obj_, &len);

     if (res != TCL_OK)
     {
          throw tcl_error(i.get());
     }

     return static_cast<size_t>(len);
}

object object::at(interpreter &i, size_t index) const
{
     Tcl_Obj *o;
     int res = Tcl_ListObjIndex(i.get(), obj_, static_cast<int>(index), &o);
     if (res != TCL_OK)
     {
          throw tcl_error(i.get());
     }
     if (o == NULL)
     {
          throw tcl_error("Index out of range.");
     }

     return object(o);
}

object & object::append(interpreter &i, object const &o)
{
     int res = Tcl_ListObjAppendElement(i.get(), obj_, o.obj_);
     if (res != TCL_OK)
     {
          throw tcl_error(i.get());
     }

     return *this;
}

object & object::append_list(interpreter &i, object const &o)
{
     int res = Tcl_ListObjAppendList(i.get(), obj_, o.obj_);
     if (res != TCL_OK)
     {
          throw tcl_error(i.get());
     }

     return *this;
}

object & object::replace(interpreter &i, size_t index, size_t count,
     object const &o)
{
     int res = Tcl_ListObjReplace(i.get(), obj_,
          static_cast<int>(index), static_cast<int>(count),
          1, &(o.obj_));
     if (res != TCL_OK)
     {
          throw tcl_error(i.get());
     }

     return *this;
}

object & object::replace_list(interpreter &i, size_t index, size_t count,
     object const &o)
{
     int objc;
     Tcl_Obj **objv;

     int res = Tcl_ListObjGetElements(i.get(), o.obj_, &objc, &objv);
     if (res != TCL_OK)
     {
          throw tcl_error(i.get());
     }

     res = Tcl_ListObjReplace(i.get(), obj_,
          static_cast<int>(index), static_cast<int>(count),
          objc, objv);
     if (res != TCL_OK)
     {
          throw tcl_error(i.get());
     }

     return *this;
}

void object::set_interp(Tcl_Interp *interp)
{
     interp_ = interp;
}

Tcl_Interp * object::get_interp() const
{
     return interp_;
}


interpreter::interpreter()
{
     interp_ =  Tcl_CreateInterp();
     owner_ = true;
}

interpreter::interpreter(Tcl_Interp *interp, bool owner)
{
     interp_ =  interp;
     owner_ = owner;
}

interpreter::~interpreter()
{
     if (owner_)
     {
          // clear all callback info belonging to this interpreter
          clear_definitions(interp_);

          Tcl_DeleteInterp(interp_);
     }
}

void interpreter::make_safe()
{
     int cc = Tcl_MakeSafe(interp_);
     if (cc != TCL_OK)
     {
          throw tcl_error(interp_);
     }
}

result interpreter::eval(string const &script)
{
     int cc = Tcl_Eval(interp_, script.c_str());
     if (cc != TCL_OK)
     {
          throw tcl_error(interp_);
     }
 
     return result(interp_);
}

result interpreter::eval(istream &s)
{
     string str(
          istreambuf_iterator<char>(s.rdbuf()),
          istreambuf_iterator<char>()
     );
     return eval(str);
}

result interpreter::eval(object const &o)
{
     int cc = Tcl_EvalObjEx(interp_, o.get_object(), 0);
     if (cc != TCL_OK)
     {
          throw tcl_error(interp_);
     }
 
     return result(interp_);
}

void interpreter::pkg_provide(string const &name, string const &version)
{
     int cc = Tcl_PkgProvide(interp_, name.c_str(), version.c_str());
     if (cc != TCL_OK)
     {
          throw tcl_error(interp_);
     }
}

void interpreter::create_alias(string const &cmd,
     interpreter &targetInterp, string const &targetCmd)
{
     int cc = Tcl_CreateAlias(interp_, cmd.c_str(),
          targetInterp.interp_, targetCmd.c_str(), 0, 0);
     if (cc != TCL_OK)
     {
          throw tcl_error(interp_);
     }
}

void interpreter::clear_definitions(Tcl_Interp *interp)
{
     // delete all callbacks that were registered for given interpreter

     {
          callback_map::iterator it = callbacks.find(interp);
          if (it == callbacks.end())
          {
               // no callbacks defined for this interpreter
               return;
          }

          callback_interp_map &imap = it->second;
          for (callback_interp_map::iterator it2 = imap.begin();
               it2 != imap.end(); ++it2)
          {
               Tcl_DeleteCommand(interp, it2->first.c_str());
          }

          callbacks.erase(interp);
     }

     // delete all constructors

     {
          callback_map::iterator it = constructors.find(interp);
          if (it == constructors.end())
          {
               // no callbacks defined for this interpreter
               return;
          }

          callback_interp_map &imap = it->second;
          for (callback_interp_map::iterator it2 = imap.begin();
               it2 != imap.end(); ++it2)
          {
               Tcl_DeleteCommand(interp, it2->first.c_str());
          }

          callbacks.erase(interp);
     }

     // delete all call policies

     call_policies.erase(interp);

     // delete all object handlers
     // (we have to assume that all living objects were destroyed,
     // otherwise Bad Things will happen)

     class_handlers.erase(interp);
}

void interpreter::add_function(string const &name,
     shared_ptr<callback_base> cb, policies const &p)
{
     Tcl_CreateObjCommand(interp_, name.c_str(),
          callback_handler, 0, 0);
     
     callbacks[interp_][name] = cb;
     call_policies[interp_][name] = p;
}

void interpreter::add_class(string const &name,
     shared_ptr<class_handler_base> chb)
{
     class_handlers[interp_][name] = chb;
}

void interpreter::add_constructor(string const &name,
     shared_ptr<class_handler_base> chb, shared_ptr<callback_base> cb,
     policies const &p)
{
     Tcl_CreateObjCommand(interp_, name.c_str(),
          constructor_handler, static_cast<ClientData>(chb.get()), 0);

     constructors[interp_][name] = cb;
     call_policies[interp_][name] = p;
}


int tcl_cast<int>::from(Tcl_Interp *interp, Tcl_Obj *obj)
{
     int res;
     int cc = Tcl_GetIntFromObj(interp, obj, &res);
     if (cc != TCL_OK)
     {
          throw tcl_error(interp);
     }
     
     return res;
}

long tcl_cast<long>::from(Tcl_Interp *interp, Tcl_Obj *obj)
{
     long res;
     int cc = Tcl_GetLongFromObj(interp, obj, &res);
     if (cc != TCL_OK)
     {
          throw tcl_error(interp);
     }
     
     return res;
}

bool tcl_cast<bool>::from(Tcl_Interp *interp, Tcl_Obj *obj)
{
     int res;
     int cc = Tcl_GetBooleanFromObj(interp, obj, &res);
     if (cc != TCL_OK)
     {
          throw tcl_error(interp);
     }
     
     return res != 0;
}

double tcl_cast<double>::from(Tcl_Interp *interp, Tcl_Obj *obj)
{
     double res;
     int cc = Tcl_GetDoubleFromObj(interp, obj, &res);
     if (cc != TCL_OK)
     {
          throw tcl_error(interp);
     }
     
     return res;
}

string tcl_cast<string>::from(Tcl_Interp *, Tcl_Obj *obj)
{
     return Tcl_GetString(obj);
}

char const * tcl_cast<char const *>::from(Tcl_Interp *, Tcl_Obj *obj)
{
     return Tcl_GetString(obj);
}

object tcl_cast<object>::from(Tcl_Interp *interp, Tcl_Obj *obj)
{
     object o(obj);
     o.set_interp(interp);

     return o;
}