cpptcl.cc

cpptcl library for ns2

//
// Copyright (C) 2004-2006, Maciej Sobczak
//
// Permission to copy, use, modify, sell and distribute this software
// is granted provided this copyright notice appears in all copies.
// This software is provided "as is" without express or implied
// warranty, and with no claim as to its suitability for any purpose.
//

#include "cpptcl.h"
#include <map>
#include <sstream>
#include <iterator>


using namespace Tcl;
using namespace Tcl::details;
using namespace std;
using namespace boost;


result::result(Tcl_Interp *interp) : interp_(interp) {}

result::operator bool() const
{
     Tcl_Obj *obj = Tcl_GetObjResult(interp_);
     
     int val, cc;
     cc = Tcl_GetBooleanFromObj(interp_, obj, &val);
     if (cc != TCL_OK)
     {
          throw tcl_error(interp_);
     }
     
     return static_cast<bool>(val);
}

result::operator double() const
{
     Tcl_Obj *obj = Tcl_GetObjResult(interp_);
     
     double val;
     int cc = Tcl_GetDoubleFromObj(interp_, obj, &val);
     if (cc != TCL_OK)
     {
          throw tcl_error(interp_);
     }
     
     return val;
}

result::operator int() const
{
     Tcl_Obj *obj = Tcl_GetObjResult(interp_);
     
     int val, cc;
     cc = Tcl_GetIntFromObj(interp_, obj, &val);
     if (cc != TCL_OK)
     {
          throw tcl_error(interp_);
     }
     
     return val;
}

result::operator long() const
{
     Tcl_Obj *obj = Tcl_GetObjResult(interp_);
     
     long val;
     int cc;
     cc = Tcl_GetLongFromObj(interp_, obj, &val);
     if (cc != TCL_OK)
     {
          throw tcl_error(interp_);
     }
     
     return val;
}

result::operator string() const
{
     Tcl_Obj *obj = Tcl_GetObjResult(interp_);
     return Tcl_GetString(obj);
}

result::operator object() const
{
     return object(Tcl_GetObjResult(interp_));
}


void details::set_result(Tcl_Interp *interp, bool b)
{
     Tcl_SetObjResult(interp, Tcl_NewBooleanObj(b));
}

void details::set_result(Tcl_Interp *interp, int i)
{
     Tcl_SetObjResult(interp, Tcl_NewIntObj(i));
}

void details::set_result(Tcl_Interp *interp, long i)
{
     Tcl_SetObjResult(interp, Tcl_NewLongObj(i));
}

void details::set_result(Tcl_Interp *interp, double d)
{
     Tcl_SetObjResult(interp, Tcl_NewDoubleObj(d));
}

void details::set_result(Tcl_Interp *interp, string const &s)
{
     Tcl_SetObjResult(interp,
          Tcl_NewStringObj(s.data(), static_cast<int>(s.size())));
}

void details::set_result(Tcl_Interp *interp, void *p)
{
     ostringstream ss;
     ss << 'p' << p;
     string s(ss.str());

     Tcl_SetObjResult(interp,
          Tcl_NewStringObj(s.data(), static_cast<int>(s.size())));
}

void details::set_result(Tcl_Interp *interp, object const &o)
{
     Tcl_SetObjResult(interp, o.get_object());
}


void details::check_params_no(int objc, int required)
{
     if (objc < required)
     {
          throw tcl_error("Too few arguments.");
     }
}

object details::get_var_params(Tcl_Interp *interp,
     int objc, Tcl_Obj * CONST objv[],
     int from, policies const &pol)
{
     object o;
     if (pol.variadic_)
     {
          check_params_no(objc, from);
          o.assign(objv + from, objv + objc);
     }
     else
     {
          check_params_no(objc, from + 1);
          o.assign(objv[from]);
     }

     o.set_interp(interp);

     return o;
}


