/*
 * tnmEvent.c --
 *
 *	The event command allows to do event driven programming inside
 *	of Tcl scripts easily. The basic idea is that you can raise an
 *	event which will invoke all event handlers that match the
 *	events tag. The idea was born as network management scripts
 *	usually contain a part to detect error situations and scripts
 *	to handle errors It is easy to glue things together by binding
 *	(multiple) scripts to handle events.
 *
 * Copyright (c) 1995-1996 Technical University of Braunschweig.
 *
 * See the file "license.terms" for information on usage and redistribution
 * of this file, and for a DISCLAIMER OF ALL WARRANTIES.
 */

#include "tnmInt.h"
#include "tnmPort.h"

/*
  event create type <name>		;# creates an event type <name>
  event delete type <name>		;# deletes the event type <name>
  event types				;# returns the list of all event types

  event raise <type> ?arg? ?arg? ..	;# raises an even with arguments
  event bind <type> <script>		;# binds a script to an event type
  event bindings <type>			;# list all bindings for a type

  Questions: 

  o How to identify multiple bindings for the same event?
  o Should bindings have attributes?
  o Allow conditions over event binding attributes to fire an event?
 */

/*
 * Structure used to describe an event.
 */

typedef struct Event {
    Tcl_Interp *interp;		/* The Tcl interpreter to use. */
    char *cmd;			/* The command to evaluate. */
    char *args;			/* The arguments to the command. */
} Event;

/*
 * The following hash table keeps a record for each existing binding.
 */

static Tcl_HashTable tagTable;

/*
 * Every Tcl interpreter has an associated EventControl record. It
 * keeps track of the definitions valid for a single interpreter.
 */

static char tnmEventControl[] = "tnmEventControl";

typedef struct EventControl {
    Tcl_HashTable typeTable;
} EventControl;

/*
 * Forward declarations for procedures defined later in this file:
 */

static void
AssocDeleteProc	_ANSI_ARGS_((ClientData clientData, Tcl_Interp *interp));

static void
EventProc	_ANSI_ARGS_((ClientData clientData));

static int
BindEvent	_ANSI_ARGS_((Tcl_Interp *interp, EventControl *control,
			     int argc, char **argv));

static int
RaiseEvent	_ANSI_ARGS_((Tcl_Interp *interp, EventControl *control,
			     int argc, char **argv));

/*
 *----------------------------------------------------------------------
 *
 * AssocDeleteProc --
 *
 *	This procedure is called when a Tcl interpreter gets destroyed
 *	so that we can clean up the data associated with this interpreter.
 *
 * Results:
 *	None.
 *
 * Side effects:
 *	None.
 *
 *----------------------------------------------------------------------
 */

static void
AssocDeleteProc(clientData, interp)
    ClientData clientData;
    Tcl_Interp *interp;
{
    EventControl *control = (EventControl *) clientData;

    if (control) {
	ckfree((char *) control);
    }
}

/*
 *----------------------------------------------------------------------
 *
 * EventProc --
 *
 *	This is the callback that actually handles a raised event.
 *	Issue a background error if the callback fails for some reason.
 *
 * Results:
 *	None.
 *
 * Side effects:
 *	The callback is evaluated which can cause side effects.
 *
 *----------------------------------------------------------------------
 */

static void
EventProc(clientData)
    ClientData clientData;
{
    Event *evPtr = (Event *) clientData;
    int code;
    char *cmd = ckalloc(strlen(evPtr->cmd) + strlen(evPtr->args) + 2);
    sprintf(cmd, "%s %s", evPtr->cmd, evPtr->args);

    Tcl_AllowExceptions(evPtr->interp);
    code = Tcl_GlobalEval(evPtr->interp, cmd);
    if (code == TCL_ERROR) {
	Tcl_AddErrorInfo(evPtr->interp, "\n    (event callback)");
	Tcl_BackgroundError(evPtr->interp);
    }

    ckfree(cmd);

    ckfree(evPtr->cmd);
    ckfree(evPtr->args);
    ckfree((char *) evPtr);
}

/*
 *----------------------------------------------------------------------
 *
 * BindEvent --
 *
 *	Create or return the event binding for a particular tag.
 *	Binding to an empty string will remove an existing binding.
 *
 * Results:
 *	A standard Tcl result.
 *
 * Side effects:
 *	None.
 *
 *----------------------------------------------------------------------
 */

