modules/tclscript/tclscript.c File Reference

#include <string.h>
#include <stdlib.h>
#include <tcl.h>
#include <eggdrop/eggdrop.h>

Go to the source code of this file.

Data Structures
struct	my_callback_cd_t
struct	my_args_data_t
struct	tcl_listener
Typedefs
typedef struct tcl_listener	tcl_listener_t
Functions
static int	my_command_handler (ClientData client_data, Tcl_Interp *myinterp, int objc, Tcl_Obj *CONST objv[])
static Tcl_Obj *	c_to_tcl_var (Tcl_Interp *myinterp, script_var_t *v)
static int	tcl_to_c_var (Tcl_Interp *myinterp, Tcl_Obj *obj, script_var_t *var, int type)
static int	my_tcl_cb_delete (event_owner_t *owner, void *me)
static int	my_load_script (void *ignore, char *fname)
static int	my_link_var (void *ignore, script_linked_var_t *var)
static int	my_unlink_var (void *ignore, script_linked_var_t *var)
static int	my_create_command (void *ignore, script_raw_command_t *info)
static int	my_delete_command (void *ignore, script_raw_command_t *info)
static int	my_get_arg (void *ignore, script_args_t *args, int num, script_var_t *var, int type)
static void	set_linked_var (script_linked_var_t *var, script_var_t *val)
static char *	my_trace_callback (ClientData client_data, Tcl_Interp *irp, char *name1, char *name2, int flags)
static void	log_error_message (Tcl_Interp *myinterp)
static int	my_tcl_callbacker (script_callback_t *me,...)
static int	party_tcl (partymember_t *p, char *nick, user_t *u, char *cmd, char *text)
static int	add_tcl_chan (ClientData cdata, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[])
static int	rem_tcl_chan (ClientData cdata, Tcl_Interp *interp, int objc, Tcl_Obj *CONST objv[])
static int	tclscript_secondly ()
static int	tclscript_close (int why)
EXPORT_SCOPE int	tclscript_LTX_start (egg_module_t *modinfo)
Variables
static const char	rcsid [] = "$Id: tclscript.c,v 1.52 2007-04-14 15:21:13 sven Exp $"
static event_owner_t	tcl_owner
static script_module_t	my_script_interface
static Tcl_Interp *	ginterp
static char *	error_logfile = NULL
static tcl_listener_t *	listener_list_head = NULL
static bind_list_t	party_commands []
static bind_list_t	secondly_binds []

---

Typedef Documentation

typedef struct tcl_listener tcl_listener_t

---

Function Documentation

static int add_tcl_chan	(	ClientData	cdata,
		Tcl_Interp *	interp,
		int	objc,
		Tcl_Obj *CONST	objv[]
	)			[static]

Definition at line 645 of file tclscript.c.

References tcl_listener::fd, tcl_listener::name, tcl_listener::next, NULL, and sockbuf_attach_listener().

Referenced by tclscript_LTX_start().

{
  Tcl_Channel chan;
  char *chan_name;
  int modes;
  void *fd;
  tcl_listener_t *listener;

  if (objc != 2) {
    Tcl_WrongNumArgs(interp, 0, NULL, "channel-name");
    return(TCL_ERROR);
  }

  chan_name = Tcl_GetStringFromObj(objv[1], NULL);
  if (!chan_name) return(TCL_ERROR);
  chan = Tcl_GetChannel(interp, chan_name, &modes);
  if (!chan) return(TCL_ERROR);
  if (Tcl_GetChannelHandle(chan, TCL_READABLE, &fd)) return(TCL_ERROR);
  listener = malloc(sizeof(*listener));
  listener->next = listener_list_head;
  listener->name = strdup(chan_name);
  listener->fd = (int) fd;
  listener_list_head = listener;
  sockbuf_attach_listener((int) fd);
  return(0);
}

static Tcl_Obj * c_to_tcl_var	(	Tcl_Interp *	myinterp,
		script_var_t *	v
	)			[static]

Definition at line 341 of file tclscript.c.

References byte_array_b::bytes, byte_array_b::do_free, partymember::full_id_name, user::handle, byte_array_b::len, script_var_b::len, NULL, SCRIPT_ARRAY, SCRIPT_BYTES, SCRIPT_FREE, SCRIPT_FREE_VAR, SCRIPT_INTEGER, SCRIPT_PARTIER, SCRIPT_POINTER, SCRIPT_STRING, SCRIPT_STRING_LIST, SCRIPT_TYPE_MASK, SCRIPT_UNSIGNED, SCRIPT_USER, SCRIPT_VAR, script_var_b::type, and script_var_b::value.

