From: Gurusamy Sarathy Date: Thu, 10 Jun 1999 23:34:19 +0000 (+0000) Subject: part of the platform changes for IMPLICIT_CONTEXT X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=41cd373618dfb8cfe39ec8169c4a1b162678c980;p=p5sagit%2Fp5-mst-13.2.git part of the platform changes for IMPLICIT_CONTEXT p4raw-id: //depot/perl@3531 --- diff --git a/djgpp/djgpp.c b/djgpp/djgpp.c index 07eb80e..ae03f21 100644 --- a/djgpp/djgpp.c +++ b/djgpp/djgpp.c @@ -117,10 +117,10 @@ pclose (FILE *pp) #define EXECF_EXEC 1 static int -convretcode (int rc,char *prog,int fl) +convretcode (pTHX_ int rc,char *prog,int fl) { if (rc < 0 && PL_dowarn) - warn ("Can't %s \"%s\": %s",fl ? "exec" : "spawn",prog,Strerror (errno)); + Perl_warn (aTHX_ "Can't %s \"%s\": %s",fl ? "exec" : "spawn",prog,Strerror (errno)); if (rc > 0) return rc <<= 8; if (rc < 0) @@ -129,7 +129,7 @@ convretcode (int rc,char *prog,int fl) } int -do_aspawn (SV *really,SV **mark,SV **sp) +do_aspawn (pTHX_ SV *really,SV **mark,SV **sp) { dTHR; int rc; @@ -164,7 +164,7 @@ do_aspawn (SV *really,SV **mark,SV **sp) #define EXTRA "\x00\x00\x00\x00\x00\x00" int -do_spawn2 (char *cmd,int execf) +do_spawn2 (pTHX_ char *cmd,int execf) { char **a,*s,*shell,*metachars; int rc,unixysh; @@ -232,15 +232,15 @@ doshell: } int -do_spawn (char *cmd) +do_spawn (pTHX_ char *cmd) { - return do_spawn2 (cmd,EXECF_SPAWN); + return do_spawn2 (aTHX_ cmd,EXECF_SPAWN); } bool -do_exec (char *cmd) +Perl_do_exec (pTHX_ char *cmd) { - do_spawn2 (cmd,EXECF_EXEC); + do_spawn2 (aTHX_ cmd,EXECF_EXEC); return FALSE; } @@ -361,7 +361,7 @@ XS(dos_GetCwd) dXSARGS; if (items) - croak ("Usage: Dos::GetCwd()"); + Perl_croak (aTHX_ "Usage: Dos::GetCwd()"); { char tmp[PATH_MAX+2]; ST(0)=sv_newmortal (); @@ -379,7 +379,7 @@ XS(dos_UseLFN) } void -init_os_extras() +Perl_init_os_extras(pTHX) { char *file = __FILE__; diff --git a/jpl/JNI/JNI.xs b/jpl/JNI/JNI.xs index 8a3015a..678e81c 100644 --- a/jpl/JNI/JNI.xs +++ b/jpl/JNI/JNI.xs @@ -20,11 +20,12 @@ extern int jpldebug; static void call_my_exit(jint status) { + dTHX; my_exit(status); } jvalue* -makeargs(char *sig, SV** svp, int items) +makeargs(pTHX_ char *sig, SV** svp, int items) { jvalue* jv = (jvalue*)safemalloc(sizeof(jvalue) * items); int ix = 0; @@ -399,16 +400,16 @@ makeargs(char *sig, SV** svp, int items) } break; case ')': - croak("too many arguments, signature: %s", sig); + Perl_croak(aTHX_ "too many arguments, signature: %s", sig); goto cleanup; default: - croak("panic: malformed signature: %s", s-1); + Perl_croak(aTHX_ "panic: malformed signature: %s", s-1); goto cleanup; } } if (*s != ')') { - croak("not enough arguments, signature: %s", sig); + Perl_croak(aTHX_ "not enough arguments, signature: %s", sig); goto cleanup; } return jv; @@ -419,9 +420,9 @@ cleanup: } static int -not_here(char *s) +not_here(pTHX_ char *s) { - croak("%s not implemented on this architecture", s); + Perl_croak(aTHX_ "%s not implemented on this architecture", s); return -1; } @@ -739,7 +740,7 @@ NewObject(clazz,methodID,...) int argoff = $min_args; CODE: { - jvalue * args = makeargs(sig, &ST(argoff), items - argoff); + jvalue * args = makeargs(aTHX_ sig, &ST(argoff), items - argoff); RETVAL = (*env)->NewObjectA(env, clazz,methodID,args); RESTOREENV; } @@ -809,7 +810,7 @@ CallObjectMethod(obj,methodID,...) int argoff = $min_args; CODE: { - jvalue * args = makeargs(sig, &ST(argoff), items - argoff); + jvalue * args = makeargs(aTHX_ sig, &ST(argoff), items - argoff); RETVAL = (*env)->CallObjectMethodA(env, obj,methodID,args); RESTOREENV; } @@ -840,7 +841,7 @@ CallBooleanMethod(obj,methodID,...) int argoff = $min_args; CODE: { - jvalue * args = makeargs(sig, &ST(argoff), items - argoff); + jvalue * args = makeargs(aTHX_ sig, &ST(argoff), items - argoff); RETVAL = (*env)->CallBooleanMethodA(env, obj,methodID,args); RESTOREENV; } @@ -871,7 +872,7 @@ CallByteMethod(obj,methodID,...) int argoff = $min_args; CODE: { - jvalue * args = makeargs(sig, &ST(argoff), items - argoff); + jvalue * args = makeargs(aTHX_ sig, &ST(argoff), items - argoff); RETVAL = (*env)->CallByteMethodA(env, obj,methodID,args); RESTOREENV; } @@ -902,7 +903,7 @@ CallCharMethod(obj,methodID,...) int argoff = $min_args; CODE: { - jvalue * args = makeargs(sig, &ST(argoff), items - argoff); + jvalue * args = makeargs(aTHX_ sig, &ST(argoff), items - argoff); RETVAL = (*env)->CallCharMethodA(env, obj,methodID,args); RESTOREENV; } @@ -933,7 +934,7 @@ CallShortMethod(obj,methodID,...) int argoff = $min_args; CODE: { - jvalue * args = makeargs(sig, &ST(argoff), items - argoff); + jvalue * args = makeargs(aTHX_ sig, &ST(argoff), items - argoff); RETVAL = (*env)->CallShortMethodA(env, obj,methodID,args); RESTOREENV; } @@ -964,7 +965,7 @@ CallIntMethod(obj,methodID,...) int argoff = $min_args; CODE: { - jvalue * args = makeargs(sig, &ST(argoff), items - argoff); + jvalue * args = makeargs(aTHX_ sig, &ST(argoff), items - argoff); RETVAL = (*env)->CallIntMethodA(env, obj,methodID,args); RESTOREENV; } @@ -995,7 +996,7 @@ CallLongMethod(obj,methodID,...) int argoff = $min_args; CODE: { - jvalue * args = makeargs(sig, &ST(argoff), items - argoff); + jvalue * args = makeargs(aTHX_ sig, &ST(argoff), items - argoff); RETVAL = (*env)->CallLongMethodA(env, obj,methodID,args); RESTOREENV; } @@ -1026,7 +1027,7 @@ CallFloatMethod(obj,methodID,...) int argoff = $min_args; CODE: { - jvalue * args = makeargs(sig, &ST(argoff), items - argoff); + jvalue * args = makeargs(aTHX_ sig, &ST(argoff), items - argoff); RETVAL = (*env)->CallFloatMethodA(env, obj,methodID,args); RESTOREENV; } @@ -1057,7 +1058,7 @@ CallDoubleMethod(obj,methodID,...) int argoff = $min_args; CODE: { - jvalue * args = makeargs(sig, &ST(argoff), items - argoff); + jvalue * args = makeargs(aTHX_ sig, &ST(argoff), items - argoff); RETVAL = (*env)->CallDoubleMethodA(env, obj,methodID,args); RESTOREENV; } @@ -1088,7 +1089,7 @@ CallVoidMethod(obj,methodID,...) int argoff = $min_args; CODE: { - jvalue * args = makeargs(sig, &ST(argoff), items - argoff); + jvalue * args = makeargs(aTHX_ sig, &ST(argoff), items - argoff); (*env)->CallVoidMethodA(env, obj,methodID,args); RESTOREENV; } @@ -1116,7 +1117,7 @@ CallNonvirtualObjectMethod(obj,clazz,methodID,...) int argoff = $min_args; CODE: { - jvalue * args = makeargs(sig, &ST(argoff), items - argoff); + jvalue * args = makeargs(aTHX_ sig, &ST(argoff), items - argoff); RETVAL = (*env)->CallNonvirtualObjectMethodA(env, obj,clazz,methodID,args); RESTOREENV; } @@ -1149,7 +1150,7 @@ CallNonvirtualBooleanMethod(obj,clazz,methodID,...) int argoff = $min_args; CODE: { - jvalue * args = makeargs(sig, &ST(argoff), items - argoff); + jvalue * args = makeargs(aTHX_ sig, &ST(argoff), items - argoff); RETVAL = (*env)->CallNonvirtualBooleanMethodA(env, obj,clazz,methodID,args); RESTOREENV; } @@ -1182,7 +1183,7 @@ CallNonvirtualByteMethod(obj,clazz,methodID,...) int argoff = $min_args; CODE: { - jvalue * args = makeargs(sig, &ST(argoff), items - argoff); + jvalue * args = makeargs(aTHX_ sig, &ST(argoff), items - argoff); RETVAL = (*env)->CallNonvirtualByteMethodA(env, obj,clazz,methodID,args); RESTOREENV; } @@ -1215,7 +1216,7 @@ CallNonvirtualCharMethod(obj,clazz,methodID,...) int argoff = $min_args; CODE: { - jvalue * args = makeargs(sig, &ST(argoff), items - argoff); + jvalue * args = makeargs(aTHX_ sig, &ST(argoff), items - argoff); RETVAL = (*env)->CallNonvirtualCharMethodA(env, obj,clazz,methodID,args); RESTOREENV; } @@ -1248,7 +1249,7 @@ CallNonvirtualShortMethod(obj,clazz,methodID,...) int argoff = $min_args; CODE: { - jvalue * args = makeargs(sig, &ST(argoff), items - argoff); + jvalue * args = makeargs(aTHX_ sig, &ST(argoff), items - argoff); RETVAL = (*env)->CallNonvirtualShortMethodA(env, obj,clazz,methodID,args); RESTOREENV; } @@ -1281,7 +1282,7 @@ CallNonvirtualIntMethod(obj,clazz,methodID,...) int argoff = $min_args; CODE: { - jvalue * args = makeargs(sig, &ST(argoff), items - argoff); + jvalue * args = makeargs(aTHX_ sig, &ST(argoff), items - argoff); RETVAL = (*env)->CallNonvirtualIntMethodA(env, obj,clazz,methodID,args); RESTOREENV; } @@ -1314,7 +1315,7 @@ CallNonvirtualLongMethod(obj,clazz,methodID,...) int argoff = $min_args; CODE: { - jvalue * args = makeargs(sig, &ST(argoff), items - argoff); + jvalue * args = makeargs(aTHX_ sig, &ST(argoff), items - argoff); RETVAL = (*env)->CallNonvirtualLongMethodA(env, obj,clazz,methodID,args); RESTOREENV; } @@ -1347,7 +1348,7 @@ CallNonvirtualFloatMethod(obj,clazz,methodID,...) int argoff = $min_args; CODE: { - jvalue * args = makeargs(sig, &ST(argoff), items - argoff); + jvalue * args = makeargs(aTHX_ sig, &ST(argoff), items - argoff); RETVAL = (*env)->CallNonvirtualFloatMethodA(env, obj,clazz,methodID,args); RESTOREENV; } @@ -1380,7 +1381,7 @@ CallNonvirtualDoubleMethod(obj,clazz,methodID,...) int argoff = $min_args; CODE: { - jvalue * args = makeargs(sig, &ST(argoff), items - argoff); + jvalue * args = makeargs(aTHX_ sig, &ST(argoff), items - argoff); RETVAL = (*env)->CallNonvirtualDoubleMethodA(env, obj,clazz,methodID,args); RESTOREENV; } @@ -1413,7 +1414,7 @@ CallNonvirtualVoidMethod(obj,clazz,methodID,...) int argoff = $min_args; CODE: { - jvalue * args = makeargs(sig, &ST(argoff), items - argoff); + jvalue * args = makeargs(aTHX_ sig, &ST(argoff), items - argoff); (*env)->CallNonvirtualVoidMethodA(env, obj,clazz,methodID,args); RESTOREENV; } @@ -1712,7 +1713,7 @@ CallStaticObjectMethod(clazz,methodID,...) int argoff = $min_args; CODE: { - jvalue * args = makeargs(sig, &ST(argoff), items - argoff); + jvalue * args = makeargs(aTHX_ sig, &ST(argoff), items - argoff); RETVAL = (*env)->CallStaticObjectMethodA(env, clazz,methodID,args); RESTOREENV; } @@ -1743,7 +1744,7 @@ CallStaticBooleanMethod(clazz,methodID,...) int argoff = $min_args; CODE: { - jvalue * args = makeargs(sig, &ST(argoff), items - argoff); + jvalue * args = makeargs(aTHX_ sig, &ST(argoff), items - argoff); RETVAL = (*env)->CallStaticBooleanMethodA(env, clazz,methodID,args); RESTOREENV; } @@ -1774,7 +1775,7 @@ CallStaticByteMethod(clazz,methodID,...) int argoff = $min_args; CODE: { - jvalue * args = makeargs(sig, &ST(argoff), items - argoff); + jvalue * args = makeargs(aTHX_ sig, &ST(argoff), items - argoff); RETVAL = (*env)->CallStaticByteMethodA(env, clazz,methodID,args); RESTOREENV; } @@ -1805,7 +1806,7 @@ CallStaticCharMethod(clazz,methodID,...) int argoff = $min_args; CODE: { - jvalue * args = makeargs(sig, &ST(argoff), items - argoff); + jvalue * args = makeargs(aTHX_ sig, &ST(argoff), items - argoff); RETVAL = (*env)->CallStaticCharMethodA(env, clazz,methodID,args); RESTOREENV; } @@ -1836,7 +1837,7 @@ CallStaticShortMethod(clazz,methodID,...) int argoff = $min_args; CODE: { - jvalue * args = makeargs(sig, &ST(argoff), items - argoff); + jvalue * args = makeargs(aTHX_ sig, &ST(argoff), items - argoff); RETVAL = (*env)->CallStaticShortMethodA(env, clazz,methodID,args); RESTOREENV; } @@ -1867,7 +1868,7 @@ CallStaticIntMethod(clazz,methodID,...) int argoff = $min_args; CODE: { - jvalue * args = makeargs(sig, &ST(argoff), items - argoff); + jvalue * args = makeargs(aTHX_ sig, &ST(argoff), items - argoff); RETVAL = (*env)->CallStaticIntMethodA(env, clazz,methodID,args); RESTOREENV; } @@ -1898,7 +1899,7 @@ CallStaticLongMethod(clazz,methodID,...) int argoff = $min_args; CODE: { - jvalue * args = makeargs(sig, &ST(argoff), items - argoff); + jvalue * args = makeargs(aTHX_ sig, &ST(argoff), items - argoff); RETVAL = (*env)->CallStaticLongMethodA(env, clazz,methodID,args); RESTOREENV; } @@ -1929,7 +1930,7 @@ CallStaticFloatMethod(clazz,methodID,...) int argoff = $min_args; CODE: { - jvalue * args = makeargs(sig, &ST(argoff), items - argoff); + jvalue * args = makeargs(aTHX_ sig, &ST(argoff), items - argoff); RETVAL = (*env)->CallStaticFloatMethodA(env, clazz,methodID,args); RESTOREENV; } @@ -1960,7 +1961,7 @@ CallStaticDoubleMethod(clazz,methodID,...) int argoff = $min_args; CODE: { - jvalue * args = makeargs(sig, &ST(argoff), items - argoff); + jvalue * args = makeargs(aTHX_ sig, &ST(argoff), items - argoff); RETVAL = (*env)->CallStaticDoubleMethodA(env, clazz,methodID,args); RESTOREENV; } @@ -1991,7 +1992,7 @@ CallStaticVoidMethod(cls,methodID,...) int argoff = $min_args; CODE: { - jvalue * args = makeargs(sig, &ST(argoff), items - argoff); + jvalue * args = makeargs(aTHX_ sig, &ST(argoff), items - argoff); (*env)->CallStaticVoidMethodA(env, cls,methodID,args); RESTOREENV; } @@ -2884,9 +2885,9 @@ SetBooleanArrayRegion(array,start,len,buf) CODE: { if (buf_len_ < len) - croak("string is too short"); + Perl_croak(aTHX_ "string is too short"); else if (buf_len_ > len && PL_dowarn) - warn("string is too long"); + Perl_warn(aTHX_ "string is too long"); (*env)->SetBooleanArrayRegion(env, array,start,len,buf); RESTOREENV; } @@ -2903,9 +2904,9 @@ SetByteArrayRegion(array,start,len,buf) CODE: { if (buf_len_ < len) - croak("string is too short"); + Perl_croak(aTHX_ "string is too short"); else if (buf_len_ > len && PL_dowarn) - warn("string is too long"); + Perl_warn(aTHX_ "string is too long"); (*env)->SetByteArrayRegion(env, array,start,len,buf); RESTOREENV; } @@ -2922,9 +2923,9 @@ SetCharArrayRegion(array,start,len,buf) CODE: { if (buf_len_ < len) - croak("string is too short"); + Perl_croak(aTHX_ "string is too short"); else if (buf_len_ > len && PL_dowarn) - warn("string is too long"); + Perl_warn(aTHX_ "string is too long"); (*env)->SetCharArrayRegion(env, array,start,len,buf); RESTOREENV; } @@ -2941,9 +2942,9 @@ SetShortArrayRegion(array,start,len,buf) CODE: { if (buf_len_ < len) - croak("string is too short"); + Perl_croak(aTHX_ "string is too short"); else if (buf_len_ > len && PL_dowarn) - warn("string is too long"); + Perl_warn(aTHX_ "string is too long"); (*env)->SetShortArrayRegion(env, array,start,len,buf); RESTOREENV; } @@ -2960,9 +2961,9 @@ SetIntArrayRegion(array,start,len,buf) CODE: { if (buf_len_ < len) - croak("string is too short"); + Perl_croak(aTHX_ "string is too short"); else if (buf_len_ > len && PL_dowarn) - warn("string is too long"); + Perl_warn(aTHX_ "string is too long"); (*env)->SetIntArrayRegion(env, array,start,len,buf); RESTOREENV; } @@ -2979,9 +2980,9 @@ SetLongArrayRegion(array,start,len,buf) CODE: { if (buf_len_ < len) - croak("string is too short"); + Perl_croak(aTHX_ "string is too short"); else if (buf_len_ > len && PL_dowarn) - warn("string is too long"); + Perl_warn(aTHX_ "string is too long"); (*env)->SetLongArrayRegion(env, array,start,len,buf); RESTOREENV; } @@ -2998,9 +2999,9 @@ SetFloatArrayRegion(array,start,len,buf) CODE: { if (buf_len_ < len) - croak("string is too short"); + Perl_croak(aTHX_ "string is too short"); else if (buf_len_ > len && PL_dowarn) - warn("string is too long"); + Perl_warn(aTHX_ "string is too long"); (*env)->SetFloatArrayRegion(env, array,start,len,buf); RESTOREENV; } @@ -3017,9 +3018,9 @@ SetDoubleArrayRegion(array,start,len,buf) CODE: { if (buf_len_ < len) - croak("string is too short"); + Perl_croak(aTHX_ "string is too short"); else if (buf_len_ > len && PL_dowarn) - warn("string is too long"); + Perl_warn(aTHX_ "string is too long"); (*env)->SetDoubleArrayRegion(env, array,start,len,buf); RESTOREENV; } @@ -3092,7 +3093,7 @@ GetJavaVM(...) if (!dlopen("libjava.so", RTLD_LAZY|RTLD_GLOBAL)) { if (lib && !dlopen(lib, RTLD_LAZY|RTLD_GLOBAL)) - croak("Can't load libjava.so"); + Perl_croak(aTHX_ "Can't load libjava.so"); } JNI_GetDefaultJavaVMInitArgs(&vm_args); @@ -3127,7 +3128,7 @@ GetJavaVM(...) else if (strEQ(s, "debugPort")) vm_args.debugPort = (jint)SvIV(*++mark); else - croak("unrecognized option: %s", s); + Perl_croak(aTHX_ "unrecognized option: %s", s); } JNI_CreateJavaVM(&RETVAL, &jplcurenv, &vm_args); } diff --git a/jpl/JNI/typemap b/jpl/JNI/typemap index 9bd0691..6b97cf4 100644 --- a/jpl/JNI/typemap +++ b/jpl/JNI/typemap @@ -55,13 +55,13 @@ T_JVALUELIST AV* av = (AV*)SvRV($arg); if (SvTYPE(av) == SVt_PVAV) { I32 maxarg = AvFILL(av) + 1; - $var = makeargs(sig, AvARRAY(av), maxarg); + $var = makeargs(aTHX_ sig, AvARRAY(av), maxarg); } else - croak(\"$var is not an array reference\"); + Perl_croak(aTHX_ \"$var is not an array reference\"); } else - croak(\"$var is not a reference\") + Perl_croak(aTHX_ \"$var is not a reference\") T_JIDSIG { $var = ($type)SvIV($arg); @@ -73,7 +73,7 @@ T_JPTROBJ $var = ($type) tmp; } else - croak(\"$var is not of type ${ntype}\") + Perl_croak(aTHX_ \"$var is not of type ${ntype}\") OUTPUT T_JMEM @@ -152,22 +152,22 @@ T_JPTROBJ # if (sv_isa($arg, \"${ntype}\")) # $var = (SV*)SvRV($arg); # else -# croak(\"$var is not of type ${ntype}\") +# Perl_croak(aTHX_ \"$var is not of type ${ntype}\") # T_AVREF # if (sv_isa($arg, \"${ntype}\")) # $var = (AV*)SvRV($arg); # else -# croak(\"$var is not of type ${ntype}\") +# Perl_croak(aTHX_ \"$var is not of type ${ntype}\") # T_HVREF # if (sv_isa($arg, \"${ntype}\")) # $var = (HV*)SvRV($arg); # else -# croak(\"$var is not of type ${ntype}\") +# Perl_croak(aTHX_ \"$var is not of type ${ntype}\") # T_CVREF # if (sv_isa($arg, \"${ntype}\")) # $var = (CV*)SvRV($arg); # else -# croak(\"$var is not of type ${ntype}\") +# Perl_croak(aTHX_ \"$var is not of type ${ntype}\") # T_SYSRET # $var NOT IMPLEMENTED # T_IV @@ -208,28 +208,28 @@ T_JPTROBJ # $var = ($type) tmp; # } # else -# croak(\"$var is not a reference\") +# Perl_croak(aTHX_ \"$var is not a reference\") # T_REF_IV_REF # if (sv_isa($arg, \"${type}\")) { # IV tmp = SvIV((SV*)SvRV($arg)); # $var = *($type *) tmp; # } # else -# croak(\"$var is not of type ${ntype}\") +# Perl_croak(aTHX_ \"$var is not of type ${ntype}\") # T_REF_IV_PTR # if (sv_isa($arg, \"${type}\")) { # IV tmp = SvIV((SV*)SvRV($arg)); # $var = ($type) tmp; # } # else -# croak(\"$var is not of type ${ntype}\") +# Perl_croak(aTHX_ \"$var is not of type ${ntype}\") # T_PTROBJ # if (sv_derived_from($arg, \"${ntype}\")) { # IV tmp = SvIV((SV*)SvRV($arg)); # $var = ($type) tmp; # } # else -# croak(\"$var is not of type ${ntype}\") +# Perl_croak(aTHX_ \"$var is not of type ${ntype}\") # T_PTRDESC # if (sv_isa($arg, \"${ntype}\")) { # IV tmp = SvIV((SV*)SvRV($arg)); @@ -237,21 +237,21 @@ T_JPTROBJ # $var = ${type}_desc->ptr; # } # else -# croak(\"$var is not of type ${ntype}\") +# Perl_croak(aTHX_ \"$var is not of type ${ntype}\") # T_REFREF # if (SvROK($arg)) { # IV tmp = SvIV((SV*)SvRV($arg)); # $var = *($type) tmp; # } # else -# croak(\"$var is not a reference\") +# Perl_croak(aTHX_ \"$var is not a reference\") # T_REFOBJ # if (sv_isa($arg, \"${ntype}\")) { # IV tmp = SvIV((SV*)SvRV($arg)); # $var = *($type) tmp; # } # else -# croak(\"$var is not of type ${ntype}\") +# Perl_croak(aTHX_ \"$var is not of type ${ntype}\") # T_OPAQUE # $var NOT IMPLEMENTED # T_OPAQUEPTR diff --git a/jpl/PerlInterpreter/PerlInterpreter.c b/jpl/PerlInterpreter/PerlInterpreter.c index ad85ca2..b229d13 100644 --- a/jpl/PerlInterpreter/PerlInterpreter.c +++ b/jpl/PerlInterpreter/PerlInterpreter.c @@ -16,7 +16,7 @@ # endif #endif -static void xs_init (void); +static void xs_init (pTHX); static PerlInterpreter *my_perl; int jpldebug = 0; @@ -46,8 +46,6 @@ Java_PerlInterpreter_init(JNIEnv *env, jobject obj, jstring js) if (PL_curinterp) return; - perl_init_i18nl10n(1); - if (!PL_do_undump) { my_perl = perl_alloc(); if (!my_perl) @@ -64,20 +62,21 @@ Java_PerlInterpreter_init(JNIEnv *env, jobject obj, jstring js) } JNIEXPORT void JNICALL -Java_PerlInterpreter_eval(JNIEnv *env, jobject obj, jstring js) +Java_PerlInterpreter_eval(void *perl, JNIEnv *env, jobject obj, jstring js) { SV* envsv; SV* objsv; dSP; jbyte* jb; + dTHXa(perl); ENTER; SAVETMPS; jplcurenv = env; - envsv = perl_get_sv("JPL::_env_", 1); + envsv = get_sv("JPL::_env_", 1); sv_setiv(envsv, (IV)(void*)env); - objsv = perl_get_sv("JPL::_obj_", 1); + objsv = get_sv("JPL::_obj_", 1); sv_setiv(objsv, (IV)(void*)obj); jb = (jbyte*)(*env)->GetStringUTFChars(env,js,0); @@ -85,7 +84,7 @@ Java_PerlInterpreter_eval(JNIEnv *env, jobject obj, jstring js) if (jpldebug) fprintf(stderr, "eval %s\n", (char*)jb); - perl_eval_pv( (char*)jb, 0 ); + eval_pv( (char*)jb, 0 ); if (SvTRUE(ERRSV)) { jthrowable newExcCls; @@ -106,10 +105,11 @@ Java_PerlInterpreter_eval(JNIEnv *env, jobject obj, jstring js) /* JNIEXPORT jint JNICALL -Java_PerlInterpreter_eval(JNIEnv *env, jobject obj, jint ji) +Java_PerlInterpreter_eval(void *perl, JNIEnv *env, jobject obj, jint ji) { + dTHXa(perl); op = (OP*)(void*)ji; - op = (*op->op_ppaddr)(); + op = (*op->op_ppaddr)(pTHX); return (jint)(void*)op; } */ @@ -117,11 +117,11 @@ Java_PerlInterpreter_eval(JNIEnv *env, jobject obj, jint ji) /* Register any extra external extensions */ /* Do not delete this line--writemain depends on it */ -EXTERN_C void boot_DynaLoader (CV* cv); -EXTERN_C void boot_JNI (CV* cv); +EXTERN_C void boot_DynaLoader (pTHX_ CV* cv); +EXTERN_C void boot_JNI (pTHX_ CV* cv); static void -xs_init() +xs_init(pTHX) { char *file = __FILE__; dXSUB_SYS; diff --git a/jpl/PerlInterpreter/PerlInterpreter.h b/jpl/PerlInterpreter/PerlInterpreter.h index 22fdf52..4927a5f 100644 --- a/jpl/PerlInterpreter/PerlInterpreter.h +++ b/jpl/PerlInterpreter/PerlInterpreter.h @@ -21,7 +21,7 @@ JNIEXPORT void JNICALL Java_PerlInterpreter_init * Signature: (Ljava/lang/String;)V */ JNIEXPORT void JNICALL Java_PerlInterpreter_eval - (JNIEnv *, jobject, jstring); + (void *perl, JNIEnv *, jobject, jstring); #ifdef __cplusplus } diff --git a/os2/OS2/ExtAttr/ExtAttr.xs b/os2/OS2/ExtAttr/ExtAttr.xs index 566b659..a69a01c 100644 --- a/os2/OS2/ExtAttr/ExtAttr.xs +++ b/os2/OS2/ExtAttr/ExtAttr.xs @@ -11,14 +11,14 @@ extern "C" { #include "myea.h" SV * -my_eadvalue(_ead ead, int index) +my_eadvalue(pTHX_ _ead ead, int index) { SV *sv; int size = _ead_value_size(ead, index); void *p; if (size == -1) { - die("Error getting size of EA: %s", strerror(errno)); + Perl_die(aTHX_ "Error getting size of EA: %s", strerror(errno)); } p = _ead_get_value(ead, index); return newSVpv((char*)p, size); @@ -37,6 +37,10 @@ SV * my_eadvalue(ead, index) _ead ead int index + CODE: + RETVAL = my_eadvalue(aTHX_ ead, index); + OUTPUT: + RETVAL int my_eadreplace(ead, index, sv, flag = 0) diff --git a/os2/OS2/PrfDB/PrfDB.xs b/os2/OS2/PrfDB/PrfDB.xs index 2ba836c..e747fcf 100644 --- a/os2/OS2/PrfDB/PrfDB.xs +++ b/os2/OS2/PrfDB/PrfDB.xs @@ -15,7 +15,7 @@ extern "C" { #define Prf_Close(hini) (!CheckWinError(PrfCloseProfile(hini))) SV * -Prf_Get(HINI hini, PSZ app, PSZ key) { +Prf_Get(pTHX_ HINI hini, PSZ app, PSZ key) { ULONG len; BOOL rc; SV *sv; @@ -51,7 +51,7 @@ Prf_GetLength(HINI hini, PSZ app, PSZ key) { : HINI_PROFILE) SV* -Prf_Profiles() +Prf_Profiles(pTHX) { AV *av = newAV(); SV *rv; @@ -70,7 +70,7 @@ Prf_Profiles() } BOOL -Prf_SetUser(SV *sv) +Prf_SetUser(pTHX_ SV *sv) { char user[257]; char system[257]; @@ -101,6 +101,10 @@ Prf_Get(hini, app, key) HINI hini; PSZ app; PSZ key; +CODE: + RETVAL = Prf_Get(aTHX_ hini, app, key); +OUTPUT: + RETVAL int Prf_Set(hini, app, key, s, l = (SvPOK(ST(3)) ? SvCUR(ST(3)): -1)) @@ -122,10 +126,18 @@ Prf_System(key) SV* Prf_Profiles() +CODE: + RETVAL = Prf_Profiles(aTHX); +OUTPUT: + RETVAL BOOL Prf_SetUser(sv) SV *sv +CODE: + RETVAL = Prf_SetUser(aTHX_ sv); +OUTPUT: + RETVAL BOOT: Acquire_hab(); diff --git a/os2/OS2/Process/Process.xs b/os2/OS2/Process/Process.xs index c16d15d..16b494d 100644 --- a/os2/OS2/Process/Process.xs +++ b/os2/OS2/Process/Process.xs @@ -7,18 +7,8 @@ #define INCL_DOSERRORS #include -static int -not_here(s) -char *s; -{ - croak("%s not implemented on this architecture", s); - return -1; -} - static unsigned long -constant(name, arg) -char *name; -int arg; +constant(char *name, int arg) { errno = 0; if (name[0] == 'P' && name[1] == '_') { diff --git a/os2/OS2/REXX/REXX.xs b/os2/OS2/REXX/REXX.xs index 60266f4..9f23714 100644 --- a/os2/OS2/REXX/REXX.xs +++ b/os2/OS2/REXX/REXX.xs @@ -44,7 +44,7 @@ static ULONG PERLCALL(PSZ name, ULONG argc, PRXSTRING argv, PSZ queue, PRXSTRING static long incompartment; static SV* -exec_in_REXX(char *cmd, char * handlerName, RexxFunctionHandler *handler) +exec_in_REXX(pTHX_ char *cmd, char * handlerName, RexxFunctionHandler *handler) { dTHR; HMODULE hRexx, hRexxAPI; @@ -61,7 +61,8 @@ exec_in_REXX(char *cmd, char * handlerName, RexxFunctionHandler *handler) LONG rc; SV *res; - if (incompartment) die ("Attempt to reenter into REXX compartment"); + if (incompartment) + Perl_die(aTHX_ "Attempt to reenter into REXX compartment"); incompartment = 1; if (DosLoadModule(buf, sizeof buf, "REXX", &hRexx) @@ -71,7 +72,7 @@ exec_in_REXX(char *cmd, char * handlerName, RexxFunctionHandler *handler) (PFN *)&pRexxRegisterFunctionExe) || DosQueryProcAddr(hRexxAPI, 0, "RexxDeregisterFunction", (PFN *)&pRexxDeregisterFunction)) { - die("REXX not available\n"); + Perl_die(aTHX_ "REXX not available\n"); } if (handlerName) @@ -97,9 +98,9 @@ exec_in_REXX(char *cmd, char * handlerName, RexxFunctionHandler *handler) if (rc || SvTRUE(GvSV(PL_errgv))) { if (SvTRUE(GvSV(PL_errgv))) { STRLEN n_a; - die ("Error inside perl function called from REXX compartment.\n%s", SvPV(GvSV(PL_errgv), n_a)) ; + Perl_die(aTHX_ "Error inside perl function called from REXX compartment.\n%s", SvPV(GvSV(PL_errgv), n_a)) ; } - die ("REXX compartment returned non-zero status %li", rc); + Perl_die(aTHX_ "REXX compartment returned non-zero status %li", rc); } return res; @@ -113,16 +114,17 @@ PERLSTART(PSZ name, ULONG argc, PRXSTRING argv, PSZ queue, PRXSTRING ret) return PERLCALL(NULL, argc, argv, queue, ret); } -#define in_rexx_compartment() exec_in_REXX("return StartPerl()\r\n", \ +#define in_rexx_compartment() exec_in_REXX(aTHX_ "return StartPerl()\r\n", \ "StartPerl", PERLSTART) #define REXX_call(cv) ( exec_cv = (cv), in_rexx_compartment()) #define REXX_eval_with(cmd,name,cv) ( exec_cv = (cv), \ - exec_in_REXX(cmd,name,PERLSTART)) + exec_in_REXX(aTHX_ cmd,name,PERLSTART)) #define REXX_eval(cmd) REXX_eval_with(cmd,NULL,NULL) static ULONG PERLCALL(PSZ name, ULONG argc, PRXSTRING argv, PSZ queue, PRXSTRING ret) { + dTHX; EXCEPTIONREGISTRATIONRECORD xreg = { NULL, _emx_exception }; int i, rc; unsigned long len; @@ -217,17 +219,7 @@ initialize(void) } static int -not_here(s) -char *s; -{ - croak("%s not implemented on this architecture", s); - return -1; -} - -static int -constant(name, arg) -char *name; -int arg; +constant(char *name, int arg) { errno = EINVAL; return 0; diff --git a/perl.h b/perl.h index b4cbb11..d8a035e 100644 --- a/perl.h +++ b/perl.h @@ -1502,34 +1502,33 @@ typedef pthread_key_t perl_key; #ifdef PERL_IMPLICIT_CONTEXT # ifdef USE_THREADS struct perl_thread; -# define pTHX struct perl_thread *thr -# define pTHX_ pTHX, -# define _pTHX ,pTHX -# define aTHX thr -# define aTHX_ aTHX, -# define _aTHX ,aTHX -# define dTHX pTHX = (struct perl_thread *)SvPVX(PL_thrsv) -# define dTHR dNOOP +# define pTHX struct perl_thread *thr +# define aTHX thr +# define dTHXa(a) pTHX = (struct perl_thread *)a +# define dTHX dTHXa(SvPVX(PL_thrsv)) +# define dTHR dNOOP # else # define MULTIPLICITY -# define pTHX PerlInterpreter *my_perl -# define pTHX_ pTHX, -# define _pTHX ,pTHX -# define aTHX my_perl -# define aTHX_ aTHX, -# define _aTHX ,aTHX -# define dTHX pTHX = PL_curinterp +# define pTHX PerlInterpreter *my_perl +# define aTHX my_perl +# define dTHXa(a) pTHX = (PerlInterpreter *)a +# define dTHX dTHXa(PL_curinterp) # endif +# define pTHX_ pTHX, +# define _pTHX ,pTHX +# define aTHX_ aTHX, +# define _aTHX ,aTHX #endif #ifndef pTHX -# define pTHX void +# define pTHX void # define pTHX_ # define _pTHX # define aTHX # define aTHX_ # define _aTHX -# define dTHX dNOOP +# define dTHXa(a) dNOOP +# define dTHX dNOOP #endif #define WITH_THX(s) STMT_START { dTHX; s; } STMT_END