Tcl_CreateEventSource(Tcl_EventSetupProc , Tcl_EventCheckProc, ClientData)
http://www.tcl.tk/man/tcl8.4/TclLib/Notifier.htm
This function is called to create a new source of events that will be checked by the Tcl event loop. It registers two functions that will be called when Tcl_DoOneEvent is called to process events. The SetupProc is called to check for the maximum amount of time to block if there are no events. CheckProc is called to test for a signalled state. The manual page has a good deal to say about the Tcl notifier in general so here is a sample that gets Tcl to process Glib or Gtk+ events.
#include <gtk/gtk.h>
/* When there are Gtk+ events to process we raise a Tcl event */
/* When this event is processed here it flushes the Gtk queue */
static int EventProc(Tcl_Event *evPtr, int flags)
{
if (!(flags & TCL_WINDOW_EVENTS)) {
return 0;
}
while (gtk_events_pending()) {
gtk_main_iteration();
}
return 1;
}
/* If there are gtk events in the queue, set the block time to zero */
/* otherwise make it short - 10ms */
static void SetupProc(ClientData clientData, int flags) {
Tcl_Time block_time = {0, 0};
if (!(flags & TCL_WINDOW_EVENTS)) {
return;
}
if (!gtk_events_pending()) {
block_time.usec = 10000;
}
Tcl_SetMaxBlockTime(&block_time);
return;
}
/* If there are events to process, raise a Tk event to indicate this */
static void CheckProc(ClientData clientData, int flags) {
if (!(flags & TCL_WINDOW_EVENTS)) {
return;
}
if (gtk_events_pending()) {
Tcl_Event *event = (Tcl_Event *)ckalloc(sizeof(Tcl_Event));
event->proc = EventProc;
Tcl_QueueEvent(event, TCL_QUEUE_TAIL);
}
return;
}Given the above functions we just have to register the new event source when we initialize our package or our interpreter:
Tcl_CreateEventSource(SetupProc, CheckProc, NULL);
Harald OehlmannImplement a tcl callback function with a new event source similar to the fileevent command:
set h [open com1 rw]
fileevent $h readable $CmdA command analogous to fileevent (example: mycmd event $Cmd) saves the callback command as a string object and the interpreter pointer in global variables:
Tcl_Obj * fg_p_command_obj == NULL;
Tcl_Interp * fg_p_command_interp;
int myCmd(ClientData unused, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[]) {
int Index;
char *subCmds[] = { "open", "close", "event", "version", "help", NULL};
enum iCommand { iOpen, iClose, iEvent, iVersion, iHelp,};
if (objc <= 1) {
Tcl_WrongNumArgs(interp, 1, objv, "option");
return TCL_ERROR;
}
if (TCL_ERROR = Tcl_GetIndexFromObj(interp, objv[1], subCmds, "mahnative", 0, &Index) ) {
return TCL_ERROR;
}
switch (Index) {
iEvent:
if (objc <= 1) {
Tcl_WrongNumArgs(interp, 2, objv, "cmd");
return TCL_ERROR;
}
// Save command and interpreter pointer
fg_p_command_obj = objv[2];
Tcl_IncrRefCount( fg_p_command_obj );
fg_p_command_interp = interp;
// Activate new event
Tcl_CreateEventSource( SetupProc, CheckProc, NULL);
break;
}
return TCL_OK;
}Now the EventProc may call the saved command. If the command fails, bgerror is called and the event is disabled (analoguous to fileevent):
int EventProc(Tcl_Event *evPtr, int flags)
{
// Check if it is my event type
if (!(flags & TCL_FILE_EVENTS)) {
return 0;
}
// Evaluate registered command
if ( TCL_ERROR == Tcl_EvalObjEx(fg_p_command_interp, fg_p_command_obj, TCL_EVAL_DIRECT|TCL_EVAL_GLOBAL) )
{
// Event procedure failed -> unregister event
RemoveEvent();
// Call bgerror
Tcl_EvalEx(fg_p_command_interp, "bgerror {myCmd event callback failed}", -1, TCL_EVAL_DIRECT|TCL_EVAL_GLOBAL);
}
// Return as processed
return 1;
}
void RemoveEvent()
{
if ( fg_p_command_obj != NULL )
{
// > Remove event
Tcl_DeleteEventSource( EventSetupProc, EventCheckProc, NULL);
// > Remove old command
Tcl_DecrRefCount( fg_p_command_obj );
fg_p_command_obj = NULL;
}
}