Referenced by my_command_handler(), my_tcl_callbacker(), and set_linked_var().

{
  Tcl_Obj *result;

  result = NULL;
  /* If it's an array, we call ourselves recursively. */
  if (v->type & SCRIPT_ARRAY) {
    Tcl_Obj *element;
    int i;

    result = Tcl_NewListObj(0, NULL);
    /* If it's an array of script_var_t's, then it's easy. */
    if ((v->type & SCRIPT_TYPE_MASK) == SCRIPT_VAR) {
      script_var_t **v_list;

      v_list = (script_var_t **)v->value;
      for (i = 0; i < v->len; i++) {
        element = c_to_tcl_var(myinterp, v_list[i]);
        Tcl_ListObjAppendElement(myinterp, result, element);
      }
    }
    else {
      /* Otherwise, we have to turn them into fake script_var_t's. */
      script_var_t v_sub;
      void **values;

      values = (void **)v->value;
      for (i = 0; i < v->len; i++) {
        v_sub.type = v->type & (~SCRIPT_ARRAY);
        v_sub.value = values[i];
        v_sub.len = -1;
        element = c_to_tcl_var(myinterp, &v_sub);
        Tcl_ListObjAppendElement(myinterp, result, element);
      }
    }
    /* Whew */
    if (v->type & SCRIPT_FREE) free(v->value);
    if (v->type & SCRIPT_FREE_VAR) free(v);
    return(result);
  }

  /* Here is where we handle the basic types. */
  switch (v->type & SCRIPT_TYPE_MASK) {
    case SCRIPT_INTEGER:
    case SCRIPT_UNSIGNED:
      result = Tcl_NewIntObj((int) v->value);
      break;
    case SCRIPT_STRING: {
      char *str = v->value;

      if (!str) str = "";
      if (v->len == -1) v->len = strlen(str);
#ifdef USE_TCL_BYTE_ARRAYS
      result = Tcl_NewByteArrayObj((unsigned char *) str, v->len);
#else
      result = Tcl_NewStringObj(str, v->len);
#endif
      if (v->value && v->type & SCRIPT_FREE) free(v->value);
      break;
    }
    case SCRIPT_STRING_LIST: {
      char **str = v->value;
      Tcl_Obj *element;

      result = Tcl_NewListObj(0, NULL);
      while (str && *str) {
#ifdef USE_TCL_BYTE_ARRAYS
        element = Tcl_NewByteArrayObj((unsigned char *) (*str), strlen(*str));
#else
        element = Tcl_NewStringObj(*str, strlen(*str));
#endif
        Tcl_ListObjAppendElement(myinterp, result, element);
        str++;
      }
      break;
    }
    case SCRIPT_BYTES: {
      byte_array_t *bytes = v->value;
#ifdef USE_TCL_BYTE_ARRAYS
      result = Tcl_NewByteArrayObj(bytes->bytes, bytes->len);
#else
      result = Tcl_NewStringObj(bytes->bytes, bytes->len);
#endif
      if (bytes->do_free) free(bytes->bytes);
      if (v->type & SCRIPT_FREE) free(bytes);
      break;
    }
    case SCRIPT_POINTER: {
      char str[32];

      sprintf(str, "#%u", (unsigned int) v->value);
      result = Tcl_NewStringObj(str, -1);
      break;
    }
    case SCRIPT_PARTIER: {
      partymember_t *p = v->value;

      if (p) result = Tcl_NewStringObj(p->full_id_name, -1);
      else result = Tcl_NewStringObj("*", -1);
      break;
    }
    case SCRIPT_USER: {
      /* An eggdrop user record (struct userrec *). */
      char *handle;
      user_t *u = v->value;

      if (u) handle = u->handle;
      else handle = "*";
      result = Tcl_NewStringObj(handle, -1);
      break;
    }
    default:
      /* Default: just pass a string with an error message. */
      result = Tcl_NewStringObj("unsupported type", -1);
  }
  if (v->type & SCRIPT_FREE_VAR) free(v);
  return(result);
}

static void log_error_message

(

Tcl_Interp *

myinterp

)

