/* mod_tcl.c */

/* Embedded TCL interpreter module. */

#ifdef TCL_INTERP_SUPPORT

#include <tcl.h>
#include <math.h>

#include "autoconf.h"
#include "externs.h"
#include "flags.h"
#include "attrs.h"
#include "match.h"
#include "command.h"
#include "functions.h"
#include "misc.h"
#include "alloc.h"

#define	FUNCTION(x)	\
void x(buff, player, cause, fargs, nfargs, cargs, ncargs) \
char *buff; \
dbref player, cause; \
char *fargs[], *cargs[]; \
int nfargs, ncargs;

static int invoked_interp = 0;
static Tcl_Interp *master_tcli;

static int in_tcl_interp = 0;

/* -------------------------------------------------------------------------
 * Command extension:  pemit <object dbref> <message>
 */

static int cmd_tcl_pemit(clientData, interp, argc, argv)
    ClientData clientData;
    Tcl_Interp *interp;
    int argc;
    char **argv;
{
    dbref target;
    char *obname;

    if (argc != 3) {
	interp->result = "pemit - wrong # args";
	return TCL_ERROR;
    }

    obname = argv[1];
    if (*obname != NUMBER_TOKEN) {
	interp->result = "pemit - target must be dbref";
	return TCL_ERROR;
    }
    obname++;
    target = atoi(obname);
    if (! Good_obj(target)) {
	interp->result = "pemit - invalid target";
	return TCL_ERROR;
    }

    notify(target, argv[2]);	/* WARNING: No permissions checking! */
    return TCL_OK;
}

/* -------------------------------------------------------------------------
 * Command extension:  getattrib <object dbref> <attribute>
 */

static int cmd_tcl_getattrib(clientData, interp, argc, argv)
    ClientData clientData;
    Tcl_Interp *interp;
    int argc;
    char **argv;
{
    dbref player, thing;
    int aowner, aflags;
    ATTR *attr;
    char *strp, *obname;

    if (argc != 3) {
	interp->result = "getattrib - wrong # args";
	return TCL_ERROR;
    }

    obname = argv[1];
    if (*obname != NUMBER_TOKEN) {
	interp->result = "getattrib - thing must be dbref";
	return TCL_ERROR;
    }
    obname++;
    thing = atoi(obname);
    if (! Good_obj(thing)) {
	interp->result = "getattrib - invalid thing";
	return TCL_ERROR;
    }

    attr = atr_str(argv[2]);
    if (! attr) {
	return TCL_OK;		/* non-existent attributes are okay */
    }

    /* Figure out who we are for permission purposes */

    strp = Tcl_GetVar(interp, "me", 0);
    if (!strp || !*strp) {
	interp->result = "getattrib - cannot find me";
	return TCL_ERROR;
    }
    player = atoi(strp);
    if (!Good_obj(player)) {
	interp->result = "getattrib - invalid object me";
	return TCL_ERROR;
    }

    atr_pget_info(thing, attr->number, &aowner, &aflags);
    if (!See_attr(player, thing, attr, aowner, aflags)) {
	interp->result = "getattrib - permission denied";
	return TCL_ERROR;
    }
    strp = atr_pget(thing, attr->number, &aowner, &aflags);
    if (strp) {
	if (*strp)
	    Tcl_SetResult(interp, strp, TCL_VOLATILE);
	free_lbuf(strp);
	return TCL_OK;
    }
    return TCL_OK;		/* it's okay to have a blank attribute */
}

/* -------------------------------------------------------------------------
 * Command extension:  setattrib <object dbref> <attribute> <text> 
 */

static int cmd_tcl_setattrib(clientData, interp, argc, argv)
    ClientData clientData;
    Tcl_Interp *interp;
    int argc;
    char **argv;
{
    dbref player, thing;
    int atn, aowner, aflags, could_hear;
    ATTR *attr;
    char *strp, *obname;

    if (argc != 4) {
	interp->result = "setattrib - wrong # args";
	return TCL_ERROR;
    }

    obname = argv[1];
    if (*obname != NUMBER_TOKEN) {
	interp->result = "setattrib - object must be dbref";
	return TCL_ERROR;
    }
    obname++;
    thing = atoi(obname);
    if (! Good_obj(thing)) {
	interp->result = "setattrib - invalid object";
	return TCL_ERROR;
    }

    atn = mkattr(argv[2]);
    if (atn <= 0) {
	interp->result = "setattrib - could not create attribute";
	return TCL_ERROR;
    }

    attr = atr_num(atn);
    if (!attr) {
	interp->result = "setattrib - permission denied";
	return TCL_ERROR;
    }

    /* Figure out who we are for permission purposes */

    strp = Tcl_GetVar(interp, "me", 0);
    if (!strp || !*strp) {
	interp->result = "setattrib - cannot find me";
	return TCL_ERROR;
    }
    player = atoi(strp);
    if (!Good_obj(player)) {
	interp->result = "setattrib - invalid object me";
	return TCL_ERROR;
    }

    atr_pget_info(thing, atn, &aowner, &aflags);
    if (!Set_attr(player, thing, attr, aflags)) {
	interp->result = "setattrib - permission denied";
	return TCL_ERROR;
    }

    if ((attr->check != NULL) &&
	(!(*attr->check) (0, player, thing, atn, argv[3]))) {
	interp->result = "setattrib - attr check failed";
	return TCL_ERROR;
    }

    could_hear = Hearer(thing);
    atr_add(thing, atn, argv[3], Owner(player), aflags);
    handle_ears(thing, could_hear, Hearer(thing));
    return TCL_OK;
}

