jpl/PerlInterpreter/PerlInterpreter.c

   1 /*
   2  * "The Road goes ever on and on, down from the door where it began."
   3  */
   4
   5 #include "PerlInterpreter.h"
   6 #include <dlfcn.h>
   7
   8 #include "EXTERN.h"
   9 #include "perl.h"
  10
  11 #ifndef PERL_VERSION
  12 #  include <patchlevel.h>
  13 #  define PERL_REVISION         5
  14 #  define PERL_VERSION          PATCHLEVEL
  15 #  define PERL_SUBVERSION       SUBVERSION
  16 #endif
  17
  18 #if PERL_REVISION == 5 && (PERL_VERSION < 4 || \
  19                            (PERL_VERSION == 4 && PERL_SUBVERSION <= 75))
  20 #  define PL_na                         na
  21 #  define PL_sv_no                      sv_no
  22 #  define PL_sv_undef                   sv_undef
  23 #  define PL_dowarn                     dowarn
  24 #  define PL_curinterp                  curinterp
  25 #  define PL_do_undump                  do_undump
  26 #  define PL_perl_destruct_level        perl_destruct_level
  27 #  define ERRSV                         GvSV(errgv)
  28 #endif
  29
  30 #ifndef newSVpvn
  31 #  define newSVpvn(a,b) newSVpv(a,b)
  32 #endif
  33
  34 #ifndef pTHX
  35 #  define pTHX          void
  36 #  define pTHX_
  37 #  define aTHX
  38 #  define aTHX_
  39 #  define dTHX          extern int JNI___notused
  40 #endif
  41
  42 #ifndef EXTERN_C
  43 #  ifdef __cplusplus
  44 #    define EXTERN_C extern "C"
  45 #  else
  46 #    define EXTERN_C extern
  47 #  endif
  48 #endif
  49
  50 static void xs_init (pTHX);
  51 static PerlInterpreter *my_perl;
  52
  53 int jpldebug = 0;
  54 JNIEnv *jplcurenv;
  55
  56 JNIEXPORT void JNICALL
  57 Java_PerlInterpreter_init(JNIEnv *env, jobject obj, jstring js)
  58 {
  59     int exitstatus;
  60     int argc = 3;
  61     SV* envsv;
  62     SV* objsv;
  63
  64     static char *argv[] = {"perl", "-e", "1", 0};
  65
  66     if (getenv("JPLDEBUG"))
  67         jpldebug = atoi(getenv("JPLDEBUG"));
  68
  69     if (jpldebug)
  70         fprintf(stderr, "init\n");
  71
  72     if (!dlopen("libperl.so", RTLD_LAZY|RTLD_GLOBAL)) {
  73         fprintf(stderr, "%s\n", dlerror());
  74         exit(1);
  75     }
  76
  77     if (PL_curinterp)
  78         return;
  79
  80     perl_init_i18nl10n(1);
  81
  82     if (!PL_do_undump) {
  83         my_perl = perl_alloc();
  84         if (!my_perl)
  85             exit(1);
  86         perl_construct( my_perl );
  87         PL_perl_destruct_level = 0;
  88     }
  89
  90     exitstatus = perl_parse( my_perl, xs_init, argc, argv, (char **) NULL );
  91
  92     if (!exitstatus)
  93         Java_PerlInterpreter_eval(env, obj, js);
  94
  95 }
  96
  97 JNIEXPORT void JNICALL
  98 Java_PerlInterpreter_eval(JNIEnv *env, jobject obj, jstring js)
  99 {
 100     SV* envsv;
 101     SV* objsv;
 102     dSP;
 103     jbyte* jb;
 104
 105     ENTER;
 106     SAVETMPS;
 107
 108     jplcurenv = env;
 109     envsv = perl_get_sv("JPL::_env_", 1);
 110     sv_setiv(envsv, (IV)(void*)env);
 111     objsv = perl_get_sv("JPL::_obj_", 1);
 112     sv_setiv(objsv, (IV)(void*)obj);
 113
 114     jb = (jbyte*)(*env)->GetStringUTFChars(env,js,0);
 115
 116     if (jpldebug)
 117         fprintf(stderr, "eval %s\n", (char*)jb);
 118
 119     perl_eval_pv( (char*)jb, 0 );
 120
 121     if (SvTRUE(ERRSV)) {
 122         jthrowable newExcCls;
 123
 124         (*env)->ExceptionDescribe(env);
 125         (*env)->ExceptionClear(env);
 126
 127         newExcCls = (*env)->FindClass(env, "java/lang/RuntimeException");
 128         if (newExcCls)
 129             (*env)->ThrowNew(env, newExcCls, SvPV(ERRSV,PL_na));
 130     }
 131
 132     (*env)->ReleaseStringUTFChars(env,js,jb);
 133     FREETMPS;
 134     LEAVE;
 135
 136 }
 137
 138 /*
 139 JNIEXPORT jint JNICALL
 140 Java_PerlInterpreter_eval(JNIEnv *env, jobject obj, jint ji)
 141 {
 142     op = (OP*)(void*)ji;
 143     op = (*op->op_ppaddr)(pTHX);
 144     return (jint)(void*)op;
 145 }
 146 */
 147
 148 /* Register any extra external extensions */
 149
 150 /* Do not delete this line--writemain depends on it */
 151 EXTERN_C void boot_DynaLoader (pTHX_ CV* cv);
 152 EXTERN_C void boot_JNI (pTHX_ CV* cv);
 153
 154 static void
 155 xs_init(pTHX)
 156 {
 157     char *file = __FILE__;
 158     dXSUB_SYS;
 159         newXS("DynaLoader::boot_DynaLoader", boot_DynaLoader, file);
 160 }