[static]

Definition at line 214 of file tclscript.c.

References _, error_logfile, LOG_MISC, NULL, and putlog().

Referenced by my_tcl_callbacker().

{
  FILE *fp;
  const char *errmsg;
  time_t timenow;

  errmsg = Tcl_GetStringResult(myinterp);
  putlog(LOG_MISC, "*", "Tcl Error: %s", errmsg);

  if (!error_logfile || !error_logfile[0]) return;

  timenow = time(NULL);
  fp = fopen(error_logfile, "a");
  if (!fp) putlog(LOG_MISC, "*", _("Error opening Tcl error log (%s)!"), error_logfile);
  else {
    errmsg = Tcl_GetVar(myinterp, "errorInfo", TCL_GLOBAL_ONLY);
    fprintf(fp, "%s", asctime(localtime(&timenow)));
    fprintf(fp, "%s\n\n", errmsg);
    fclose(fp);
  }
}

static int my_command_handler	(	ClientData	client_data,
		Tcl_Interp *	myinterp,
		int	objc,
		Tcl_Obj *CONST	objv[]
	)			[static]

Definition at line 567 of file tclscript.c.

References c_to_tcl_var(), script_raw_command_t::callback, script_raw_command_t::client_data, script_args_b::client_data, cmd, my_args_data_t::irp, script_var_b::len, script_args_b::len, script_args_b::module, NULL, my_args_data_t::objv, SCRIPT_ERROR, script_var_b::type, and script_var_b::value.

{
  script_raw_command_t *cmd = (script_raw_command_t *)client_data;
  script_var_t retval;
  Tcl_Obj *tcl_retval = NULL;
  script_args_t args;
  my_args_data_t argdata;
  int err;

  /* Initialize args. */
  argdata.irp = myinterp;
  argdata.objv = objv;
  args.module = &my_script_interface;
  args.client_data = &argdata;
  args.len = objc-1;

  /* Initialize retval. */
  retval.type = 0;
  retval.value = NULL;
  retval.len = -1;

  /* Execute callback. */
  cmd->callback(cmd->client_data, &args, &retval);
  err = retval.type & SCRIPT_ERROR;

  /* Process the return value. */
  tcl_retval = c_to_tcl_var(myinterp, &retval);

  if (tcl_retval) Tcl_SetObjResult(myinterp, tcl_retval);
  else Tcl_ResetResult(myinterp);

  if (err) return TCL_ERROR;
  return TCL_OK;
}

static int my_create_command	(	void *	ignore,
		script_raw_command_t *	info
	)			[static]

Definition at line 307 of file tclscript.c.

References script_raw_command_t::class, egg_mprintf(), ginterp, my_command_handler(), script_raw_command_t::name, and NULL.

{
  char *cmdname;

  if (info->class && strlen(info->class)) {
    cmdname = egg_mprintf("%s_%s", info->class, info->name);
  }
  else {
    cmdname = strdup(info->name);
  }
  Tcl_CreateObjCommand(ginterp, cmdname, my_command_handler, (ClientData) info, NULL);
  free(cmdname);

  return(0);
}

static int my_delete_command	(	void *	ignore,
		script_raw_command_t *	info
	)			[static]

Definition at line 324 of file tclscript.c.

References script_raw_command_t::class, egg_mprintf(), ginterp, and script_raw_command_t::name.

{
  char *cmdname;

  if (info->class && strlen(info->class)) {
    cmdname = egg_mprintf("%s_%s", info->class, info->name);
  }
  else {
    cmdname = strdup(info->name);
  }
  Tcl_DeleteCommand(ginterp, cmdname);
  free(cmdname);

  return(0);
}

static int my_get_arg	(	void *	ignore,
		script_args_t *	args,
		int	num,
		script_var_t *	var,
		int	type
	)			[static]

Definition at line 602 of file tclscript.c.

References script_args_b::client_data, my_args_data_t::irp, my_args_data_t::objv, and tcl_to_c_var().

{
  my_args_data_t *argdata;

  argdata = (my_args_data_t *)args->client_data;
  return tcl_to_c_var(argdata->irp, argdata->objv[num+1], var, type);
}

static int my_link_var	(	void *	ignore,
		script_linked_var_t *	var
	)			[static]

Definition at line 186 of file tclscript.c.

