Version 2 of C++ object-style Tcl example extension

Updated 2008-04-15 12:09:50 by jdc

This piece of C++ code implements a simple Tcl extension. The API as seen from Tcl is:

example::createCreates a new example object and returns the object handle
handle pingPing the object
handle destroyDestroy the object
#include "tcl.h"

#include <iostream>

class MyObjectData {
    int id;
public:
    MyObjectData(int iid) : id(iid) {}
    void ping() { std::cout << "pong from " << id << std::endl; }
};

extern "C" int example_obj_command(ClientData     clientData, 
				   Tcl_Interp*    interp,
				   int	    objc,
				   Tcl_Obj* const objv[]) 
{
    if (objc < 2) {
	Tcl_WrongNumArgs(interp, 1, objv, "method ?argument ...?");
	return TCL_ERROR;
    }
  
    static const char* methods[] = {"ping", "destroy", NULL};
    enum ExObjMethods {EXOBJ_PING, EXOBJ_DESTROY};

    int index = -1;

    if (Tcl_GetIndexFromObj(interp, objv[1], methods, "method", 0,
			    &index) != TCL_OK)
	return TCL_ERROR;

    MyObjectData* p = (MyObjectData*)clientData;

    switch((ExObjMethods)index) {
    case EXOBJ_PING:
	p->ping();
	break;
    case EXOBJ_DESTROY:
	Tcl_DeleteCommand(interp, Tcl_GetString(objv[0]));
	delete p;
	break;
    }
    
    return TCL_OK;
}

extern "C" int example_create(ClientData     clientData, 
			      Tcl_Interp*    interp,
			      int	    objc,
			      Tcl_Obj* const objv[]) 
{
    static int obj_count = 0;

    MyObjectData* p = new MyObjectData(obj_count);
    
    char obj_name[13 + TCL_INTEGER_SPACE];
    sprintf(obj_name, "::exampleobj%d", obj_count++);
    
    Tcl_CreateObjCommand(interp, obj_name,
			 (Tcl_ObjCmdProc*)example_obj_command,
			 (ClientData) p, (Tcl_CmdDeleteProc *) NULL);

    Tcl_SetObjResult(interp, Tcl_NewStringObj(obj_name, strlen(obj_name)));
   
    return TCL_OK;
}

extern "C" DLLEXPORT int Example_Init(Tcl_Interp *interp)
{
    if (Tcl_InitStubs(interp, TCL_VERSION, 0) == NULL) {
	return TCL_ERROR;
    }
    if (Tcl_PkgRequire(interp, "Tcl", TCL_VERSION, 0) == NULL) {
	return TCL_ERROR;
    }
    if (Tcl_PkgProvide(interp, "example", "0.1") != TCL_OK) {
	return TCL_ERROR;
    }

    Tcl_CreateObjCommand(interp, "example::create",
			 (Tcl_ObjCmdProc*)example_create,
			 (ClientData)NULL, (Tcl_CmdDeleteProc*)NULL);

    return TCL_OK;
}
 

enter categories here