/****************************************************************************
 * rb2pl.c
 * Conversion routines between Ruby and Perl data types.
 ****************************************************************************/

#include "rb2pl.h"
#include "st.h"		/* ST_CONTINUE */

#define INL_MAGIC_NUM 0x2943545b
#define INL_MAGIC_KEY(mg_ptr) (((inline_magic *)mg_ptr)->key)
#define INL_MAGIC_CHECK(mg_ptr) (INL_MAGIC_KEY(mg_ptr) == INL_MAGIC_NUM)

/*============================================================================
 * class InlineRubyWrapper {
 *    // ctor, dtor:
 *    SV* new_InlineRubyWrapper(VALUE, SV*);
 *    int free_InlineRubyWrapper(SV* obj, MAGIC* mg);
 *
 *    // get magic
 *    inline_magic* data_InlineRubyWrapper(SV* self);
 *
 *    // isa? (class method)
 *    int isa_InlineRubyWrapper(SV* candidate);
 * };
 *==========================================================================*/
static int
free_InlineRubyWrapper(pTHX_ SV* obj, MAGIC* mg) {
    if (mg && mg->mg_type == '~' && INL_MAGIC_CHECK(mg->mg_ptr)) {
	SV* pl_obj = ((inline_magic*)mg->mg_ptr)->iter;
	if (pl_obj)
	    SvREFCNT_dec(pl_obj);
    }
    else {
	croak("ERROR: tried to free a non-Ruby object. Aborting.");
    }
}

SV *
new_InlineRubyWrapper(VALUE obj, SV* iter) {
    SV *wrapper = (SV*)newHV();
    SV *self = newRV_noinc(wrapper);
    MAGIC *mg;
    inline_magic priv;

    /* Initialize object */
    priv.key = INL_MAGIC_NUM;
    priv.rb_val = obj;
    priv.iter = iter;
    if (iter)
	SvREFCNT_inc(iter);

    /* bless inst into an Inline::Ruby::Object */
    sv_bless(self, gv_stashpv("Inline::Ruby::Object", 1));

    /* set up magic */
    sv_magic(wrapper, wrapper, '~', (char*)&priv, sizeof(priv));
    mg = mg_find(wrapper, '~');
    mg->mg_virtual = (MGVTBL*)malloc(sizeof(MGVTBL));
    mg->mg_virtual->svt_free = &free_InlineRubyWrapper;

#ifdef I_RB_DEBUG
    Printf(("new_InlineRubyWrapper\n"));
    /*sv_dump(self);
    sv_dump(wrapper);*/
#endif
    return self;
}

int
isa_InlineRubyWrapper(SV* obj) {
#ifdef I_RB_DEBUG
    Printf(("isa_InlineRubyWrapper(%p)\n", obj));
    if (obj) {
	/*sv_dump(obj);*/
	if (SvROK(obj)) {
	    Printf(("SvTYPE(SvRV(obj)) == %i\n", SvTYPE(SvRV(obj))));
	    /*sv_dump(SvRV(obj));*/
	}
    }
#endif
    if (obj && SvROK(obj) && SvTYPE(SvRV(obj)) == SVt_PVHV) {
	SV *wrapped = SvRV(obj);
	MAGIC *mg = mg_find(wrapped, '~');
	Printf(("Okay, object is magic...\n"));
	if (mg && mg->mg_ptr && INL_MAGIC_CHECK(mg->mg_ptr)) {
	    Printf(("Yay, magic found && matched!\n"));
	    return 1;	/* obj is magic, and of the correct type */
	}
	Printf(("Magic not found, or didn't match...\n"));
	return 0;	/* magic, but not the proper type */
    }
    return 0;		/* bloody muggles */
}

inline_magic*
data_InlineRubyWrapper(SV* self) {
    MAGIC *mg = mg_find(SvRV(self), '~');
    return (inline_magic *)mg->mg_ptr;
}

/*============================================================================
 * This class is strictly for Perl subs or closures only. This is great,
 * because Ruby Proc()s can't take blocks, and neither can Perl subs.
 * 
 * class PerlProc {
 *    VALUE new_Proc(SV* cref);
 *    void free_PerlProc(VALUE self);
 *    SV* call_PerlProc(VALUE self);
 * };
 *==========================================================================*/
extern VALUE rb_ePerlException;
VALUE cPerlProc;
typedef struct PerlProc {
    SV* cref;
    I32 flags;
} PerlProc;

static void
free_PerlProc(void *data) {
    Safefree(data);
}