namespace // anonymous
{

// map of polymorphic callbacks
typedef map<string, shared_ptr<callback_base> > callback_interp_map;
typedef map<Tcl_Interp *, callback_interp_map> callback_map;

callback_map callbacks;
callback_map constructors;

// map of call policies
typedef map<string, policies> policies_interp_map;
typedef map<Tcl_Interp *, policies_interp_map> policies_map;

policies_map call_policies;

// map of object handlers
typedef map<string, shared_ptr<class_handler_base> > class_interp_map;
typedef map<Tcl_Interp *, class_interp_map> class_handlers_map;

class_handlers_map class_handlers;


// helper for finding call policies - returns true when found
bool find_policies(Tcl_Interp *interp, string const &cmdName,
     policies_interp_map::iterator &piti)
{
     policies_map::iterator pit = call_policies.find(interp);
     if (pit == call_policies.end())
     {
          return false;
     }
     
     piti = pit->second.find(cmdName);
     return piti != pit->second.end();
}

extern "C"
int object_handler(ClientData cd, Tcl_Interp *interp,
     int objc, Tcl_Obj * CONST objv[]);

// helper function for post-processing call policies
// for both free functions (isMethod == false)
// and class methods (isMethod == true)
void post_process_policies(Tcl_Interp *interp, policies &pol,
     Tcl_Obj * CONST objv[], bool isMethod)
{
     // check if it is a factory
     if (!pol.factory_.empty())
     {
          class_handlers_map::iterator it = class_handlers.find(interp);
          if (it == class_handlers.end())
          {
               throw tcl_error(
                    "Factory was registered for unknown class.");
          }

          class_interp_map::iterator oit = it->second.find(pol.factory_);
          if (oit == it->second.end())
          {
               throw tcl_error(
                    "Factory was registered for unknown class.");
          }

          class_handler_base *chb = oit->second.get();

          // register a new command for the object returned
          // by this factory function
          // if everything went OK, the result is the address of the
          // new object in the 'pXXX' form
          // - the new command will be created with this name

          Tcl_CreateObjCommand(interp,
               Tcl_GetString(Tcl_GetObjResult(interp)),
               object_handler, static_cast<ClientData>(chb), 0);
     }

     // process all declared sinks
     // - unregister all object commands that envelopes the pointers
     for (vector<int>::iterator s = pol.sinks_.begin();
          s != pol.sinks_.end(); ++s)
     {
          if (isMethod == false)
          {
               // example: if there is a declared sink at parameter 3,
               // and the Tcl command was:
               // % fun par1 par2 PAR3 par4
               // then the index 3 correctly points into the objv array

               int index = *s;
               Tcl_DeleteCommand(interp, Tcl_GetString(objv[index]));
          }
          else
          {
               // example: if there is a declared sink at parameter 3,
               // and the Tcl command was:
               // % $p method par1 par2 PAR3 par4
               // then the index 3 needs to be incremented
               // in order correctly point into the 4th index of objv array

               int index = *s + 1;
               Tcl_DeleteCommand(interp, Tcl_GetString(objv[index]));
          }
     }
}

// actual functions handling various callbacks

// generic callback handler
extern "C"
int callback_handler(ClientData, Tcl_Interp *interp,
     int objc, Tcl_Obj * CONST objv[])
{
     callback_map::iterator it = callbacks.find(interp);
     if (it == callbacks.end())
     {
          Tcl_SetResult(interp,
               "Trying to invoke non-existent callback (wrong interpreter?)",
               TCL_STATIC);
          return TCL_ERROR;
     }
     
     string cmdName(Tcl_GetString(objv[0]));
     callback_interp_map::iterator iti = it->second.find(cmdName);
     if (iti == it->second.end())
     {
          Tcl_SetResult(interp,
               "Trying to invoke non-existent callback (wrong cmd name?)",
               TCL_STATIC);
          return TCL_ERROR;
     }
     
     policies_map::iterator pit = call_policies.find(interp);
     if (pit == call_policies.end())
     {
          Tcl_SetResult(interp,
               "Trying to invoke callback with no known policies",
               TCL_STATIC);
          return TCL_ERROR;
     }
     
     policies_interp_map::iterator piti;
     if (find_policies(interp, cmdName, piti) == false)
     {
          Tcl_SetResult(interp,
               "Trying to invoke callback with no known policies",
               TCL_STATIC);
          return TCL_ERROR;
     }

     policies &pol = piti->second;
     
     try
     {
          iti->second->invoke(interp, objc, objv, pol);

          post_process_policies(interp, pol, objv, false);
     }
     catch (exception const &e)
     {
          Tcl_SetResult(interp, const_cast<char*>(e.what()), TCL_VOLATILE);
          return TCL_ERROR;
     }
     catch (...)
     {
          Tcl_SetResult(interp, "Unknown error.", TCL_STATIC);
          return TCL_ERROR;
     }
     
     return TCL_OK;
}

// generic "object" command handler
extern "C"
int object_handler(ClientData cd, Tcl_Interp *interp,
     int objc, Tcl_Obj * CONST objv[])
{
     // here, client data points to the singleton object
     // which is responsible for managing commands for
     // objects of a given type

     class_handler_base *chb = reinterpret_cast<class_handler_base*>(cd);

     // the command name has the form 'pXXX' where XXX is the address
     // of the "this" object

     string const str(Tcl_GetString(objv[0]));
     istringstream ss(str);
     char dummy;
     void *p;
     ss >> dummy >> p;

     try
     {
          string methodName(Tcl_GetString(objv[1]));
          policies &pol = chb->get_policies(methodName);

          chb->invoke(p, interp, objc, objv, pol);

          post_process_policies(interp, pol, objv, true);
     }
     catch (exception const &e)
     {
          Tcl_SetResult(interp, const_cast<char*>(e.what()), TCL_VOLATILE);
          return TCL_ERROR;
     }
     catch (...)
     {
          Tcl_SetResult(interp, "Unknown error.", TCL_STATIC);
          return TCL_ERROR;
     }

     return TCL_OK;
}

// generic "constructor" command
extern "C"
int constructor_handler(ClientData cd, Tcl_Interp *interp,
     int objc, Tcl_Obj * CONST objv[])
{
     // here, client data points to the singleton object
     // which is responsible for managing commands for
     // objects of a given type

     class_handler_base *chb = reinterpret_cast<class_handler_base*>(cd);

     callback_map::iterator it = constructors.find(interp);
     if (it == constructors.end())
     {
          Tcl_SetResult(interp,
               "Trying to invoke non-existent callback (wrong interpreter?)",
               TCL_STATIC);
          return TCL_ERROR;
     }
     
     string className(Tcl_GetString(objv[0]));
     callback_interp_map::iterator iti = it->second.find(className);
     if (iti == it->second.end())
     {
          Tcl_SetResult(interp,
               "Trying to invoke non-existent callback (wrong class name?)",
               TCL_STATIC);
          return TCL_ERROR;
     }
     
     policies_interp_map::iterator piti;
     if (find_policies(interp, className, piti) == false)
     {
          Tcl_SetResult(interp,
               "Trying to invoke callback with no known policies",
               TCL_STATIC);
          return TCL_ERROR;
     }

     policies &pol = piti->second;

     try
     {
          iti->second->invoke(interp, objc, objv, pol);

          // if everything went OK, the result is the address of the
          // new object in the 'pXXX' form
          // - we can create a new command with this name

          Tcl_CreateObjCommand(interp,
               Tcl_GetString(Tcl_GetObjResult(interp)),
               object_handler, static_cast<ClientData>(chb), 0);
     }
     catch (exception const &e)
     {
          Tcl_SetResult(interp, const_cast<char*>(e.what()), TCL_VOLATILE);
          return TCL_ERROR;
     }
     catch (...)
     {
          Tcl_SetResult(interp, "Unknown error.", TCL_STATIC);
          return TCL_ERROR;
     }

     return TCL_OK;
}

} // namespace anonymous