References script_linked_var_b::class, egg_mprintf(), ginterp, my_trace_callback(), script_linked_var_b::name, NULL, and set_linked_var().

{
  char *varname;

  if (var->class && strlen(var->class)) varname = egg_mprintf("%s(%s)", var->class, var->name);
  else varname = strdup(var->name);

  set_linked_var(var, NULL);
  Tcl_TraceVar(ginterp, varname, TCL_TRACE_READS | TCL_TRACE_WRITES | TCL_TRACE_UNSETS, (Tcl_VarTraceProc *)my_trace_callback, var);

  free(varname);
  return(0);
}

static int my_load_script	(	void *	ignore,
		char *	fname
	)			[static]

Definition at line 105 of file tclscript.c.

References _, ginterp, LOG_MISC, putlog(), SCRIPT_ERR_CODE, SCRIPT_ERR_NOT_RESPONSIBLE, and SCRIPT_OK.

{
  int result;
  int len;

  /* Check the filename and make sure it ends in .tcl */
  len = strlen(fname);
  if (len < 4 || fname[len-1] != 'l' || fname[len-2] != 'c' || fname[len-3] != 't' || fname[len-4] != '.') {
    /* Nope, let someone else load it. */
    return SCRIPT_ERR_NOT_RESPONSIBLE;
  }

  result = Tcl_EvalFile (ginterp, fname);
  if (result != TCL_OK) {
    putlog (LOG_MISC, "*", _("Failed to load script %s: %s"),
        fname, Tcl_GetStringResult (ginterp));
    return SCRIPT_ERR_CODE;
  }

  return SCRIPT_OK; 
}

static int my_tcl_callbacker	(	script_callback_t *	me,
			...
	)			[static]

Definition at line 238 of file tclscript.c.

References c_to_tcl_var(), script_callback_b::callback_data, my_callback_cd_t::command, script_var_b::len, log_error_message(), my_callback_cd_t::myinterp, SCRIPT_INTEGER, SCRIPT_UNSIGNED, script_callback_b::syntax, script_var_b::type, and script_var_b::value.

Referenced by tcl_to_c_var().

{
  Tcl_Obj *arg, *final_command, *result;
  Tcl_Interp *interp;
  script_var_t var;
  my_callback_cd_t *cd; /* My callback client data */
  int i, n, retval;
  va_list va;

  /* This struct contains the interp and the obj command. */
  cd = (my_callback_cd_t *)me->callback_data;

  /* Get a copy of the command, then append args. */
  final_command = Tcl_DuplicateObj(cd->command);

  if (me->syntax) n = strlen(me->syntax);
  else n = 0;

  va_start(va, me);
  for (i = 0; i < n; i++) {
    var.type = me->syntax[i];
    if (var.type == SCRIPT_INTEGER || var.type == SCRIPT_UNSIGNED) var.value = (void *) (va_arg(va, int));
    else var.value = va_arg(va, void *);
    var.len = -1;
    arg = c_to_tcl_var(cd->myinterp, &var);
    Tcl_ListObjAppendElement(cd->myinterp, final_command, arg);
  }
  va_end(va);

  interp = cd->myinterp;

#ifdef USE_TCL_BYTE_ARRAYS
  n = Tcl_EvalObjEx(interp, final_command, TCL_EVAL_GLOBAL);
#else
  n = Tcl_GlobalEvalObj(interp, final_command);
#endif

  if (n == TCL_OK) {
    result = Tcl_GetObjResult(interp);
    Tcl_GetIntFromObj(interp, result, &retval);
  }
  else {
    log_error_message(interp);
    Tcl_BackgroundError(interp);
  }

  /* Clear any errors or stray messages. */
  Tcl_ResetResult(interp);

  return(retval);
}

static int my_tcl_cb_delete	(	event_owner_t *	owner,
		void *	me
	)			[static]

Definition at line 291 of file tclscript.c.

References script_callback_b::callback_data, my_callback_cd_t::command, script_callback_b::name, my_callback_cd_t::name, and script_callback_b::syntax.

{
  script_callback_t *me = data;
  my_callback_cd_t *cd;

  cd = me->callback_data;
  Tcl_DecrRefCount(cd->command);
  if (cd->name) free(cd->name);
  if (me->syntax) free(me->syntax);
  if (me->name) free(me->name);
  free(cd);
  free(me);
  return(0);
}

