#define PERL_NO_GET_CONTEXT
#include "EXTERN.h"
#include "perl.h"
#include "XSUB.h"

#include "message.h"

/*
 * struct message
 */

void S_destroy_message(pTHX_ const message* message_) {
	PerlMemShared_free((message*)message_);
}

static SV* S_message_get_sv(pTHX_ const message* message) {
	SV* stored = newSVpvn(message->value, message->length);
	return stored;
}

#define message_get_sv(message) S_message_get_sv(aTHX_ message)

static const message* S_message_new_sv(pTHX_ SV* value, enum message_type type) {
	message* message;
	const char* string;
	STRLEN len;
	string = SvPV(value, len);
   	message = PerlMemShared_calloc(1, sizeof(*message) + len + 1);
	message->type = type;
	message->length = len;
	Copy(string, message->value, len, char);
	return message;
}

#define message_new_sv(value, type) S_message_new_sv(aTHX_ value, type)

const message* S_message_store_value(pTHX_ SV* value) {
	dSP;
	const message* ret;
	ENTER;
	SAVETMPS;
	sv_setiv(save_scalar(gv_fetchpv("Storable::Deparse", TRUE | GV_ADDMULTI, SVt_PV)), 1);
	PUSHMARK(SP);
	XPUSHs(sv_2mortal(newRV_inc(value)));
	PUTBACK;
	call_pv("Storable::mstore", G_SCALAR);
	SPAGAIN;
	ret = message_new_sv(POPs, STORABLE);
	FREETMPS;
	LEAVE;
	PUTBACK;
	return ret;
}

static int S_is_simple(pTHX_ SV* value) {
	return SvOK(value) && !SvROK(value) && !(SvPOK(value) && SvUTF8(value));
}
#define is_simple(value) S_is_simple(aTHX_ value)

static int S_are_simple(pTHX_ SV** begin, SV** end) {
	SV** current;
	for(current = begin; current <= end; current++)
		if (! is_simple(*current))
			return FALSE;
	return TRUE;
}

#define are_simple(begin, end) S_are_simple(aTHX_ begin, end)

static const char pack_template[] = "(I/a)*";

const message* S_message_from_stack(pTHX) {
	dSP; dMARK;
	if (SP == MARK && is_simple(*SP)) {
		return message_new_sv(MARK[0], STRING);
	}
	else if (are_simple(MARK + 1, SP)) {
		SV* tmp = sv_2mortal(newSVpvn("", 0));
		packlist(tmp, pack_template, pack_template + sizeof pack_template - 1, MARK + 1, SP + 1);
		return message_new_sv(tmp, PACKED);
	}
	else {
		SV* list = sv_2mortal((SV*)av_make(SP - MARK, MARK + 1));
		return message_store_value(list);
	}
}

SV* S_message_load_value(pTHX_ const message* message) {
	dSP;
	SV* ret;

	sv_setiv(save_scalar(gv_fetchpv("Storable::Eval", TRUE | GV_ADDMULTI, SVt_PV)), 1);
	PUSHMARK(SP);
	XPUSHs(sv_2mortal(message_get_sv(message)));
	PUTBACK;
	call_pv("Storable::thaw", G_SCALAR);
	SPAGAIN;
	ret = POPs;
	PUTBACK;
	return ret;
}

void S_message_to_stack(pTHX_ const message* message, U32 context) {
	dSP;
	switch(message->type) {
		case STRING:
			PUSHs(sv_2mortal(newRV_noinc(message_get_sv(message))));
			break;
		case PACKED: {
			SV* mess = sv_2mortal(message_get_sv(message));
			STRLEN len;
			const char* packed = SvPV(mess, len);
			PUTBACK;
			unpackstring(pack_template, pack_template + sizeof pack_template - 1, packed, packed + len, 0);
			SPAGAIN;
			break;
		}
		case STORABLE: {
			AV* values = (AV*) SvRV(message_load_value(message));
			SPAGAIN;

			if (context == G_SCALAR) {
				SV** ret = av_fetch(values, 0, FALSE);
				PUSHs(ret ? *ret : &PL_sv_undef);
			}
			else if (context == G_ARRAY) {
				UV count = av_len(values) + 1;
				EXTEND(SP, count);
				Copy(AvARRAY(values), SP + 1, count, SV*);
				SP += count;
			}
			break;
		}
		default:
			Perl_croak(aTHX_ "Type %d is not yet implemented", message->type);
	}

	PUTBACK;
}

AV* S_message_to_array(pTHX_ const message* message) {
	dSP;
	AV* ret;
	switch(message->type) {
		case STRING:
			ret = newAV();
			av_push(ret, message_get_sv(message));
			break;
		case PACKED: {
			SV* mess = message_get_sv(message);
			STRLEN len;
			int count;
			const char* packed = SvPV(mess, len);
			SV** mark = SP;
			PUTBACK;
			count = unpackstring(pack_template, pack_template + sizeof pack_template - 1, packed, packed + len, 0);
			SPAGAIN;
			ret = av_make(count, mark + 1);
			break;
		}
		case STORABLE: {
			ret = (AV*)SvREFCNT_inc(SvRV(message_load_value(message)));
			SPAGAIN;
			break;
		}
		default:
			Perl_croak(aTHX_ "Type %d is not yet implemented", message->type);
	}
	PUTBACK;

	return ret;
}

const message* S_message_clone(pTHX_ const message* origin) {
	/* return savesharedpvn(origin, sizeof(message) + origin->length + 1) */
	size_t size = sizeof(message) + origin->length + 1;
	message* clone = PerlMemShared_calloc(1, size);
	Copy(origin, clone, size, char);
	return clone;
}