/* -------------------------------------------------------------------------
 * Command extension: mushfunc <function name> <param1> <param2> <etc.>
 */

static int cmd_tcl_mushfunc(clientData, interp, argc, argv)
    ClientData clientData;
    Tcl_Interp *interp;
    int argc;
    char **argv;
{
    FUN *fp;
    char func_name[SBUF_SIZE];
    char *sp, *tp, *strp, *buff;
    char *fargs[MAX_ARG];
    int nfargs, i;
    dbref player, cause;

    if (argc < 2) {
	interp->result = "mushfunc - wrong # args";
	return TCL_ERROR;
    }

    for (sp = func_name, tp = argv[1];
	 tp && *tp;
	 sp++, tp++) {
	*sp = ToLower(*tp);
    }
    *sp = '\0';

    if ((fp = (FUN *) hashfind(func_name,
			       (HASHTAB *) &mudstate.func_htab)) == NULL) {
	interp->result = "mushfunc - no such function";
	return TCL_ERROR;
    }

    nfargs = argc - 2;
    if ((nfargs == fp->nargs) ||
	(nfargs == - fp->nargs) ||
	(fp->flags & FN_VARARGS)) {

	/* THIS IGNORES THE USUAL LIMITS ON FUNCTION INVOCATION
	 * AND RECURSION.
	 */

	strp = Tcl_GetVar(interp, "me", 0);
	if (!strp || !*strp) {
	    interp->result = "mushfunc - cannot find me";
	    return TCL_ERROR;
	}
	player = atoi(strp);
	if (!Good_obj(player)) {
	    interp->result = "mushfunc - invalid object me";
	}

	if (!check_access(player, fp->perms)) {
	    interp->result = "mushfunc - permission denied";
	    return TCL_ERROR;
	}

	strp = Tcl_GetVar(interp, "enactor", 0);
	if (!strp || !*strp) {
	    interp->result = "mushfunc - cannot find enactor";
	    return TCL_ERROR;
	}
	cause = atoi(strp);
	if (!Good_obj(cause)) {
	    interp->result = "mushfunc - invalid object enactor";
	}

	for (i = 0; i < nfargs; i++) {
	    fargs[i] = alloc_lbuf("cmd_tcl_mushfunc");
	    strncpy(fargs[i], argv[i+2], LBUF_SIZE - 2);
	    fargs[i][LBUF_SIZE - 1] = '\0';
	}

	buff = alloc_lbuf("mushfunc_result");
	fp->fun(buff, player, cause, fargs,nfargs, (char **) NULL, 0);

	if (*buff)
	    Tcl_SetResult(interp, buff, TCL_VOLATILE);
	free_lbuf(buff);

	for (i = 0; i < nfargs; i++)
	    free_lbuf(fargs[i]);

	return TCL_OK;

    } else {
	interp->result = "mushfunc - wrong # args to MUSH function";
	return TCL_ERROR;
    }
}

/* -------------------------------------------------------------------------
 * Invocation functions for interpreters.
 */

static int invoke_tclmaster(player)
    dbref player;
{
    /* ALWAYS check invoked_interp value is false before calling! */

    master_tcli = Tcl_CreateInterp();

    if (! master_tcli) {
	STARTLOG(LOG_BUGS, "TCL", "MASTER")
	    log_name(player);
	ENDLOG
	notify_quiet(player, "Could not spawn master TCL interpreter.");
	return 0;
    }
    
    invoked_interp = 1;
    return 1;
}

static Tcl_Interp *invoke_tclslave(player)
    dbref player;
{
    char interp_name[8];
    Tcl_Interp *slave_tcli;

    ltos(interp_name, player);
    slave_tcli = Tcl_GetSlave(master_tcli, interp_name);
    if (! slave_tcli) {
	slave_tcli = Tcl_CreateSlave(master_tcli, interp_name, 1);
	if (! slave_tcli) {
	    notify_quiet(player, "Could not spawn slave TCL interpreter.");
	    return NULL;
	}
    }

    Tcl_CreateCommand(slave_tcli, "pemit", cmd_tcl_pemit,
		      (ClientData) NULL, (Tcl_CmdDeleteProc *) NULL);
    Tcl_CreateCommand(slave_tcli, "getattrib", cmd_tcl_getattrib,
		      (ClientData) NULL, (Tcl_CmdDeleteProc *) NULL);
    Tcl_CreateCommand(slave_tcli, "setattrib", cmd_tcl_setattrib,
		      (ClientData) NULL, (Tcl_CmdDeleteProc *) NULL);
    Tcl_CreateCommand(slave_tcli, "mushfunc", cmd_tcl_mushfunc,
		      (ClientData) NULL, (Tcl_CmdDeleteProc *) NULL);

    return slave_tcli;
}

