modules/perlscript/perlscript.c File Reference

#include <stdio.h>
#include <stdlib.h>
#include <EXTERN.h>
#include <perl.h>
#include <XSUB.h>
#include <eggdrop/eggdrop.h>

Go to the source code of this file.

Data Structures
struct	my_args_data_t
Functions
static	XS (my_command_handler)
static SV *	c_to_perl_var (script_var_t *v)
static int	perl_to_c_var (SV *sv, script_var_t *var, int type)
static int	my_perl_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 *linked_var)
static int	my_unlink_var (void *ignore, script_linked_var_t *linked_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)
int	log_error (char *msg)
static void	set_linked_var (script_linked_var_t *linked_var, SV *sv, script_var_t *val)
static int	linked_var_get (pTHX_ SV *sv, MAGIC *mg)
static int	linked_var_set (pTHX_ SV *sv, MAGIC *mg)
static int	my_perl_callbacker (script_callback_t *me,...)
char *	real_perl_cmd (char *text)
static void	init_xs_stuff ()
int	perlscript_init ()
int	perlscript_destroy ()
Variables
static const char	rcsid [] = "$Id: perlscript.c,v 1.33 2007-04-14 15:21:13 sven Exp $"
static PerlInterpreter *	ginterp
script_module_t	my_script_interface
event_owner_t	perl_owner

---

Function Documentation

static SV * c_to_perl_var

(

script_var_t *

v

)

[static]

Definition at line 299 of file perlscript.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, SCRIPT_ARRAY, SCRIPT_BYTES, SCRIPT_FREE, SCRIPT_FREE_VAR, SCRIPT_INTEGER, SCRIPT_PARTIER, SCRIPT_POINTER, SCRIPT_STRING, SCRIPT_TYPE_MASK, SCRIPT_UNSIGNED, SCRIPT_USER, SCRIPT_VAR, script_var_b::type, and script_var_b::value.

Referenced by my_perl_callbacker(), set_linked_var(), and XS().

{
  SV *result;

  if (v->type & SCRIPT_ARRAY) {
    AV *array;
    SV *element;
    int i;

    array = newAV();
    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_perl_var(v_list[i]);
        av_push(array, element);
      }
    }
    else {
      script_var_t v_sub;
      void **values;

      v_sub.type = v->type & (~SCRIPT_ARRAY);
      values = (void **)v->value;
      for (i = 0; i < v->len; i++) {
        v_sub.value = values[i];
        v_sub.len = -1;
        element = c_to_perl_var(&v_sub);
        av_push(array, element);
      }
    }
    if (v->type & SCRIPT_FREE) free(v->value);
    if (v->type & SCRIPT_FREE_VAR) free(v);
    result = newRV_noinc((SV *)array);
    return(result);
  }

  switch (v->type & SCRIPT_TYPE_MASK) {
    case SCRIPT_INTEGER:
    case SCRIPT_UNSIGNED:
      result = newSViv((int) v->value);
      break;
    case SCRIPT_STRING: {
      char *str = v->value;

      if (!str) str = "";
      if (v->len == -1) v->len = strlen(str);
      result = newSVpv(str, v->len);
      if (v->value && v->type & SCRIPT_FREE) free(v->value);
      break;
    }
    case SCRIPT_BYTES: {
      byte_array_t *bytes = v->value;

      result = newSVpv(bytes->bytes, bytes->len);
      if (bytes->do_free) free(bytes->bytes);
      if (v->type & SCRIPT_FREE) free(bytes);
      break;
    }
    case SCRIPT_POINTER: {
      char str[32];
      int str_len;

      sprintf(str, "#%u", (unsigned int) v->value);
      str_len = strlen(str);
      result = newSVpv(str, str_len);
      break;
    }
    case SCRIPT_USER: {
      char *handle;
      int str_len;
      user_t *u = v->value;

      handle = u->handle;

      str_len = strlen(handle);
      result = newSVpv(handle, str_len);
      break;
    }
    case SCRIPT_PARTIER: {
      partymember_t *p = v->value;

      if (p) result = newSVpv(p->full_id_name, strlen(p->full_id_name));
      else result = newSVpv("*", 1);
      break;
    }
    default:
      result = &PL_sv_undef;
  }
  return(result);
}

static void init_xs_stuff

(

)

[static]

Definition at line 523 of file perlscript.c.

Referenced by perlscript_init().