static char* my_trace_callback	(	ClientData	client_data,
		Tcl_Interp *	irp,
		char *	name1,
		char *	name2,
		int	flags
	)			[static]

Definition at line 151 of file tclscript.c.

References script_linked_var_b::callbacks, my_link_var(), NULL, script_var_callbacks_b::on_read, script_linked_var_on_write(), SCRIPT_READONLY, set_linked_var(), tcl_to_c_var(), and script_linked_var_b::type.

Referenced by my_link_var(), and my_unlink_var().

{
  script_linked_var_t *linked_var = (script_linked_var_t *)client_data;
  script_var_t newvalue = {0};

  if (flags & TCL_INTERP_DESTROYED) return(NULL);

  if (flags & TCL_TRACE_READS) {
    if (linked_var->callbacks && linked_var->callbacks->on_read) {
      int r = (linked_var->callbacks->on_read)(linked_var, &newvalue);
      if (r) return(NULL);
    }
    set_linked_var(linked_var, &newvalue);
  }
  else if (flags & TCL_TRACE_WRITES) {
    Tcl_Obj *obj;

    if (linked_var->type & SCRIPT_READONLY) return("read only variable");

    obj = Tcl_GetVar2Ex(irp, name1, name2, 0);
    if (!obj) return("Error setting variable");

    tcl_to_c_var(irp, obj, &newvalue, linked_var->type);
    script_linked_var_on_write(linked_var, &newvalue);
  }
  else if (flags & TCL_TRACE_UNSETS) {
    /* If someone unsets a variable, we'll just reset it. */
    if (flags & TCL_TRACE_DESTROYED) my_link_var(NULL, linked_var);
    else set_linked_var(linked_var, NULL);
    return("read only variable");
  }
  return(NULL);
}

static int my_unlink_var	(	void *	ignore,
		script_linked_var_t *	var
	)			[static]

Definition at line 201 of file tclscript.c.

References script_linked_var_b::class, egg_mprintf(), ginterp, my_trace_callback(), and script_linked_var_b::name.

{
  char *varname;

  if (var->class && strlen(var->class)) varname = egg_mprintf("%s(%s)", var->class, var->name);
  else varname = strdup(var->name);

  Tcl_UntraceVar(ginterp, varname, TCL_TRACE_READS | TCL_TRACE_WRITES | TCL_TRACE_UNSETS, (Tcl_VarTraceProc *)my_trace_callback, var);

  free(varname);
  return(0);
}

static int party_tcl	(	partymember_t *	p,
		char *	nick,
		user_t *	u,
		char *	cmd,
		char *	text
	)			[static]

Definition at line 610 of file tclscript.c.

References _, BIND_RET_LOG, egg_isowner(), ginterp, user::handle, partymember_printf(), and partymember_write().

{
  const char *str;

  if (!u || !egg_isowner(u->handle)) {
    partymember_write(p, _("You must be a permanent owner (defined in the config file) to use this command.\n"), -1);
    return(BIND_RET_LOG);
  }

  if (!text) {
    partymember_write(p, _("Syntax: .tcl <tclexpression>"), -1);
    return(0);
  }

  if (Tcl_GlobalEval(ginterp, text) != TCL_OK) {
    str = Tcl_GetVar(ginterp, "errorInfo", TCL_GLOBAL_ONLY);
    if (!str) str = Tcl_GetStringResult(ginterp);
    partymember_printf(p, _("Tcl error: %s\n\n"), str);
  }
  else {
    str = Tcl_GetStringResult(ginterp);
    partymember_printf(p, _("Tcl: %s\n\n"), str);
  }
  return(0);
}

static int rem_tcl_chan	(	ClientData	cdata,
		Tcl_Interp *	interp,
		int	objc,
		Tcl_Obj *CONST	objv[]
	)			[static]

Definition at line 672 of file tclscript.c.

References tcl_listener::fd, tcl_listener::name, tcl_listener::next, NULL, and sockbuf_detach_listener().

Referenced by tclscript_LTX_start().

