Patch for Perlbug #4253

[p5sagit/p5-mst-13.2.git] / perl.c

diff --git a/perl.c b/perl.c
index b4b2aad..aad80ed 100644 (file)
--- a/perl.c
+++ b/perl.c
@@ -123,7 +123,7 @@ static I32 read_e_script(pTHX_ int idx, SV *buf_sv, int maxlen);
 #endif
 
 static void
-S_init_tls_and_interp(pTHX)
+S_init_tls_and_interp(PerlInterpreter *my_perl)
 {
     if (!PL_curinterp) {                       
        PERL_SET_INTERP(my_perl);
@@ -181,9 +181,6 @@ PerlInterpreter *
 perl_alloc(void)
 {
     PerlInterpreter *my_perl;
-#ifdef USE_5005THREADS
-    dTHX;
-#endif
 
     /* New() needs interpreter, so call malloc() instead */
     my_perl = (PerlInterpreter*)PerlMem_malloc(sizeof(PerlInterpreter));
@@ -213,10 +210,6 @@ perl_construct(pTHXx)
 #endif
    /* Init the real globals (and main thread)? */
     if (!PL_linestr) {
-#ifdef PERL_FLEXIBLE_EXCEPTIONS
-       PL_protect = MEMBER_TO_FPTR(Perl_default_protect); /* for exceptions */
-#endif
-
        PL_curcop = &PL_compiling;      /* needed by ckWARN, right away */
 
        PL_linestr = NEWSV(65,79);
@@ -357,9 +350,6 @@ perl_destruct(pTHXx)
 {
     volatile int destruct_level;  /* 0=none, 1=full, 2=full with checks */
     HV *hv;
-#ifdef USE_5005THREADS
-    dTHX;
-#endif /* USE_5005THREADS */
 
     /* wait for all pseudo-forked children to finish */
     PERL_WAIT_FOR_CHILDREN;
@@ -951,6 +941,31 @@ perl_free(pTHXx)
 #endif
 }
 
+#if defined(USE_5005THREADS) || defined(USE_ITHREADS)
+/* provide destructors to clean up the thread key when libperl is unloaded */
+#ifndef WIN32 /* handled during DLL_PROCESS_DETACH in win32/perllib.c */
+
+#if defined(__hpux) && !defined(__GNUC__)
+#pragma fini "perl_fini"
+#endif
+
+#if defined(__GNUC__) && defined(__attribute__) 
+/* want to make sure __attribute__ works here even
+ * for -Dd_attribut=undef builds.
+ */
+#undef __attribute__
+#endif
+
+static void __attribute__((destructor))
+perl_fini()
+{
+    if (PL_curinterp)
+       FREE_THREAD_KEY;
+}
+
+#endif /* WIN32 */
+#endif /* THREADS */
+
 void
 Perl_call_atexit(pTHX_ ATEXIT_t fn, void *ptr)
 {
@@ -1025,9 +1040,6 @@ perl_parse(pTHXx_ XSINIT_t xsinit, int argc, char **argv, char **env)
     I32 oldscope;
     int ret;
     dJMPENV;
-#ifdef USE_5005THREADS
-    dTHX;
-#endif
 
 #ifdef SETUID_SCRIPTS_ARE_SECURE_NOW
 #ifdef IAMSUID
@@ -1176,16 +1188,10 @@ setuid perl scripts securely.\n");
     oldscope = PL_scopestack_ix;
     PL_dowarn = G_WARN_OFF;
 
-#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);
        ret = 0;
@@ -1212,17 +1218,6 @@ setuid perl scripts securely.\n");
     return ret;
 }
 
-#ifdef PERL_FLEXIBLE_EXCEPTIONS
-STATIC void *
-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)
 {
@@ -1739,30 +1734,20 @@ perl_run(pTHXx)
     I32 oldscope;
     int ret = 0;
     dJMPENV;
-#ifdef USE_5005THREADS
-    dTHX;
-#endif
 
     oldscope = PL_scopestack_ix;
 #ifdef VMS
     VMSISH_HUSHED = 0;
 #endif
 
-#ifdef PERL_FLEXIBLE_EXCEPTIONS
- redo_body:
-    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 */
-#ifndef PERL_FLEXIBLE_EXCEPTIONS
  redo_body:
        run_body(oldscope);
-#endif
        /* FALL THROUGH */
     case 2:                            /* my_exit() */
        while (PL_scopestack_ix > oldscope)
@@ -1793,16 +1778,6 @@ perl_run(pTHXx)
     return ret;
 }
 
-#ifdef PERL_FLEXIBLE_EXCEPTIONS
-STATIC void *
-S_vrun_body(pTHX_ va_list args)
-{
-    I32 oldscope = va_arg(args, I32);
-
-    return run_body(oldscope);
-}
-#endif
-
 
 STATIC void *
 S_run_body(pTHX_ I32 oldscope)
@@ -2113,19 +2088,11 @@ Perl_call_sv(pTHX_ SV *sv, I32 flags)
        }
        PL_markstack_ptr++;
 
-#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,"");
@@ -2183,18 +2150,6 @@ Perl_call_sv(pTHX_ SV *sv, I32 flags)
     return retval;
 }
 
-#ifdef PERL_FLEXIBLE_EXCEPTIONS
-STATIC void *
-S_vcall_body(pTHX_ va_list args)
-{
-    OP *myop = va_arg(args, OP*);
-    int is_eval = va_arg(args, int);
-
-    call_body(myop, is_eval);
-    return NULL;
-}
-#endif
-
 STATIC void
 S_call_body(pTHX_ OP *myop, int is_eval)
 {
@@ -2254,23 +2209,15 @@ 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_vcall_body),
-               (OP*)&myop, TRUE);
-#else
     /* fail now; otherwise we could fail after the JMPENV_PUSH but
      * before a PUSHEVAL, which corrupts the stack after a croak */
     TAINT_PROPER("eval_sv()");
 
     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,"");