{
  extern void boot_DynaLoader();
  newXS("DynaLoader::boot_DynaLoader", boot_DynaLoader, "eggdrop");
}

static int linked_var_get	(	pTHX_ SV *	sv,
		MAGIC *	mg
	)			[static]

Definition at line 125 of file perlscript.c.

References script_linked_var_b::callbacks, NULL, script_var_callbacks_b::on_read, and set_linked_var().

Referenced by my_link_var().

{
  script_linked_var_t *linked_var = (script_linked_var_t *)mg->mg_ptr;

  if (linked_var->callbacks && linked_var->callbacks->on_read) {
    script_var_t newvalue = {0};
    int r = (linked_var->callbacks->on_read)(linked_var, &newvalue);
    if (r) return(r);
    set_linked_var(linked_var, sv, &newvalue);
  }
  else set_linked_var(linked_var, sv, NULL);
  return(0);
}

static int linked_var_set	(	pTHX_ SV *	sv,
		MAGIC *	mg
	)			[static]

Definition at line 139 of file perlscript.c.

Referenced by my_link_var().

{
  script_linked_var_t *linked_var = (script_linked_var_t *)mg->mg_ptr;
  script_var_t newvalue = {0};

  perl_to_c_var(sv, &newvalue, linked_var->type);
  script_linked_var_on_write(linked_var, &newvalue);
  return(0);
}

int log_error

(

char *

msg

)

Definition at line 36 of file mod_iface.c.

References _, LOG_MISC, and putlog().

Referenced by my_load_script(), and my_perl_callbacker().

{
  putlog(LOG_MISC, "*", _("Perl error: %s"), msg);
  return(0);
}

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

Definition at line 275 of file perlscript.c.

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

{
  char *cmdname;
  CV *cv;

  if (info->class && strlen(info->class)) {
    cmdname = egg_mprintf("%s_%s", info->class, info->name);
  }
  else {
    cmdname = strdup(info->name);
  }
  cv = newXS(cmdname, my_command_handler, "eggdrop");
  XSANY.any_ptr = info;
  free(cmdname);

  return(0);
}

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

Definition at line 293 of file perlscript.c.

{
  /* Not sure how to delete CV's in perl yet. */
  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 485 of file perlscript.c.

References my_args_data_t::ax, script_args_b::client_data, my_args_data_t::items, my_args_data_t::mark, perl_to_c_var(), and my_args_data_t::sp.

{
  my_args_data_t *argdata;
  register SV **sp;
  register SV **mark;
  I32 ax;
  I32 items;

  argdata = (my_args_data_t *)args->client_data;
  sp = argdata->sp;
  mark = argdata->mark;
  ax = argdata->ax;
  items = argdata->items;

  if (num >= items) return(-1);

  return perl_to_c_var(ST(num), var, type);
}

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

Definition at line 150 of file perlscript.c.

References script_linked_var_b::class, egg_mprintf(), linked_var_get(), linked_var_set(), script_linked_var_b::name, NULL, and set_linked_var().

{
  MAGIC *mg;
  SV *sv;
  char *name;

  /* Figure out the perl name of the variable. */
  if (linked_var->class && strlen(linked_var->class)) name = egg_mprintf("%s::%s", linked_var->class, linked_var->name);
  else name = strdup(linked_var->name);

  /* Get a pointer to the sv, creating it if necessary. */
  sv = get_sv(name, TRUE);
  free(name);

  /* Set the initial value before we do our magic. */
  set_linked_var(linked_var, sv, NULL);

  /* Create the magic virtual table, which hooks in our callbacks.
    We put a pointer to linked_var as the name field, with a length
    of -1, which tells perl to just store the pointer. Then we can
    use it later to know which variable is being read/written. */
  sv_magic(sv, NULL, 'U', (char *)linked_var, sizeof(*linked_var));

  /* This part is based on code generated by SWIG. */
  mg = mg_find(sv, 'U');
  mg->mg_virtual = (MGVTBL *)calloc(1, sizeof(MGVTBL));
  mg->mg_virtual->svt_get = linked_var_get;
  mg->mg_virtual->svt_set = linked_var_set;

  return(0);
}

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

Definition at line 74 of file perlscript.c.

References log_error().

{
  FILE *fp;
  char *data;
  int size, len;

  /* Check the filename and make sure it ends in .pl */
  len = strlen(fname);
  if (len < 3 || fname[len-1] != 'l' || fname[len-2] != 'p' || fname[len-3] != '.') {
    /* Nope, not ours. */
    return(0);
  }

  fp = fopen(fname, "r");
  if (!fp) return (0);
  fseek(fp, 0, SEEK_END);
  size = ftell(fp);
  data = (char *)malloc(size + 1);
  fseek(fp, 0, SEEK_SET);
  fread(data, size, 1, fp);
  data[size] = 0;
  fclose(fp);
  eval_pv(data, TRUE);
  if (SvTRUE(ERRSV)) {
    char *msg;
    int len;

    msg = SvPV(ERRSV, len);
    log_error(msg);
  }
  free(data);
  return(0);
}

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

Definition at line 209 of file perlscript.c.

References c_to_perl_var(), script_callback_b::callback_data, cmd, count, script_var_b::len, log_error(), SCRIPT_INTEGER, SCRIPT_UNSIGNED, script_callback_b::syntax, script_var_b::type, and script_var_b::value.

Referenced by perl_to_c_var().

{
  int retval, i, n, count;
  script_var_t var;
  SV *cmd, *arg;
  va_list va;
  dSP;

  ENTER;
  SAVETMPS;
  PUSHMARK(SP);

  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_perl_var(&var);
    XPUSHs(sv_2mortal(arg));
  }
  va_end(va);
  PUTBACK;

  cmd = me->callback_data;
  SvREFCNT_inc(cmd);

  count = call_sv(cmd, G_EVAL|G_SCALAR);
  SvREFCNT_dec(cmd);

  SPAGAIN;

  if (SvTRUE(ERRSV)) {
    char *msg;
    int len;

    msg = SvPV(ERRSV, len);
    retval = POPi;
    log_error(msg);
  }
  else if (count > 0) {
    retval = POPi;
  }
  else retval = 0;

  PUTBACK;
  FREETMPS;
  LEAVE;

  return(retval);
}

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

