#include "mlp_perl.h"


mlp_perl_function::mlp_perl_function(mlp_context *ctx, mlp_runtime *rt, mlp_library *lib,
	mlp_type rtype, const char *name, mlp_prototype proto)
	: mlp_function(ctx, rt, lib, rtype, name, proto), coderef(NULL) {
	PerlInterpreter *my_perl = ((mlp_perl_runtime *)rt)->_get_my_perl() ;
	ctx->clear_error() ;

	coderef = get_cv(name, FALSE) ;
	if (coderef == NULL){
		ctx->set_error(MLP_NO_SUCH_FUNCTION, "Can't find perl function '%s'\n",
			name) ;
		return ;
	}
}


mlp_perl_function::~mlp_perl_function(){
}


mlp_value *mlp_perl_function::call(mlp_context *ctx, mlp_arguments args){
	PerlInterpreter *my_perl = ((mlp_perl_runtime *)rt)->_get_my_perl() ;
	ctx->clear_error() ;

	dSP ;
	ENTER ;
	SAVETMPS ;

	PUSHMARK(SP) ;
	int i = 0 ;
	for (int i = 0 ; i < args.size() ; i++){
		SV *sv = mlp_perl_allocate_SV((mlp_perl_runtime *)rt, proto[i], &(args[i])) ;
		XPUSHs(sv) ;
	}
	PUTBACK ;

	int count = call_sv((SV *)coderef, G_SCALAR | G_EVAL) ;

	SPAGAIN ;

    if (SvTRUE(ERRSV)){
		// TODO: Deal with the exception and return it to the caller 
        STRLEN n_a ;
		ctx->set_error(MLP_FUNCTION_ERROR, "Error calling function %s: %s",
			name.c_str(), SvPV(ERRSV, n_a)) ;
        return NULL ;
    }
	else if (count != 1){
		ctx->set_error(MLP_INVALID_RETURN_VALUE, "Perl function must return 1 value (not %d)", count) ;
        return NULL ;
	}

	mlp_value *ret = mlp_perl_allocate_mlp_value((mlp_perl_runtime *)rt, rtype, POPs) ;

	FREETMPS ;
	LEAVE ;

	return ret ;
}


void mlp_perl_function::destroy(mlp_context *ctx){
	PerlInterpreter *my_perl = ((mlp_perl_runtime *)rt)->_get_my_perl() ;
	ctx->clear_error() ;

	if (coderef != NULL){
		SvREFCNT_dec(coderef) ;
	}
	mlp_function::destroy(ctx) ;
}


/*
mlp_value *_mlp_perl_call_function(mlp_context *ctx, void *library, const char *name, 
	int nb_args, const mlp_value **args, mlp_type return_type){

	PerlInterpreter *my_perl = mlp_context_get_runtime(ctx)->runtime ;

	return ret ;
}
*/