Weird, "C++" in the title seems to confuse this wiki
This is a minimal example on how to set up a Tcl extension which ties into a C++ command class. It appears to clean up properly when commands are renamed/deleted and when the interpreter exits -- JC
DKF: Hmm. Just wondering if a better extension of this would be to recast this class in terms of core class you can inherit from that sets up a command and manages its safe deletion for you. Then, the constructor for the class would have to be the place where the exit handler was installed, and you could leave the implementation of the command itself to a (naturally virtual) function. I suspect that there are a few typos below too... :^)
#include <tcl.h>
class xProtoCmd
{
Tcl_Interp* _interp;
Tcl_Command _token;
public:
xProtoCmd (Tcl_Interp* interp_);
~xProtoCmd ();
static int CommandProc(ClientData, Tcl_Interp*, int, struct Tcl_Obj* const []);
static void DeleteProc(ClientData);
static void ExitProc(ClientData);
};
int xProtoCmd::CommandProc(ClientData self_,
Tcl_Interp* interp_, int objc_, struct Tcl_Obj* const objv_[])
{
xProtoCmd* self = (xProtoCmd*) self_;
// test code
Tcl_SetIntObj(Tcl_GetObjResult(interp_), (int) self_);
return TCL_OK;
}
void xProtoCmd::DeleteProc(ClientData self_)
{
xProtoCmd* self = (xProtoCmd*) self_;
delete self;
}
void xProtoCmd::ExitProc(ClientData self_)
{
xProtoCmd* self = (xProtoCmd*) self_;
Tcl_DeleteCommandFromToken(self->_interp, self->_token);
}
xProtoCmd::xProtoCmd (Tcl_Interp* interp_)
: _interp (interp_), _token (0)
{
_token = Tcl_CreateObjCommand (_interp, "proto", CommandProc, this, DeleteProc);
}
xProtoCmd::~xProtoCmd ()
{
Tcl_DeleteExitHandler(xProtoCmd::ExitProc, this);
Tcl_DeleteCommandFromToken(_interp, _token);
}
extern "C" DLLEXPORT int Proto_Init(Tcl_Interp* interp_)
{
#if USE_TCL_STUBS
if (Tcl_InitStubs(interp, "8.0", 0) == NULL) {
return TCL_ERROR;
}
#endif
Tcl_CreateExitHandler(xProtoCmd::ExitProc, new xProtoCmd (interp_));
return Tcl_PkgProvide (interp_, "Proto", "0.1");
}Lars H: I've been looking for something like this, since I do have a C++ class (source is [L1 ], see [L2 ] for info) whose functionality I think would be interesting to make available to a Tcl program. (I don't understand much of C++ though, so I suppose taking this as a first Tcl extension project isn't a very wise thing to do.) Anyhow, am I correct in suspecting that the above code makes the class so that the Tcl command is created when the object is, and that conversely the object is destroyed when the Tcl command is deleted? If so, how would one implement a Tcl command that (similarly to label, canvas, etc.) creates a new object and its Tcl command?
DG: That's very similar to something I wrote, but I did it as a template: http://tomasoft.cvs.sourceforge.net/tomasoft/cpptcl/TclAdapter.hpp?rev=HEAD&view=auto
and added [Incr Tcl] services: http://tomasoft.cvs.sourceforge.net/tomasoft/cpptcl/ItclAdapter.hpp?rev=HEAD&view=auto
The class to make an adapter for (Stack.hpp):
// A C++ template implementation of a stack.
#ifndef STACK_HPP
#define STACK_HPP
template <class T>
class Stack
{
public:
Stack();
~Stack();
void push (T data);
T peek();
T pop();
private:
class Link
{
public:
Link(T data, Link *next)
{
_data = data;
_next = next;
}
T _data;
Link *_next;
} *_head;
};
template <class T>
Stack<T>::Stack()
: _head(0L)
{}
template <class T>
Stack<T>::~Stack()
{
Link *cursor = _head;
while (_head != 0L) {
cursor = cursor->_next;
delete _head;
_head = cursor;
}
}
template <class T>
void Stack<T>::push(T data) {
Link *newLink = new Link(data, _head);
_head = newLink;
};
template <class T>
T Stack<T>::peek() {
if (_head == 0L) return 0L;
return _head->_data;
};
template <class T>
T Stack<T>::pop() {
if (_head == 0L) return 0L;
T result = _head->_data;
Link *oldHead = _head;
_head = _head->_next;
delete oldHead;
return result;
};
#endifOur adapter:
//----------------------------------------------------------------------------- // StackTcl.cpp -- // // An example of how to make an [Incr Tcl] extension in C++. // // author: David Gravereaux <[email protected]> //----------------------------------------------------------------------------- #include "ItclAdapter.hpp" #include "TclHash.hpp" #include "Stack.hpp" class StackAdapter : protected Itcl::IAdapter<StackAdapter> { Tcl::Hash<Stack<Tcl_Obj *> *, TCL_ONE_WORD_KEYS> StackHash; public: StackAdapter(Tcl_Interp *interp) : Itcl::IAdapter<StackAdapter>(interp) { // Let [Incr Tcl] know we have some methods in here. NewItclCmd("Stack-construct", &StackAdapter::ConstructCmd); NewItclCmd("Stack-destruct", &StackAdapter::DestructCmd); NewItclCmd("Stack-peek", &StackAdapter::PeekCmd); NewItclCmd("Stack-push", &StackAdapter::PushCmd); NewItclCmd("Stack-pop", &StackAdapter::PopCmd); } ~StackAdapter() { // Use of the interp pointer is not allowed in here. Tcl_HashEntry *entryPtr; Tcl_HashSearch search; Stack<Tcl_Obj *> *stackPtr; Tcl_Obj *data; // iterate through the hash table and clean-up all instances of the stack // objects. for ( entryPtr = Tcl_FirstHashEntry(&StackHash.HashTbl, &search); entryPtr != NULL; entryPtr = Tcl_NextHashEntry(&search) ) { stackPtr = static_cast <Stack<Tcl_Obj *> *> (Tcl_GetHashValue(entryPtr)); while((data = stackPtr->pop()) != 0L) Tcl_DecrRefCount(data); delete stackPtr; } } // The Tcl::Adapter base class is telling us we are about to go away and it // is safe to use the interp pointer to do any needed cleanup. virtual void DoCleanup () {}; private: int ConstructCmd (int objc, struct Tcl_Obj * CONST objv[]) { ItclObject *ItclObj; if (objc != 1) { Tcl_WrongNumArgs(m_interp, 1, objv, ""); return TCL_ERROR; } if (GetItclObj(&ItclObj, objv[0]) != TCL_OK) return TCL_ERROR; // Using the object context pointer as our key, create a new // stack C++ object and store the pointer in the hash table. StackHash.Add(ItclObj, new Stack<Tcl_Obj *>); return TCL_OK; } int DestructCmd (int objc, struct Tcl_Obj * CONST objv[]) { ItclObject *ItclObj; Stack<Tcl_Obj *> *stackPtr; Tcl_Obj *data; if (objc != 1) { Tcl_WrongNumArgs(m_interp, 1, objv, ""); return TCL_ERROR; } if (GetItclObj(&ItclObj, objv[0]) != TCL_OK) return TCL_ERROR; if (StackHash.Find(ItclObj, &stackPtr) == TCL_OK) { // Itcl's destructor may be called even though the Itcl class // constructor returned with an error! Thus, no Stack<Tcl_Obj *> // instance exists in the hash table even though an Itcl object // context exists. Only delete what we know is there. while((data = stackPtr->pop()) != 0L) Tcl_DecrRefCount(data); delete stackPtr; StackHash.Delete(ItclObj); } return TCL_OK; } int PeekCmd (int objc, struct Tcl_Obj * CONST objv[]) { ItclObject *ItclObj; Stack<Tcl_Obj *> *stackPtr; Tcl_Obj *data; if (objc != 1) { Tcl_WrongNumArgs(m_interp, 1, objv, ""); return TCL_ERROR; } if (GetItclObj(&ItclObj, objv[0]) != TCL_OK) return TCL_ERROR; if (StackHash.Find(ItclObj, &stackPtr) != TCL_OK) { Tcl_SetObjResult(m_interp, Tcl_NewStringObj("Stack<Tcl_Obj *> instance lost!", -1)); return TCL_ERROR; } data = stackPtr->peek(); if (data != 0L) Tcl_SetObjResult(m_interp, data); return TCL_OK; } int PushCmd (int objc, struct Tcl_Obj * CONST objv[]) { ItclObject *ItclObj; Stack<Tcl_Obj *> *stackPtr; if (objc != 2) { Tcl_WrongNumArgs(m_interp, 1, objv, "<item>"); return TCL_ERROR; } if (GetItclObj(&ItclObj, objv[0]) != TCL_OK) return TCL_ERROR; if (StackHash.Find(ItclObj, &stackPtr) != TCL_OK) { Tcl_SetObjResult(m_interp, Tcl_NewStringObj("Stack<Tcl_Obj *> instance lost!", -1)); return TCL_ERROR; } Tcl_IncrRefCount(objv[1]); // take ownership stackPtr->push(objv[1]); return TCL_OK; } int PopCmd (int objc, struct Tcl_Obj * CONST objv[]) { ItclObject *ItclObj; Stack<Tcl_Obj *> *stackPtr; Tcl_Obj *data; if (objc != 1) { Tcl_WrongNumArgs(m_interp, 1, objv, ""); return TCL_ERROR; } if (GetItclObj(&ItclObj, objv[0]) != TCL_OK) return TCL_ERROR; if (StackHash.Find(ItclObj, &stackPtr) != TCL_OK) { Tcl_SetObjResult(m_interp, Tcl_NewStringObj("Stack<Tcl_Obj *> instance lost!", -1)); return TCL_ERROR; } data = stackPtr->pop(); if (data != 0L) { Tcl_SetObjResult(m_interp, data); Tcl_DecrRefCount(data); // remove ownership } return TCL_OK; } }; #undef TCL_STORAGE_CLASS #define TCL_STORAGE_CLASS DLLEXPORT EXTERN int Stack_Init (Tcl_Interp *interp) { #ifdef USE_TCL_STUBS if (Tcl_InitStubs(interp, "8.1", 0) == 0L) { return TCL_ERROR; } #endif #ifdef USE_ITCL_STUBS if (Itcl_InitStubs(interp, "3.1", 0) == 0L) { return TCL_ERROR; } #endif new StackAdapter(interp); Tcl_PkgProvide(interp, "stack", "1.1"); return TCL_OK; }
And the resulting [Incr Tcl] class ended-up as:
load stack11.dll
itcl::class Stack {
constructor {} { _init }
destructor { _delete }
public {
method peek {} @Stack-peek
method pop {} @Stack-pop
method push {data} @Stack-push
}
private {
method _init {} @Stack-construct
method _delete {} @Stack-destruct
}
}