Definition at line 263 of file perlscript.c.

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

{
  script_callback_t *me = data;

  if (me->syntax) free(me->syntax);
  if (me->name) free(me->name);
  sv_2mortal((SV *)me->callback_data);
  SvREFCNT_dec((SV *)me->callback_data);
  free(me);
  return(0);
}

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

Definition at line 182 of file perlscript.c.

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

{
  MAGIC *mg;
  SV *sv;
  char *name;

  /* Figure out the perl name of the variable. */
  if (linked_var->class && strlen(linked_var->class)) name = egg_mprintf("%s::%s", linked_var->class, linked_var->name);
  else name = strdup(linked_var->name);

  /* Get a pointer to the sv, creating it if necessary. */
  sv = get_sv(name, FALSE);
  free(name);

  if (!sv) return(0);

  mg = mg_find(sv, 'U');
  free(mg->mg_virtual);
  mg->mg_virtual = NULL;

  mg_free(sv);
  mg_clear(sv);
  SvREFCNT_dec(sv);

  return(0);
}

static int perl_to_c_var	(	SV *	sv,
		script_var_t *	var,
		int	type
	)			[static]

Definition at line 392 of file perlscript.c.

References script_callback_b::callback, script_callback_b::callback_data, script_var_b::len, my_perl_callbacker(), script_callback_b::name, NULL, script_callback_b::owner, partymember_lookup(), SCRIPT_BYTES, SCRIPT_CALLBACK, SCRIPT_INTEGER, SCRIPT_PARTIER, SCRIPT_STRING, SCRIPT_UNSIGNED, SCRIPT_USER, script_var_b::type, user_lookup_by_handle(), and script_var_b::value.

Referenced by my_get_arg().

{
  int len;

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

  switch (type) {
    case SCRIPT_BYTES: /* Byte-array. */
    case SCRIPT_STRING: { /* String. */
      var->value = SvPV(sv, len);
      break;
    }
    case SCRIPT_UNSIGNED:
    case SCRIPT_INTEGER: { /* Integer. */
      var->value = (void *)SvIV(sv);
      break;
    }
    case SCRIPT_CALLBACK: { /* Callback. */
      script_callback_t *cback;
      char *name;

      cback = (script_callback_t *)calloc(1, sizeof(*cback));
      cback->callback = (Function) my_perl_callbacker;
      name = SvPV(sv, len);
      cback->name = strdup(name);
      cback->callback_data = newSVsv(sv);
      cback->owner = &perl_owner;

      var->value = cback;
      break;
    }
    case SCRIPT_PARTIER: {
      var->value = partymember_lookup(SvPV(sv, len), NULL, -1);
      break;
    }
    case SCRIPT_USER: { /* User. */
      user_t *u;
      char *handle;

      handle = SvPV(sv, len);
      if (handle) u = user_lookup_by_handle(handle);
      else u = NULL;
      var->value = u;
      break;
    }
    default:
      return(1); /* Error */
  }
  return(0); /* No error */
}

