X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=perl.c;h=9da19e0e758125b76498754b1ddfdcddc92a95e6;hb=99efa25c11975a5bbacdb6c324b19bda9d8b8b89;hp=6776ac949733c9dfd0116c1c231a72325afbf228;hpb=9a34ef1dede5fef4f3211de7a12cc37f4645a3bd;p=p5sagit%2Fp5-mst-13.2.git diff --git a/perl.c b/perl.c index 6776ac9..9da19e0 100644 --- a/perl.c +++ b/perl.c @@ -59,11 +59,25 @@ perl_alloc_using(struct IPerlMem* ipM, struct IPerlMem* ipMS, #ifdef PERL_OBJECT my_perl = (PerlInterpreter*)new(ipM) CPerlObj(ipM, ipMS, ipMP, ipE, ipStd, ipLIO, ipD, ipS, ipP); - PERL_SET_INTERP(my_perl); + if (!PL_curinterp) { + PERL_SET_INTERP(my_perl); +#if defined(USE_THREADS) || defined(USE_ITHREADS) + INIT_THREADS; + ALLOC_THREAD_KEY; +#endif + } + PERL_SET_THX(my_perl); #else /* New() needs interpreter, so call malloc() instead */ my_perl = (PerlInterpreter*)(*ipM->pMalloc)(ipM, sizeof(PerlInterpreter)); - PERL_SET_INTERP(my_perl); + if (!PL_curinterp) { + PERL_SET_INTERP(my_perl); +#if defined(USE_THREADS) || defined(USE_ITHREADS) + INIT_THREADS; + ALLOC_THREAD_KEY; +#endif + } + PERL_SET_THX(my_perl); Zero(my_perl, 1, PerlInterpreter); PL_Mem = ipM; PL_MemShared = ipMS; @@ -95,7 +109,15 @@ perl_alloc(void) /* New() needs interpreter, so call malloc() instead */ my_perl = (PerlInterpreter*)PerlMem_malloc(sizeof(PerlInterpreter)); - PERL_SET_INTERP(my_perl); + + if (!PL_curinterp) { + PERL_SET_INTERP(my_perl); +#if defined(USE_THREADS) || defined(USE_ITHREADS) + INIT_THREADS; + ALLOC_THREAD_KEY; +#endif + } + PERL_SET_THX(my_perl); Zero(my_perl, 1, PerlInterpreter); return my_perl; } @@ -118,7 +140,7 @@ perl_construct(pTHXx) struct perl_thread *thr = NULL; #endif /* FAKE_THREADS */ #endif /* USE_THREADS */ - + #ifdef MULTIPLICITY init_interp(); PL_perl_destruct_level = 1; @@ -129,14 +151,7 @@ perl_construct(pTHXx) /* Init the real globals (and main thread)? */ if (!PL_linestr) { - INIT_THREADS; #ifdef USE_THREADS -#ifdef ALLOC_THREAD_KEY - ALLOC_THREAD_KEY; -#else - if (pthread_key_create(&PL_thr_key, 0)) - Perl_croak(aTHX_ "panic: pthread_key_create"); -#endif MUTEX_INIT(&PL_sv_mutex); /* * Safe to use basic SV functions from now on (though @@ -146,16 +161,18 @@ perl_construct(pTHXx) COND_INIT(&PL_eval_cond); MUTEX_INIT(&PL_threads_mutex); COND_INIT(&PL_nthreads_cond); -#ifdef EMULATE_ATOMIC_REFCOUNTS +# ifdef EMULATE_ATOMIC_REFCOUNTS MUTEX_INIT(&PL_svref_mutex); -#endif /* EMULATE_ATOMIC_REFCOUNTS */ +# endif /* EMULATE_ATOMIC_REFCOUNTS */ MUTEX_INIT(&PL_cred_mutex); thr = init_main_thread(); #endif /* USE_THREADS */ +#ifdef PERL_FLEXIBLE_EXCEPTIONS PL_protect = MEMBER_TO_FPTR(Perl_default_protect); /* for exceptions */ +#endif PL_curcop = &PL_compiling; /* needed by ckWARN, right away */ @@ -218,7 +235,7 @@ perl_construct(pTHXx) PL_patchlevel = NEWSV(0,4); SvUPGRADE(PL_patchlevel, SVt_PVNV); if (PERL_REVISION > 127 || PERL_VERSION > 127 || PERL_SUBVERSION > 127) - SvGROW(PL_patchlevel,24); + SvGROW(PL_patchlevel, UTF8_MAXLEN*3+1); s = (U8*)SvPVX(PL_patchlevel); s = uv_to_utf8(s, (UV)PERL_REVISION); s = uv_to_utf8(s, (UV)PERL_VERSION); @@ -800,13 +817,20 @@ setuid perl scripts securely.\n"); oldscope = PL_scopestack_ix; PL_dowarn = G_WARN_OFF; - CALLPROTECT(aTHX_ pcur_env, &ret, MEMBER_TO_FPTR(S_parse_body), - env, xsinit); +#ifdef PERL_FLEXIBLE_EXCEPTIONS + CALLPROTECT(aTHX_ pcur_env, &ret, MEMBER_TO_FPTR(S_vparse_body), env, xsinit); +#else + JMPENV_PUSH(ret); +#endif switch (ret) { case 0: +#ifndef PERL_FLEXIBLE_EXCEPTIONS + parse_body(env,xsinit); +#endif if (PL_checkav) call_list(oldscope, PL_checkav); - return 0; + ret = 0; + break; case 1: STATUS_ALL_FAILURE; /* FALL THROUGH */ @@ -818,21 +842,34 @@ setuid perl scripts securely.\n"); PL_curstash = PL_defstash; if (PL_checkav) call_list(oldscope, PL_checkav); - return STATUS_NATIVE_EXPORT; + ret = STATUS_NATIVE_EXPORT; + break; case 3: PerlIO_printf(Perl_error_log, "panic: top_env\n"); - return 1; + ret = 1; + break; } - return 0; + JMPENV_POP; + return ret; } +#ifdef PERL_FLEXIBLE_EXCEPTIONS STATIC void * -S_parse_body(pTHX_ va_list args) +S_vparse_body(pTHX_ va_list args) +{ + char **env = va_arg(args, char**); + XSINIT_t xsinit = va_arg(args, XSINIT_t); + + return parse_body(env, xsinit); +} +#endif + +STATIC void * +S_parse_body(pTHX_ char **env, XSINIT_t xsinit) { dTHR; int argc = PL_origargc; char **argv = PL_origargv; - char **env = va_arg(args, char**); char *scriptname = NULL; int fdscript = -1; VOL bool dosearch = FALSE; @@ -842,8 +879,6 @@ S_parse_body(pTHX_ va_list args) register char *s; char *cddir = Nullch; - XSINIT_t xsinit = va_arg(args, XSINIT_t); - sv_setpvn(PL_linestr,"",0); sv = newSVpvn("",0); /* first used for -I flags */ SAVEFREESV(sv); @@ -965,8 +1000,11 @@ S_parse_body(pTHX_ va_list args) # ifdef USE_ITHREADS sv_catpv(PL_Sv," USE_ITHREADS"); # endif -# ifdef USE_64_BITS - sv_catpv(PL_Sv," USE_64_BITS"); +# ifdef USE_64_BIT_INT + sv_catpv(PL_Sv," USE_64_BIT_INT"); +# endif +# ifdef USE_64_BIT_ALL + sv_catpv(PL_Sv," USE_64_BIT_ALL"); # endif # ifdef USE_LONG_DOUBLE sv_catpv(PL_Sv," USE_LONG_DOUBLE"); @@ -1154,7 +1192,7 @@ print \" \\@INC:\\n @INC\\n\";"); if (xsinit) (*xsinit)(aTHXo); /* in case linked C routines want magical variables */ -#if defined(VMS) || defined(WIN32) || defined(DJGPP) +#if defined(VMS) || defined(WIN32) || defined(DJGPP) || defined(__CYGWIN__) init_os_extras(); #endif @@ -1230,7 +1268,7 @@ perl_run(pTHXx) { dTHR; I32 oldscope; - int ret; + int ret = 0; dJMPENV; #ifdef USE_THREADS dTHX; @@ -1238,14 +1276,23 @@ perl_run(pTHXx) oldscope = PL_scopestack_ix; +#ifdef PERL_FLEXIBLE_EXCEPTIONS redo_body: - CALLPROTECT(aTHX_ pcur_env, &ret, MEMBER_TO_FPTR(S_run_body), oldscope); + CALLPROTECT(aTHX_ pcur_env, &ret, MEMBER_TO_FPTR(S_vrun_body), oldscope); +#else + JMPENV_PUSH(ret); +#endif switch (ret) { case 1: cxstack_ix = -1; /* start context stack again */ goto redo_body; - case 0: /* normal completion */ - case 2: /* my_exit() */ + case 0: /* normal completion */ +#ifndef PERL_FLEXIBLE_EXCEPTIONS + redo_body: + run_body(oldscope); +#endif + /* FALL THROUGH */ + case 2: /* my_exit() */ while (PL_scopestack_ix > oldscope) LEAVE; FREETMPS; @@ -1256,7 +1303,8 @@ perl_run(pTHXx) if (PerlEnv_getenv("PERL_DEBUG_MSTATS")) dump_mstats("after execution: "); #endif - return STATUS_NATIVE_EXPORT; + ret = STATUS_NATIVE_EXPORT; + break; case 3: if (PL_restartop) { POPSTACK_TO(PL_mainstack); @@ -1264,19 +1312,30 @@ perl_run(pTHXx) } PerlIO_printf(Perl_error_log, "panic: restartop\n"); FREETMPS; - return 1; + ret = 1; + break; } - /* NOTREACHED */ - return 0; + JMPENV_POP; + return ret; } +#ifdef PERL_FLEXIBLE_EXCEPTIONS STATIC void * -S_run_body(pTHX_ va_list args) +S_vrun_body(pTHX_ va_list args) { - dTHR; I32 oldscope = va_arg(args, I32); + return run_body(oldscope); +} +#endif + + +STATIC void * +S_run_body(pTHX_ I32 oldscope) +{ + dTHR; + DEBUG_r(PerlIO_printf(Perl_debug_log, "%s $` $& $' support.\n", PL_sawampersand ? "Enabling" : "Omitting")); @@ -1543,7 +1602,7 @@ Perl_call_sv(pTHX_ SV *sv, I32 flags) if (!(flags & G_EVAL)) { CATCH_SET(TRUE); - call_xbody((OP*)&myop, FALSE); + call_body((OP*)&myop, FALSE); retval = PL_stack_sp - (PL_stack_base + oldmark); CATCH_SET(oldcatch); } @@ -1571,11 +1630,19 @@ Perl_call_sv(pTHX_ SV *sv, I32 flags) } PL_markstack_ptr++; - redo_body: - CALLPROTECT(aTHX_ pcur_env, &ret, MEMBER_TO_FPTR(S_call_body), +#ifdef PERL_FLEXIBLE_EXCEPTIONS + redo_body: + CALLPROTECT(aTHX_ pcur_env, &ret, MEMBER_TO_FPTR(S_vcall_body), (OP*)&myop, FALSE); +#else + JMPENV_PUSH(ret); +#endif switch (ret) { case 0: +#ifndef PERL_FLEXIBLE_EXCEPTIONS + redo_body: + call_body((OP*)&myop, FALSE); +#endif retval = PL_stack_sp - (PL_stack_base + oldmark); if (!(flags & G_KEEPERR)) sv_setpv(ERRSV,""); @@ -1587,6 +1654,7 @@ Perl_call_sv(pTHX_ SV *sv, I32 flags) /* my_exit() was called */ PL_curstash = PL_defstash; FREETMPS; + JMPENV_POP; if (PL_statusvalue && !(PL_exit_flags & PERL_EXIT_EXPECTED)) Perl_croak(aTHX_ "Callback called exit"); my_exit_jump(); @@ -1620,6 +1688,7 @@ Perl_call_sv(pTHX_ SV *sv, I32 flags) PL_curpm = newpm; LEAVE; } + JMPENV_POP; } if (flags & G_DISCARD) { @@ -1632,18 +1701,20 @@ Perl_call_sv(pTHX_ SV *sv, I32 flags) return retval; } +#ifdef PERL_FLEXIBLE_EXCEPTIONS STATIC void * -S_call_body(pTHX_ va_list args) +S_vcall_body(pTHX_ va_list args) { OP *myop = va_arg(args, OP*); int is_eval = va_arg(args, int); - call_xbody(myop, is_eval); + call_body(myop, is_eval); return NULL; } +#endif STATIC void -S_call_xbody(pTHX_ OP *myop, int is_eval) +S_call_body(pTHX_ OP *myop, int is_eval) { dTHR; @@ -1703,11 +1774,19 @@ Perl_eval_sv(pTHX_ SV *sv, I32 flags) if (flags & G_KEEPERR) myop.op_flags |= OPf_SPECIAL; +#ifdef PERL_FLEXIBLE_EXCEPTIONS redo_body: - CALLPROTECT(aTHX_ pcur_env, &ret, MEMBER_TO_FPTR(S_call_body), + CALLPROTECT(aTHX_ pcur_env, &ret, MEMBER_TO_FPTR(S_vcall_body), (OP*)&myop, TRUE); +#else + JMPENV_PUSH(ret); +#endif switch (ret) { case 0: +#ifndef PERL_FLEXIBLE_EXCEPTIONS + redo_body: + call_body((OP*)&myop,TRUE); +#endif retval = PL_stack_sp - (PL_stack_base + oldmark); if (!(flags & G_KEEPERR)) sv_setpv(ERRSV,""); @@ -1719,6 +1798,7 @@ Perl_eval_sv(pTHX_ SV *sv, I32 flags) /* my_exit() was called */ PL_curstash = PL_defstash; FREETMPS; + JMPENV_POP; if (PL_statusvalue && !(PL_exit_flags & PERL_EXIT_EXPECTED)) Perl_croak(aTHX_ "Callback called exit"); my_exit_jump(); @@ -1739,6 +1819,7 @@ Perl_eval_sv(pTHX_ SV *sv, I32 flags) break; } + JMPENV_POP; if (flags & G_DISCARD) { PL_stack_sp = PL_stack_base + oldmark; retval = 0; @@ -1844,6 +1925,8 @@ S_usage(pTHX_ char *name) /* XXX move this out into a module ? */ "-v print version, subversion (includes VERY IMPORTANT perl info)", "-V[:variable] print configuration summary (or a single Config.pm variable)", "-w enable many useful warnings (RECOMMENDED)", +"-W enable all warnings", +"-X disable all warnings", "-x[directory] strip off text before #!perl line and perhaps cd to directory", "\n", NULL @@ -2059,7 +2142,7 @@ Perl_moreswitches(pTHX_ char *s) s++; return s; case 'v': - printf(Perl_form(aTHX_ "\nThis is perl, v%v built for %s", + printf(Perl_form(aTHX_ "\nThis is perl, v%vd built for %s", PL_patchlevel, ARCHNAME)); #if defined(LOCAL_PATCH_COUNT) if (LOCAL_PATCH_COUNT > 0) @@ -2103,6 +2186,9 @@ Perl_moreswitches(pTHX_ char *s) #ifdef __MINT__ printf("MiNT port by Guido Flohr, 1997-1999\n"); #endif +#ifdef EPOC + printf("EPOC port by Olaf Flebbe, 1999-2000\n"); +#endif #ifdef BINARY_BUILD_NOTICE BINARY_BUILD_NOTICE; #endif @@ -2471,7 +2557,7 @@ sed %s -e \"/^[^#]/b\" \ /* Mention * I_SYSSTATVFS HAS_FSTATVFS * I_SYSMOUNT - * I_STATFS HAS_FSTATFS + * I_STATFS HAS_FSTATFS HAS_GETFSSTAT * I_MNTENT HAS_GETMNTENT HAS_HASMNTOPT * here so that metaconfig picks them up. */ @@ -3373,9 +3459,16 @@ Perl_call_list(pTHX_ I32 oldscope, AV *paramList) while (AvFILL(paramList) >= 0) { cv = (CV*)av_shift(paramList); SAVEFREESV(cv); - CALLPROTECT(aTHX_ pcur_env, &ret, MEMBER_TO_FPTR(S_call_list_body), cv); +#ifdef PERL_FLEXIBLE_EXCEPTIONS + CALLPROTECT(aTHX_ pcur_env, &ret, MEMBER_TO_FPTR(S_vcall_list_body), cv); +#else + JMPENV_PUSH(ret); +#endif switch (ret) { case 0: +#ifndef PERL_FLEXIBLE_EXCEPTIONS + call_list_body(cv); +#endif atsv = ERRSV; (void)SvPV(atsv, len); if (len) { @@ -3392,6 +3485,7 @@ Perl_call_list(pTHX_ I32 oldscope, AV *paramList) : "END"); while (PL_scopestack_ix > oldscope) LEAVE; + JMPENV_POP; Perl_croak(aTHX_ "%s", SvPVx(atsv, n_a)); } break; @@ -3406,6 +3500,7 @@ Perl_call_list(pTHX_ I32 oldscope, AV *paramList) PL_curstash = PL_defstash; PL_curcop = &PL_compiling; CopLINE_set(PL_curcop, oldline); + JMPENV_POP; if (PL_statusvalue && !(PL_exit_flags & PERL_EXIT_EXPECTED)) { if (paramList == PL_beginav) Perl_croak(aTHX_ "BEGIN failed--compilation aborted"); @@ -3427,15 +3522,22 @@ Perl_call_list(pTHX_ I32 oldscope, AV *paramList) FREETMPS; break; } + JMPENV_POP; } } +#ifdef PERL_FLEXIBLE_EXCEPTIONS STATIC void * -S_call_list_body(pTHX_ va_list args) +S_vcall_list_body(pTHX_ va_list args) { - dTHR; CV *cv = va_arg(args, CV*); + return call_list_body(cv); +} +#endif +STATIC void * +S_call_list_body(pTHX_ CV *cv) +{ PUSHMARK(PL_stack_sp); call_sv((SV*)cv, G_EVAL|G_DISCARD); return NULL;