The Perl Toolchain Summit needs more sponsors. If your company depends on Perl, please support this very important event.
#include "EXTERN.h"
#include "perl.h"
#include "XSUB.h"

#include <blade.h>

/* We do a bit of work to make sure more than
 * one callback can be registered at a time,
 * although it's probably time wasted.
 */

typedef struct {
  SV *code;
  SV *data;
  blade_env *blade;
} CallbackStruct;

static CallbackStruct *structs = 0;
static long n_structs = 0;
static long n_structs_used = 0;
#define STRUCTS_ALLOCATE_AT_A_TIME 128

static void allocate_more_structs() {

  structs = realloc(structs,
		(n_structs + STRUCTS_ALLOCATE_AT_A_TIME) *
		sizeof(CallbackStruct)
		);
  if (!structs)
    croak("allocate_more_structs() - out of memory");

  memset(structs + n_structs, 0,
	 STRUCTS_ALLOCATE_AT_A_TIME * sizeof(CallbackStruct)
	 );

  n_structs += STRUCTS_ALLOCATE_AT_A_TIME;

}

/*
 * Given a blade_env*, find the index of the callback data for that pointer.
 * Returns -1 if no callback matched.
 */
static long find_callback(blade_env *blade) {

  long index;

  for (index=0; index<n_structs_used; index++) {
    if (structs[index].blade == blade)
      return index;
  }

  return -1;
}
  
void unregister_blade_run_callback(blade_env *blade) {
  long index = find_callback(blade);

  if (index != -1) {
    SvREFCNT_dec(structs[index].code);
    SvREFCNT_dec(structs[index].data);
    structs[index].code = NULL;
    structs[index].data = NULL;
    structs[index].blade = NULL;
    n_structs_used--;
  }
}

void register_blade_run_callback(blade_env *blade, SV* code, SV* data) {

  long i;
  long index = find_callback(blade);

  /* already registered a callback for this blade_env */
  if (index != -1) {
    SvREFCNT_dec(structs[index].code);
    structs[index].code = code;
    SvREFCNT_dec(structs[index].data);
    structs[index].data = data;
  }
  else {

    /* Allocate more structures if necessary, otherwise
     * find the first non-used structure entry
     */
    if (n_structs_used == n_structs) {
      index = n_structs;
      allocate_more_structs();
    }
    else {
      for (i=0; i<n_structs_used; i++) {
	if (structs[i].blade == NULL) {
	  index = i;
	  break;
	}
      }
      if (index >= n_structs_used)
	croak("this shouldn't happen, bug in register_blade_run_callback()");
    }

    structs[index].code = code;
    structs[index].data = data;
    structs[index].blade = blade;

    n_structs_used++;
  }

  SvREFCNT_inc(code);
  SvREFCNT_inc(data);
}

void blade_run_wrapper(blade_env *blade, void *data) {

  long index;
  SV *blade_sv;

  dSP;
  ENTER;
  SAVETMPS;
  PUSHMARK(sp);

  index = find_callback(blade);

  if (index == -1)
    croak("blade_run_wrapper() - this did not happen");

  blade_sv = sv_newmortal();
  sv_setref_pv(blade_sv,"BLADEENV",blade);

  XPUSHs(blade_sv);
  XPUSHs(structs[index].data);
  PUTBACK;

  perl_call_sv(structs[index].code, G_DISCARD);

  SPAGAIN;
  PUTBACK;
  FREETMPS;
  LEAVE;
}