static VALUE
new_PerlProc(SV* cref) {
    PerlProc *data;
    VALUE self;
    
    Newz(527, data, 1, PerlProc);
    if (cref && SvTRUE(cref)) {
	data->cref = cref;
	SvREFCNT_inc(cref);
    }
    data->flags = G_SCALAR | G_EVAL | G_KEEPERR;
    self = Data_Wrap_Struct(cPerlProc, 0, free_PerlProc, data);
    return self;
}

static VALUE
call_PerlProc(VALUE self, VALUE args) {
    dSP;
    PerlProc *data;
    I32 count;
    I32 ax;
    SV *pl_args;
    VALUE rb_retval;

    Printf(("call_PerlProc()...\n"));

    Data_Get_Struct(self, PerlProc, data);

    pl_args = rb2pl(args);

    ENTER;
    SAVETMPS;

    PUSHMARK(SP);
#ifdef	FLATTEN_CALLBACK_ARGS
    if (SvROK(pl_args) && SvTYPE(SvRV(pl_args)) == SVt_PVAV) {
	AV* av = (AV*) SvRV(pl_args);
	int len = av_len(av) + 1;
	int i;
	for (i=0; i<len; i++) {
	    XPUSHs(sv_2mortal(av_shift(av)));
	}
    }
    else
#endif
	XPUSHs(sv_2mortal(pl_args));
    PUTBACK;

    count = call_sv(data->cref, data->flags);

    if (SvTRUE(ERRSV)) {
	if (data->flags & G_SCALAR)
	    POPs;
	rb_raise(rb_ePerlException, SvPV_nolen(ERRSV));
	return Qnil;	/* not reached */
    }

    SPAGAIN;
    SP -= count;
    ax = (SP - PL_stack_base) + 1;
    if (count == 0)
	rb_retval = Qnil;
    else if (count == 1)
	rb_retval = pl2rb(ST(0));
    else {
	int i;
	rb_retval = rb_ary_new2(count);
	for (i=0; i<count; i++) {
	    rb_ary_push(rb_retval, pl2rb(ST(i)));
	}
    }
    PUTBACK;

    FREETMPS;
    LEAVE;

    return rb_retval;
}

static VALUE
arity_PerlProc(VALUE self, VALUE args) {
    return INT2FIX(-1);
}

static VALUE
eq_PerlProc(VALUE self, VALUE other) {
    return Qnil;
}

static VALUE
str_PerlProc(VALUE self, VALUE args) {
    return 
	rb_str_new2("#<PerlProc: sub, closure, or code reference>");
}

extern VALUE rb_cProc;
void
Init_PerlProc() {
    cPerlProc = rb_define_class("PerlProc", rb_cProc);

    rb_undef_method(cPerlProc, "new");
    rb_define_method(cPerlProc, "call", call_PerlProc, -2);
    rb_define_method(cPerlProc, "arity", arity_PerlProc, 0);
    rb_define_method(cPerlProc, "[]", call_PerlProc, -2);
    rb_define_method(cPerlProc, "==", eq_PerlProc, 1);
    rb_define_method(cPerlProc, "to_s", str_PerlProc, 0);
}

/* Shamelessly stolen from hash.c, in the Ruby sources.
 * This is an iterator callback, which is used to populate the array of hash
 * keys. */
static int
keys_i(VALUE key, VALUE value, VALUE ary) {
    if (key == Qundef) return ST_CONTINUE;
    rb_ary_push(ary, key);
    return ST_CONTINUE;
}