/* -------------------------------------------------------------------------
 * The MUSH functions.
 */

FUNCTION(fun_tclclear)
{
    /* tclclear():  Clear out the interpreter on a given object. */

    char interp_name[8];
    Tcl_Interp *slave_tcli;

    *buff = '\0';

    if (! invoked_interp)
	return;

    if (in_tcl_interp)
	return;

    ltos(interp_name, player);
    slave_tcli = Tcl_GetSlave(master_tcli, interp_name);
    if (slave_tcli) {
	if (! Tcl_InterpDeleted(slave_tcli)) {
	    Tcl_DeleteInterp(slave_tcli);
	} else {
	    notify_quiet(player,
			 "Slave TCL interpreter already marked for deletion.");
	}
    }
}

static void handle_tclarrays(player, strname, copybufs)
    dbref player;
    const char *strname;
    char **copybufs;
{
    char arr_name[16];
    char *bp, *errbuf;
    int i;
    Tcl_Interp *slave_tcli;

    if (!invoked_interp && !invoke_tclmaster(player))
	return;

    slave_tcli = invoke_tclslave(player);
    if (! slave_tcli)
	return;

    for (i = 0; i < MAX_GLOBAL_REGS; i++) {
	if (copybufs[i] && *copybufs[i])
	    Tcl_SetVar(slave_tcli, tprintf("%s(%d)", strname, i),
		       copybufs[i], 0);
	else
	    Tcl_SetVar(slave_tcli, tprintf("%s(%d)", strname, i),
		       (char *) "", 0);
    }
}

FUNCTION(fun_tclparams)
{
    /* tclparams(): Make the %0-%9 regs available to tcl as mushparams. */

    *buff = '\0';

    if (in_tcl_interp)
	return;

    handle_tclarrays(player, "mushparams", fargs);
}

FUNCTION(fun_tclregs)
{
    /* tclregs(): Make the %q0-%q9 regs available to tcl as mushregs. */

    *buff = '\0';

    if (in_tcl_interp)
	return;

    handle_tclarrays(player, "mushregs", mudstate.global_regs);
}

FUNCTION(fun_tcleval)
{
    /* tcleval(<object>/<attribute>[,<arg>,...<arg>]):
     * Execute tcl code on an attribute, optionally passing in
     * up to nine arguments.
     */

    dbref thing, aowner;
    int attrib, aflags;
    ATTR *attr;
    char *atr_gotten, *bp;
    char nbuf[8];
    int err_code;
    Tcl_Interp *slave_tcli;
    static char errorbuf[LBUF_SIZE]; /* don't keep allocating storage */

    if (in_tcl_interp)
	return;

    /* must have at least on argument */

    if (nfargs < 1) {
	strcpy(buff, "#-1 TOO FEW ARGUMENTS");
	return;
    }

    if (!parse_attrib(player, fargs[0], &thing, &attrib)) {
	strcpy(buff, "#-1 NO MATCH");
	return;
    }
    *buff = '\0';
    if (attrib == NOTHING)
	return;
    attr = atr_num(attrib);
    if (!attr)
    	return;
    if (attr->flags & AF_IS_LOCK)
	return;
    atr_gotten = atr_pget(thing, attrib, &aowner, &aflags);

    if (!See_attr(player, thing, attr, aowner, aflags)) {
	free_lbuf(atr_gotten);
	return;
    }

    if (!invoked_interp && !invoke_tclmaster(player)) {
	free_lbuf(atr_gotten);
	return;
    }

    slave_tcli = invoke_tclslave(player);
    if (! slave_tcli) {
	free_lbuf(atr_gotten);
	return;
    }

    ltos(nbuf, player);
    Tcl_SetVar(slave_tcli, "me", nbuf, 0);
    ltos(nbuf, cause);
    Tcl_SetVar(slave_tcli, "enactor", nbuf, 0);

    /* make any additional input parameters available as $in(0), etc. */

    if (nfargs > 1) {
	handle_tclarrays(player, "in", fargs + 1);
    }
    
    Tcl_Preserve(slave_tcli);
    in_tcl_interp = 1;
    err_code = Tcl_Eval(slave_tcli, atr_gotten);
    in_tcl_interp = 0;
    Tcl_Release(slave_tcli);
    if (err_code != TCL_OK) {
	if (slave_tcli->result && *slave_tcli->result) {
	    bp = errorbuf;
	    safe_str((char *) "Tcl error: ", errorbuf, &bp);
	    safe_str(slave_tcli->result, errorbuf, &bp);
	    *bp = '\0';
	    notify_quiet(player, errorbuf);
	} else {
	    notify_quiet(player, "Tcl error: unknown problem in Eval.");
	}
	free_lbuf(atr_gotten);
	return;
    }

    if (slave_tcli->result && *slave_tcli->result) {
	bp = buff;
	safe_str(slave_tcli->result, buff, &bp);
	*bp = '\0';
    }

    free_lbuf(atr_gotten);
}

#endif /* TCL_INTERP_SUPPORT */