static int
BindEvent(interp, control, argc, argv)
    Tcl_Interp *interp;
    EventControl *control;
    int argc;
    char **argv;
{
    Tcl_HashEntry *entryPtr;

    if (argc == 2) {
        Tcl_HashSearch search;
        entryPtr = Tcl_FirstHashEntry(&control->typeTable, &search);
	while (entryPtr) {
	    Tcl_AppendElement(interp, Tcl_GetHashKey(&control->typeTable, entryPtr));
	    entryPtr = Tcl_NextHashEntry(&search);
	}
    } else if (argc == 3) {
        entryPtr = Tcl_FindHashEntry(&control->typeTable, argv[2]);
	if (entryPtr) {
	    Tcl_SetResult(interp, (char *) Tcl_GetHashValue(entryPtr), 
			  TCL_STATIC);
	}
    } else if (argc == 4) {
        int isNew, append = argv[3][0] == '+';
	char *newCmd, *oldCmd = NULL;
	if (append) {
	    argv[3]++;
	}
	entryPtr = Tcl_FindHashEntry(&control->typeTable, argv[2]);
	if (entryPtr) {
	    oldCmd = (char *) Tcl_GetHashValue(entryPtr);
	}
	if (argv[3][0] == '\0') {
	    if (entryPtr) {
	        Tcl_DeleteHashEntry(entryPtr);
	    }
	} else {
	    if (append && oldCmd) {
	        newCmd = ckalloc(strlen(oldCmd) + strlen(argv[3]) + 2);
		sprintf(newCmd, "%s\n%s", oldCmd, argv[3]);
	    } else {
	        newCmd = ckstrdup(argv[3]);
		if (! entryPtr) {
		   entryPtr = Tcl_CreateHashEntry(&control->typeTable, argv[2], &isNew);
		}
	    }
	    Tcl_SetHashValue(entryPtr, (ClientData) newCmd);
	}
	if (oldCmd) {
	    ckfree(oldCmd);
	}
    } else {
        Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
			 " bind ?pattern? ?command?\"", (char *) NULL);
	return TCL_ERROR;
    }

    return TCL_OK;
}

/*
 *----------------------------------------------------------------------
 *
 * RaiseEvent --
 *
 *	Create an event and prepares to triggers all event handlers
 *	that are created for the given tag. Some issues here:
 *	Should we allow a tag list? And should we allow to match the 
 *	tag against those tags in the tagTable?
 *
 * Results:
 *	A standard Tcl result.
 *
 * Side effects:
 *	Events are processed which can have side arbitrary effects.
 *
 *----------------------------------------------------------------------
 */

static int
RaiseEvent(interp, control, argc, argv)
    Tcl_Interp *interp;
    EventControl *control;
    int argc;
    char **argv;
{
    Tcl_HashEntry *entryPtr;

    if (argc < 3) {
        Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
			 " raise tag ?args?\"", (char *) NULL);
	return TCL_ERROR;
    }
    
    entryPtr = Tcl_FindHashEntry(&control->typeTable, argv[2]);
    if (entryPtr) {
        Event *evPtr = (Event *) ckalloc(sizeof(Event));
	evPtr->interp = interp;
	evPtr->cmd = ckstrdup((char *) Tcl_GetHashValue(entryPtr));
	evPtr->args = Tcl_Merge(argc-3, argv+3);
#if 0
	Tcl_CreateTimerHandler(0, EventProc, (ClientData) evPtr);
/*	Tcl_DoWhenIdle(EventProc, (ClientData) evPtr); */
#else
	EventProc((ClientData) evPtr);
	Tcl_ResetResult(interp);
#endif
    }
  
    return TCL_OK;
}

/*
 *----------------------------------------------------------------------
 *
 * Tnm_EventCmd --
 *
 *	This procedure is invoked to process the "event" command.
 *	See the user documentation for details on what it does.
 *
 * Results:
 *	A standard Tcl result.
 *
 * Side effects:
 *	See the user documentation.
 *
 *----------------------------------------------------------------------
 */

int
Tnm_EventCmd(clientData, interp, argc, argv)
    ClientData clientData;
    Tcl_Interp *interp;
    int argc;
    char **argv;
{
    EventControl *control = (EventControl *) 
	Tcl_GetAssocData(interp, tnmEventControl, NULL);

    if (! control) {
	control = (EventControl *) ckalloc(sizeof(EventControl));
        Tcl_InitHashTable(&control->typeTable, TCL_STRING_KEYS);
	Tcl_SetAssocData(interp, tnmEventControl, AssocDeleteProc, 
			 (ClientData) control);
    }

    if (argc < 2) {
	Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
			 " option ?arg arg ...?\"", (char *) NULL);
	return TCL_ERROR;
    }

    if (strcmp(argv[1], "bind") == 0) {
	return BindEvent(interp, control, argc, argv);

    } else if (strcmp(argv[1], "raise") == 0) {
        return RaiseEvent(interp, control, argc, argv);

    }

    Tcl_AppendResult(interp, "bad option \"", argv[1], 
		     "\": should be bind, or raise",
		     (char *) NULL);
    return TCL_ERROR;
}