SV *
rb2pl(VALUE obj) {
    SV *rval; /* declared for convenience */

#ifdef EXPOSE_PERL
	/* unwrap Perl objects */

	/* unwrap Perl code refs */
#endif

    switch(TYPE(obj)) {
	case T_OBJECT: /* an instance of a class */
	    rval = new_InlineRubyWrapper(obj, NULL);
	    return rval;
	case T_FIXNUM:
	    /* I haven't figured out how to ask Ruby about signed-ness, or
	     * whether it's a long. There are four macros I could use, and I'm
	     * just picking the one that seems safest: */
	    rval = newSViv(NUM2INT(obj));
	    return rval;
	case T_FLOAT:
	    rval = newSVnv(RFLOAT(obj)->value);
	    return rval;
	case T_STRING:
	    rval = newSVpvn(RSTRING(obj)->ptr, RSTRING(obj)->len);
	    return rval;

	case T_ARRAY:
	    {
		/* Convert the Ruby array into a Perl array */
		long i;
		AV *retval = newAV();
		for (i=0; i<RARRAY(obj)->len; i++) {
		    SV *entry = rb2pl(rb_ary_entry(obj, i));
		    av_push(retval, entry);
		}
		rval = newRV_noinc((SV*)retval);
		return rval;
	    }
	case T_HASH:
	    {
		/* Convert the Ruby hash into a Perl hash */
		VALUE keys = rb_ary_new();
		VALUE key;
		long i;
		HV *retval = newHV();
		/* use keys_i() as a callback to populate the keys */
		st_foreach(RHASH(obj)->tbl, &keys_i, keys);
		for (i=0; i<RARRAY(keys)->len; i++) {
		    SV *entry;
		    char *key_c;
		    STRLEN klen;
		    key = rb_ary_entry(keys, i);
		    entry = rb2pl(rb_hash_aref(obj, key));
		    if (TYPE(key) != T_STRING) {
			/* Perl can only use strings as hash keys. 
			 * Use the stringified key, and emit a warning if
			 * warnings are turned on. */
			key = rb_convert_type(key, T_STRING, "String", "to_str");
			warn("Warning: stringifying a hash-key may lose info!");
		    }
		    key_c = RSTRING(key)->ptr;
		    klen = RSTRING(key)->len;
		    hv_store(retval, key_c, klen, entry, 0);
		}
		rval = newRV_noinc((SV*)retval);
		return rval;
	    }
	case T_FALSE:
	case T_NIL:
	    return &PL_sv_undef;
	case T_TRUE:
	    return newSViv(1);
	case T_FILE:
	    /* Why not pass this as a FILE *? */
	case T_REGEXP:
	    /* There's no reason not to translate regexps in the expected
	     * fashion. I suppose the most reasonable way to do this is to
	     * extract the regexp string and re-compile it in Perl. Could
	     * break down if Ruby supports looking up variables inside regexes
	     * as Perl does. */
	default:
	    warn("rb2pl: %i: unrecognized Ruby type\n", TYPE(obj));
	    return &PL_sv_undef;
    }
    return &PL_sv_undef; /* not reached */
}

VALUE
pl2rb(SV *obj) {
    VALUE o;
    if (isa_InlineRubyWrapper(obj)) {
	return INLINE_MAGIC(obj)->rb_val;
    }
#if 0
    else if (sv_isobject(obj)) {
	SV *obj_deref = SvRV(obj);
	HV *stash = SvSTASH(obj_deref);
	char *pkg = HvNAME(stash);
	SV *full_pkg = newSVpvf("main::%s::", pkg);
	VALUE pkg_rb;

	Printf(("A Perl object (%s). Wrapping...\n", SvPV(full_pkg, PL_na)));
    }
#endif 
    else if (SvIOKp(obj)) {
	Printf(("integer: %i\n", SvIV(obj)));
	o = INT2FIX(SvIV(obj));
    }
    else if (SvNOKp(obj)) {
	Printf(("float: %f\n", SvNV(obj)));
	o = rb_float_new(SvNV(obj));
    }
    else if (SvPOKp(obj)) {
	STRLEN len;
	char *ptr = SvPV(obj, len);
	Printf(("string: %s\n", ptr));
	o = rb_str_new(ptr, len);
    }
    else if (SvROK(obj) && SvTYPE(SvRV(obj)) == SVt_PVAV) {
	AV *av = (AV*)SvRV(obj);
	int i;
	int len = av_len(av) + 1;
	o = rb_ary_new2(len);
	
	Printf(("array (%i)\n", len));

	for (i=0; i<len; i++) {
	    SV *tmp = *av_fetch(av, i, 0);
	    rb_ary_store(o, i, pl2rb(tmp));
	}
    }
    else if (SvROK(obj) && SvTYPE(SvRV(obj)) == SVt_PVHV) {
	HV *hv = (HV*)SvRV(obj);
	int len = hv_iterinit(hv);
	int i;

	o = rb_hash_new();

	Printf(("hash (%i)\n", len));

	for (i=0; i<len; i++) {
	    HE *next = hv_iternext(hv);
	    I32 len;
	    char *key = hv_iterkey(next, &len);
	    VALUE key_rb = rb_str_new(key, len);
	    VALUE val_rb = pl2rb(hv_iterval(hv, next));
	    rb_hash_aset(o, key_rb, val_rb);
	}
    }
    else if (SvROK(obj) && SvTYPE(SvRV(obj)) == SVt_PVCV) {
	/* wrap this up in a PerlSub_object */
	Printf(("Yo! Gots myself a coderef here. Wrapping...\n"));
	o = new_PerlProc(obj);
	Printf(("Result: %s\n", STR2CSTR(rb_inspect(o))));
    }
    else {
	o = Qnil;
    }
    Printf(("returning from pl2rb\n"));
    return o;
}