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"

#ifdef __CYGWIN__
	#include "w32api/basetyps.h"
#endif

/* Include the JNI header file */
#include "jni.h"

/* The PerlInterpreter handle */
PerlInterpreter *interp = NULL ;


/* XS initialisation stuff */
void boot_DynaLoader(pTHX_ CV* cv) ;


static void xs_init(pTHX){
    char *file = __FILE__ ;
    dXSUB_SYS ;
    newXS("DynaLoader::boot_DynaLoader", boot_DynaLoader, file) ;
}



void throw_ijp(JNIEnv *env, char *msg){
	jclass ije ;

	ije = (*(env))->FindClass(env, "org/perl/inline/java/InlineJavaPerlException") ;
	if ((*(env))->ExceptionCheck(env)){
		(*(env))->ExceptionDescribe(env) ;
		(*(env))->ExceptionClear(env) ;
		(*(env))->FatalError(env, "Can't find class InlineJavaPerlException: exiting...") ;
	}
	(*(env))->ThrowNew(env, ije, msg) ;
}


JNIEXPORT void JNICALL Java_org_perl_inline_java_InlineJavaPerlInterpreter_construct(JNIEnv *env, jclass cls){
	char *args[] = {"inline-java", "-e1"} ;
	char **envdup = NULL ;

#ifdef PERL_PARSE_ENV_DUP
	int envl = 0 ;
	int i = 0 ;
	/* This will leak, but it's a one shot... */
	for (i = 0 ; environ[i] != NULL ; i++){
		envl++ ;
	}
	envdup = (char **)calloc(envl + 1, sizeof(char *)) ;
	for (i = 0 ; i < envl ; i++){
		envdup[i] = strdup(environ[i]) ;
	}
#endif
	
	interp = perl_alloc() ;
	perl_construct(interp) ;
	perl_parse(interp, xs_init, 2, args, envdup) ;
	perl_run(interp) ;
}


JNIEXPORT void JNICALL Java_org_perl_inline_java_InlineJavaPerlInterpreter_destruct(JNIEnv *env, jclass cls){
	if (interp != NULL){
		perl_destruct(interp) ;
		perl_free(interp) ;
		interp = NULL ;
	}
}


JNIEXPORT void JNICALL Java_org_perl_inline_java_InlineJavaPerlInterpreter_evalNoReturn(JNIEnv *env, jclass cls, jstring code){
	SV *sv = NULL ;
	char *pcode = NULL ;

	pcode = (char *)((*(env))->GetStringUTFChars(env, code, NULL)) ;
	sv = sv_2mortal(newSVpv(pcode, 0)) ;
	/* sv = eval_pv(pcode, FALSE) ; */
	eval_sv(sv, G_EVAL|G_KEEPERR) ;
	(*(env))->ReleaseStringUTFChars(env, code, pcode) ;
	if (SvTRUE(ERRSV)){
		STRLEN n_a ;
		throw_ijp(env, SvPV(ERRSV, n_a)) ;
	}
}



MODULE = Inline::Java::PerlInterpreter   PACKAGE = Inline::Java::PerlInterpreter

PROTOTYPES: DISABLE