Tcl::details::no_init_type Tcl::no_init;


policies & policies::factory(string const &name)
{
     factory_ = name;
     return *this;
}

policies & policies::sink(int index)
{
     sinks_.push_back(index);
     return *this;
}

policies & policies::variadic()
{
     variadic_ = true;
     return *this;
}

policies Tcl::factory(string const &name)
{
     return policies().factory(name);
}

policies Tcl::sink(int index)
{
     return policies().sink(index);
}

policies Tcl::variadic()
{
     return policies().variadic();
}


class_handler_base::class_handler_base()
{
     // default policies for the -delete command
     policies_["-delete"] = policies();
}

void class_handler_base::register_method(string const &name,
     shared_ptr<object_cmd_base> ocb, policies const &p)
{
     methods_[name] = ocb;
     policies_[name] = p;
}

policies & class_handler_base::get_policies(string const &name)
{
     policies_map_type::iterator it = policies_.find(name);
     if (it == policies_.end())
     {
          throw tcl_error("Trying to use non-existent policy: " + name);
     }

     return it->second;
}


object::object()
     : interp_(0)
{
     obj_ = Tcl_NewObj();
     Tcl_IncrRefCount(obj_);
}

object::object(bool b)
     : interp_(0)
{
     obj_ = Tcl_NewBooleanObj(b);
     Tcl_IncrRefCount(obj_);
}

object::object(char const *buf, size_t size)
     : interp_(0)
{
     obj_ = Tcl_NewByteArrayObj(
          reinterpret_cast<unsigned char const *>(buf),
          static_cast<int>(size));
     Tcl_IncrRefCount(obj_);
}

object::object(double d)
     : interp_(0)
{
     obj_ = Tcl_NewDoubleObj(d);
     Tcl_IncrRefCount(obj_);
}

object::object(int i)
     : interp_(0)