{
  char *chan_name;
  tcl_listener_t *listener, *prev;

  if (objc != 2) {
    Tcl_WrongNumArgs(interp, 0, NULL, "channel-name");
    return(TCL_ERROR);
  }

  chan_name = Tcl_GetStringFromObj(objv[1], NULL);
  if (!chan_name) return(TCL_ERROR);

  prev = NULL;
  for (listener = listener_list_head; listener; listener = listener->next) {
    if (!strcasecmp(listener->name, chan_name)) break;
    prev = listener;
  }
  if (!listener) return(TCL_ERROR);

  if (prev) prev->next = listener->next;
  else listener_list_head = listener->next;
  sockbuf_detach_listener(listener->fd);
  free(listener->name);
  free(listener);
  return(0);
}

static void set_linked_var	(	script_linked_var_t *	var,
		script_var_t *	val
	)			[static]

Definition at line 128 of file tclscript.c.

References c_to_tcl_var(), script_linked_var_b::class, ginterp, script_var_b::len, script_linked_var_b::name, NULL, SCRIPT_TYPE_MASK, script_linked_var_b::type, script_var_b::type, script_linked_var_b::value, and script_var_b::value.

{
  Tcl_Obj *obj;
  script_var_t script_var;

  if (!val || !val->type) {
    script_var.type = var->type & SCRIPT_TYPE_MASK;
    script_var.len = -1;
    script_var.value = *(void **)var->value;
    val = &script_var;
  }

  obj = c_to_tcl_var(ginterp, val);

  if (var->class && strlen(var->class)) {
    Tcl_SetVar2Ex(ginterp, var->class, var->name, obj, TCL_GLOBAL_ONLY);
  }
  else {
    Tcl_SetVar2Ex(ginterp, var->name, NULL, obj, TCL_GLOBAL_ONLY);
  }
}

static int tcl_to_c_var	(	Tcl_Interp *	myinterp,
		Tcl_Obj *	obj,
		script_var_t *	var,
		int	type
	)			[static]

Definition at line 463 of file tclscript.c.

References _, byte_array_b::bytes, script_callback_b::callback, script_callback_b::callback_data, my_callback_cd_t::command, byte_array_b::len, script_var_b::len, my_tcl_callbacker(), my_callback_cd_t::myinterp, script_callback_b::name, NULL, script_callback_b::owner, partymember_lookup(), SCRIPT_BYTES, SCRIPT_CALLBACK, SCRIPT_FREE, SCRIPT_INTEGER, SCRIPT_PARTIER, SCRIPT_STRING, SCRIPT_TYPE_MASK, SCRIPT_UNSIGNED, SCRIPT_USER, script_var_b::type, user_lookup_by_handle(), and script_var_b::value.

Referenced by my_get_arg(), and my_trace_callback().

{
  int err = TCL_OK;

  var->type = type;
  var->len = -1;
  var->value = NULL;

  switch (type & SCRIPT_TYPE_MASK) {
    case SCRIPT_STRING: {
      char *str;
      int len;

#ifdef USE_TCL_BYTE_ARRAYS
        unsigned char *bytes;

        bytes = Tcl_GetByteArrayFromObj(obj, &len);
        str = malloc(len+1);
        memcpy(str, bytes, len);
        str[len] = 0;
        var->type |= SCRIPT_FREE;
#else
        str = Tcl_GetStringFromObj(obj, &len);
#endif
      var->value = str;
      var->len = len;
      break;
    }
    case SCRIPT_BYTES: {
      byte_array_t *byte_array;

      byte_array = malloc(sizeof(*byte_array));

#ifdef USE_TCL_BYTE_ARRAYS
      byte_array->bytes = Tcl_GetByteArrayFromObj(obj, &byte_array->len);
#else
      byte_array->bytes = Tcl_GetStringFromObj(obj, &byte_array->len);
#endif

      var->value = byte_array;
      var->type |= SCRIPT_FREE;
      break;
    }
    case SCRIPT_UNSIGNED:
    case SCRIPT_INTEGER: {
      int intval = 0;

      err = Tcl_GetIntFromObj(myinterp, obj, &intval);
      var->value = (void *) intval;
      break;
    }
    case SCRIPT_CALLBACK: {
      script_callback_t *cback; /* Callback struct */
      my_callback_cd_t *cdata; /* Our client data */

      cback = calloc(1, sizeof(*cback));
      cdata = calloc(1, sizeof(*cdata));
      cback->callback = (Function) my_tcl_callbacker;
      cback->callback_data = cdata;
      cback->name = strdup(Tcl_GetString(obj));
      cback->owner = &tcl_owner;
      cdata->myinterp = myinterp;
      cdata->command = obj;
      Tcl_IncrRefCount(obj);

      var->value = cback;
      break;
    }
    case SCRIPT_PARTIER: {
      const char *name;

      name = Tcl_GetString(obj);
      var->value = partymember_lookup(name, NULL, -1);
      break;
    }
    case SCRIPT_USER: {
      user_t *u;
      script_var_t handle;

      /* Call ourselves recursively to get the handle as a string. */
      tcl_to_c_var(myinterp, obj, &handle, SCRIPT_STRING);
      u = user_lookup_by_handle((char *)handle.value);
      if (handle.type & SCRIPT_FREE) free(handle.value);
      var->value = u;
      if (!u) {
        Tcl_AppendResult(myinterp, "User not found", NULL);
        err++;
      }
      break;
    }
    default: {
      char vartype[2];

      vartype[0] = type;
      vartype[1] = 0;
      Tcl_AppendResult(myinterp, _("Cannot convert Tcl object to unknown variable type '"), vartype, "'.", NULL);
      err++;
    }
  }

  return(err);
}

