/* 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 */