@@ -2773,13 +2720,13 @@ Perl_moreswitches(pTHX_ char *s)
                (void *)upg_version(PL_patchlevel);
 #if !defined(DGUX)
        PerlIO_printf(PerlIO_stdout(),
-               Perl_form(aTHX_ "\nThis is perl, v%_ built for %s",
+               Perl_form(aTHX_ "\nThis is perl, v%"SVf" built for %s",
                    vstringify(PL_patchlevel),
                    ARCHNAME));
 #else /* DGUX */
 /* Adjust verbose output as in the perl that ships with the DG/UX OS from EMC */
        PerlIO_printf(PerlIO_stdout(),
-               Perl_form(aTHX_ "\nThis is perl, v%_\n",
+               Perl_form(aTHX_ "\nThis is perl, v%"SVf"\n",
                    vstringify(PL_patchlevel)));
        PerlIO_printf(PerlIO_stdout(),
                        Perl_form(aTHX_ "        built under %s at %s %s\n",
@@ -3005,7 +2952,7 @@ S_init_main_stash(pTHX)
     SvREFCNT_dec(GvHV(gv));
     GvHV(gv) = (HV*)SvREFCNT_inc(PL_defstash);
     SvREADONLY_on(gv);
-    HvNAME(PL_defstash) = savepv("main");
+    HvNAME(PL_defstash) = savepvn("main", 4);
     PL_incgv = gv_HVadd(gv_AVadd(gv_fetchpv("INC",TRUE, SVt_PVAV)));
     GvMULTI_on(PL_incgv);
     PL_hintgv = gv_fetchpv("\010",TRUE, SVt_PV); /* ^H */
@@ -3041,7 +2988,7 @@ S_open_script(pTHX_ char *scriptname, bool dosearch, SV *sv)
     PL_suidscript = -1;
 
     if (PL_e_script) {
-       PL_origfilename = savepv("-e");
+       PL_origfilename = savepvn("-e", 2);
     }
     else {
        /* if find_script() returns, it returns a malloc()-ed value */
@@ -4632,16 +4579,10 @@ Perl_call_list(pTHX_ I32 oldscope, AV *paramList)
        } else {
            SAVEFREESV(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) {
@@ -4698,15 +4639,6 @@ Perl_call_list(pTHX_ I32 oldscope, AV *paramList)
     }
 }
 
-#ifdef PERL_FLEXIBLE_EXCEPTIONS
-STATIC void *
-S_vcall_list_body(pTHX_ va_list args)
-{
-    CV *cv = va_arg(args, CV*);
-    return call_list_body(cv);
-}
-#endif
-
 STATIC void *
 S_call_list_body(pTHX_ CV *cv)
 {