static int tclscript_close

(

int

why

)

[static]

Definition at line 735 of file tclscript.c.

References bind_rem_list(), ginterp, and script_unregister_module().

Referenced by tclscript_LTX_start().

{
  Tcl_DeleteInterp(ginterp);

  bind_rem_list("party", party_commands);
  bind_rem_list("secondly", secondly_binds);

  script_unregister_module(&my_script_interface);
  return(0);
}

int tclscript_LTX_start

(

egg_module_t *

modinfo

)

Definition at line 748 of file tclscript.c.

References add_tcl_chan(), egg_module::author, bind_add_list(), egg_module::close_func, egg_module::description, error_logfile, ginterp, event_owner_b::module, egg_module::name, NULL, rem_tcl_chan(), script_playback(), script_register_module(), tclscript_close(), and egg_module::version.

{
  tcl_owner.module = modinfo;

  modinfo->name = "tclscript";
  modinfo->author = "eggdev";
  modinfo->version = "1.0.0";
  modinfo->description = "provides tcl scripting support";
  modinfo->close_func = tclscript_close;

  /* Create the interpreter and let tcl load its init.tcl */
  ginterp = Tcl_CreateInterp();
  Tcl_Init(ginterp);

  error_logfile = strdup("logs/tcl_errors.log");
  Tcl_LinkVar(ginterp, "error_logfile", (char *)&error_logfile, TCL_LINK_STRING);

  script_register_module(&my_script_interface);
  script_playback(&my_script_interface);

  bind_add_list("party", party_commands);
  bind_add_list("secondly", secondly_binds);

  Tcl_CreateObjCommand(ginterp, "net_add_tcl", add_tcl_chan, NULL, NULL);
  Tcl_CreateObjCommand(ginterp, "net_rem_tcl", rem_tcl_chan, NULL, NULL);
  return(0);
}

static int tclscript_secondly

(

)

[static]

Definition at line 700 of file tclscript.c.

{
  Tcl_DoOneEvent(TCL_ALL_EVENTS | TCL_DONT_WAIT);
  return(0);
}

---

Variable Documentation

char* error_logfile = NULL [static]

Definition at line 77 of file tclscript.c.

Tcl_Interp* ginterp [static]

Definition at line 75 of file tclscript.c.

tcl_listener_t* listener_list_head = NULL [static]

Definition at line 642 of file tclscript.c.

script_module_t my_script_interface [static]

Initial value:

 {
  "Tcl", NULL,
  my_load_script,
  my_link_var, my_unlink_var,
  my_create_command, my_delete_command,
  my_get_arg
}

Definition at line 67 of file tclscript.c.

bind_list_t party_commands[] [static]

Initial value:

 {
  {"n", "tcl", (Function) party_tcl},
  {0}
}

Definition at line 725 of file tclscript.c.

const char rcsid[] = "$Id: tclscript.c,v 1.52 2007-04-14 15:21:13 sven Exp $" [static]

Definition at line 21 of file tclscript.c.

bind_list_t secondly_binds[] [static]

Initial value:

 {
  {NULL, NULL, tclscript_secondly},
  {0}
}

Definition at line 730 of file tclscript.c.

event_owner_t tcl_owner [static]

Initial value:

 {
  "tclscript", 0,
  0, 0,
  my_tcl_cb_delete
}

Definition at line 61 of file tclscript.c.