int perlscript_destroy

(

)

Definition at line 539 of file perlscript.c.

References ginterp.

Referenced by perlscript_close().

{
  PL_perl_destruct_level = 1;
  perl_destruct(ginterp);
  perl_free(ginterp);
  return(0);
}

int perlscript_init

(

)

Definition at line 529 of file perlscript.c.

References ginterp, init_xs_stuff(), and NULL.

Referenced by perlscript_LTX_start().

{
  char *embedding[] = {"", "-e", "0"};

  ginterp = perl_alloc();
  perl_construct(ginterp);
  perl_parse(ginterp, init_xs_stuff, 3, embedding, NULL);
  return(0);
}

char* real_perl_cmd

(

char *

text

)

Definition at line 504 of file perlscript.c.

References egg_mprintf().

Referenced by party_perl().

{
  SV *result;
  char *msg, *retval;
  int len;

  result = eval_pv(text, FALSE);
  if (SvTRUE(ERRSV)) {
    msg = SvPV(ERRSV, len);
    retval = egg_mprintf("Perl error: %s", msg);
  }
  else {
    msg = SvPV(result, len);
    retval = egg_mprintf("Perl result: %s\n", msg);
  }

  return(retval);
}

static void set_linked_var	(	script_linked_var_t *	linked_var,
		SV *	sv,
		script_var_t *	val
	)			[static]

Definition at line 108 of file perlscript.c.

References c_to_perl_var(), script_var_b::len, SCRIPT_TYPE_MASK, script_linked_var_b::type, script_var_b::type, script_linked_var_b::value, and script_var_b::value.

Referenced by linked_var_get(), my_link_var(), and my_trace_callback().

{
  SV *newsv;
  script_var_t var;

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

  newsv = c_to_perl_var(val);
  sv_setsv(sv, newsv);
  SvREFCNT_dec(newsv);
}

static XS

(

my_command_handler

)

[static]

Definition at line 445 of file perlscript.c.

References c_to_perl_var(), script_raw_command_t::callback, script_raw_command_t::client_data, script_module_b::client_data, cmd, and NULL.

{
  dXSARGS;

  /* Now we have an "items" variable for number of args and also an XSANY.any_ptr variable for client data. This isn't what you would call a "well documented" feature of perl heh. */

  script_raw_command_t *cmd = (script_raw_command_t *) XSANY.any_ptr;
  script_var_t retval;
  SV *result = NULL;
  script_args_t args;
  my_args_data_t argdata;

  argdata.mark = mark;
  argdata.sp = sp;
  argdata.ax = ax;
  argdata.items = items;
  args.module = &my_script_interface;
  args.client_data = &argdata;
  args.len = items;

  retval.type = 0;
  retval.value = NULL;
  retval.len = -1;

  cmd->callback(cmd->client_data, &args, &retval);

  /* No error exceptions right now. */
  /* err = retval.type & SCRIPT_ERROR; */
  result = c_to_perl_var(&retval);

  if (result) {
    XSprePUSH;
    PUSHs(result);
    XSRETURN(1);
  }
  else {
    XSRETURN_EMPTY;
  }
}

---

Variable Documentation

PerlInterpreter* ginterp [static]

Definition at line 36 of file perlscript.c.

Referenced by my_create_command(), my_delete_command(), my_link_var(), my_load_script(), my_unlink_var(), party_tcl(), perlscript_destroy(), perlscript_init(), set_linked_var(), tclscript_close(), and tclscript_LTX_start().

script_module_t my_script_interface

Initial value:

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

Definition at line 50 of file perlscript.c.

event_owner_t perl_owner

Initial value:

 {
  "perlscript", 0,
  0, 0,
  my_perl_cb_delete
}

Definition at line 58 of file perlscript.c.

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

Definition at line 21 of file perlscript.c.