use libdbm.nfs.a if available (libdbm.a is missing dbmclose())

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

diff --git a/perl.c b/perl.c
index 3c12ee7..74884b2 100644 (file)
--- a/perl.c
+++ b/perl.c
@@ -14,6 +14,7 @@
 #include "EXTERN.h"
 #define PERL_IN_PERL_C
 #include "perl.h"
+#include "patchlevel.h"                        /* for local_patches */
 
 /* XXX If this causes problems, set i_unistd=undef in the hint file.  */
 #ifdef I_UNISTD
@@ -61,7 +62,8 @@ perl_alloc(void)
 {
     PerlInterpreter *my_perl;
 
-    New(53, my_perl, 1, PerlInterpreter);
+    /* New() needs interpreter, so call malloc() instead */
+    my_perl = (PerlInterpreter*)PerlMem_malloc(sizeof(PerlInterpreter));
     PERL_SET_INTERP(my_perl);
     return my_perl;
 }
@@ -73,7 +75,7 @@ perl_construct(pTHXx)
 #ifdef USE_THREADS
     int i;
 #ifndef FAKE_THREADS
-    struct perl_thread *thr;
+    struct perl_thread *thr = NULL;
 #endif /* FAKE_THREADS */
 #endif /* USE_THREADS */
     
@@ -81,6 +83,14 @@ perl_construct(pTHXx)
     Zero(my_perl, 1, PerlInterpreter);
 #endif
 
+#ifdef MULTIPLICITY
+    init_interp();
+    PL_perl_destruct_level = 1; 
+#else
+   if (PL_perl_destruct_level > 0)
+       init_interp();
+#endif
+
    /* Init the real globals (and main thread)? */
     if (!PL_linestr) {
 #ifdef USE_THREADS
@@ -158,13 +168,6 @@ perl_construct(pTHXx)
     PL_rs = SvREFCNT_inc(PL_nrs);
 
     init_stacks();
-#ifdef MULTIPLICITY
-    init_interp();
-    PL_perl_destruct_level = 1; 
-#else
-   if (PL_perl_destruct_level > 0)
-       init_interp();
-#endif
 
     init_ids();
     PL_lex_state = LEX_NOTPARSING;
@@ -217,7 +220,7 @@ perl_destruct(pTHXx)
     /* Pass 1 on any remaining threads: detach joinables, join zombies */
   retry_cleanup:
     MUTEX_LOCK(&PL_threads_mutex);
-    DEBUG_S(PerlIO_printf(PerlIO_stderr(),
+    DEBUG_S(PerlIO_printf(Perl_debug_log,
                          "perl_destruct: waiting for %d threads...\n",
                          PL_nthreads - 1));
     for (t = thr->next; t != thr; t = t->next) {
@@ -225,7 +228,7 @@ perl_destruct(pTHXx)
        switch (ThrSTATE(t)) {
            AV *av;
        case THRf_ZOMBIE:
-           DEBUG_S(PerlIO_printf(PerlIO_stderr(),
+           DEBUG_S(PerlIO_printf(Perl_debug_log,
                                  "perl_destruct: joining zombie %p\n", t));
            ThrSETSTATE(t, THRf_DEAD);
            MUTEX_UNLOCK(&t->mutex);
@@ -239,11 +242,11 @@ perl_destruct(pTHXx)
            MUTEX_UNLOCK(&PL_threads_mutex);
            JOIN(t, &av);
            SvREFCNT_dec((SV*)av);
-           DEBUG_S(PerlIO_printf(PerlIO_stderr(),
+           DEBUG_S(PerlIO_printf(Perl_debug_log,
                                  "perl_destruct: joined zombie %p OK\n", t));
            goto retry_cleanup;
        case THRf_R_JOINABLE:
-           DEBUG_S(PerlIO_printf(PerlIO_stderr(),
+           DEBUG_S(PerlIO_printf(Perl_debug_log,
                                  "perl_destruct: detaching thread %p\n", t));
            ThrSETSTATE(t, THRf_R_DETACHED);
            /* 
@@ -257,7 +260,7 @@ perl_destruct(pTHXx)
            MUTEX_UNLOCK(&t->mutex);
            goto retry_cleanup;
        default:
-           DEBUG_S(PerlIO_printf(PerlIO_stderr(),
+           DEBUG_S(PerlIO_printf(Perl_debug_log,
                                  "perl_destruct: ignoring %p (state %u)\n",
                                  t, ThrSTATE(t)));
            MUTEX_UNLOCK(&t->mutex);
@@ -269,14 +272,14 @@ perl_destruct(pTHXx)
     /* Pass 2 on remaining threads: wait for the thread count to drop to one */
     while (PL_nthreads > 1)
     {
-       DEBUG_S(PerlIO_printf(PerlIO_stderr(),
+       DEBUG_S(PerlIO_printf(Perl_debug_log,
                              "perl_destruct: final wait for %d threads\n",
                              PL_nthreads - 1));
        COND_WAIT(&PL_nthreads_cond, &PL_threads_mutex);
     }
     /* At this point, we're the last thread */
     MUTEX_UNLOCK(&PL_threads_mutex);
-    DEBUG_S(PerlIO_printf(PerlIO_stderr(), "perl_destruct: armageddon has arrived\n"));
+    DEBUG_S(PerlIO_printf(Perl_debug_log, "perl_destruct: armageddon has arrived\n"));
     MUTEX_DESTROY(&PL_threads_mutex);
     COND_DESTROY(&PL_nthreads_cond);
 #endif /* !defined(FAKE_THREADS) */
@@ -325,8 +328,6 @@ perl_destruct(pTHXx)
     PL_warnhook = Nullsv;
     SvREFCNT_dec(PL_diehook);
     PL_diehook = Nullsv;
-    SvREFCNT_dec(PL_parsehook);
-    PL_parsehook = Nullsv;
 
     /* call exit list functions */
     while (PL_exitlistlen-- > 0)
@@ -406,6 +407,11 @@ perl_destruct(pTHXx)
     Safefree(PL_screamnext);
     PL_screamnext  = 0;
 
+    /* float buffer */
+    Safefree(PL_efloatbuf);
+    PL_efloatbuf = Nullch;
+    PL_efloatsize = 0;
+
     /* startup and shutdown function lists */
     SvREFCNT_dec(PL_beginav);
     SvREFCNT_dec(PL_endav);
@@ -423,6 +429,7 @@ perl_destruct(pTHXx)
     PL_argvgv = Nullgv;
     PL_argvoutgv = Nullgv;
     PL_stdingv = Nullgv;
+    PL_stderrgv = Nullgv;
     PL_last_in_gv = Nullgv;
     PL_replgv = Nullgv;
 
@@ -435,6 +442,10 @@ perl_destruct(pTHXx)
     PL_defstash = 0;
     SvREFCNT_dec(hv);
 
+    /* clear queued errors */
+    SvREFCNT_dec(PL_errors);
+    PL_errors = Nullsv;
+
     FREETMPS;
     if (destruct_level >= 2 && ckWARN_d(WARN_INTERNAL)) {
        if (PL_scopestack_ix != 0)
@@ -558,9 +569,9 @@ void
 perl_free(pTHXx)
 {
 #if defined(PERL_OBJECT)
-    Safefree(this);
+    PerlMem_free(this);
 #else
-    Safefree(aTHXx);
+    PerlMem_free(aTHXx);
 #endif
 }
 
@@ -640,11 +651,11 @@ setuid perl scripts securely.\n");
            LEAVE;
        FREETMPS;
        PL_curstash = PL_defstash;
-       if (PL_endav)
+       if (PL_endav && !PL_minus_c)
            call_list(oldscope, PL_endav);
        return STATUS_NATIVE_EXPORT;
     case 3:
-       PerlIO_printf(PerlIO_stderr(), "panic: top_env\n");
+       PerlIO_printf(Perl_error_log, "panic: top_env\n");
        return 1;
     }
     return 0;
@@ -924,6 +935,7 @@ print \"  \\@INC:\\n    @INC\\n\";");
     CvPADLIST(PL_compcv) = comppadlist;
 
     boot_core_UNIVERSAL();
+    boot_core_xsutils();
 
     if (xsinit)
        (*xsinit)(aTHXo);       /* in case linked C routines want magical variables */
@@ -1011,7 +1023,7 @@ perl_run(pTHXx)
            LEAVE;
        FREETMPS;
        PL_curstash = PL_defstash;
-       if (PL_endav)
+       if (PL_endav && !PL_minus_c)
            call_list(oldscope, PL_endav);
 #ifdef MYMALLOC
        if (PerlEnv_getenv("PERL_DEBUG_MSTATS"))
@@ -1023,7 +1035,7 @@ perl_run(pTHXx)
            POPSTACK_TO(PL_mainstack);
            goto redo_body;
        }
-       PerlIO_printf(PerlIO_stderr(), "panic: restartop\n");
+       PerlIO_printf(Perl_error_log, "panic: restartop\n");
        FREETMPS;
        return 1;
     }
@@ -1048,7 +1060,7 @@ S_run_body(pTHX_ va_list args)
                              (unsigned long) thr));
 
        if (PL_minus_c) {
-           PerlIO_printf(PerlIO_stderr(), "%s syntax OK\n", PL_origfilename);
+           PerlIO_printf(Perl_error_log, "%s syntax OK\n", PL_origfilename);
            my_exit(0);
        }
        if (PERLDB_SINGLE && PL_DBsingle)
@@ -1885,8 +1897,13 @@ S_init_interp(pTHX)
 #    define PERLVAR(var,type)
 #    define PERLVARA(var,n,type)
 #    if defined(PERL_IMPLICIT_CONTEXT)
-#      define PERLVARI(var,type,init)  my_perl->var = init;
-#      define PERLVARIC(var,type,init) my_perl->var = init;
+#      if defined(USE_THREADS)
+#        define PERLVARI(var,type,init)                PERL_GET_INTERP->var = init;
+#        define PERLVARIC(var,type,init)       PERL_GET_INTERP->var = init;
+#      else /* !USE_THREADS */
+#        define PERLVARI(var,type,init)                aTHX->var = init;
+#        define PERLVARIC(var,type,init)       aTHX->var = init;
+#      endif /* USE_THREADS */
 #    else
 #      define PERLVARI(var,type,init)  PERL_GET_INTERP->var = init;
 #      define PERLVARIC(var,type,init) PERL_GET_INTERP->var = init;
@@ -2620,9 +2637,9 @@ S_init_predump_symbols(pTHX)
     GvMULTI_on(tmpgv);
     GvIOp(tmpgv) = (IO*)SvREFCNT_inc(io);
 
-    othergv = gv_fetchpv("STDERR",TRUE, SVt_PVIO);
-    GvMULTI_on(othergv);
-    io = GvIOp(othergv);
+    PL_stderrgv = gv_fetchpv("STDERR",TRUE, SVt_PVIO);
+    GvMULTI_on(PL_stderrgv);
+    io = GvIOp(PL_stderrgv);
     IoOFP(io) = IoIFP(io) = PerlIO_stderr();
     tmpgv = gv_fetchpv("stderr",TRUE, SVt_PV);
     GvMULTI_on(tmpgv);
@@ -2861,7 +2878,7 @@ S_incpush(pTHX_ char *p, int addsubdirs)
                sv_usepvn(libdir,unix,len);
            }
            else
-               PerlIO_printf(PerlIO_stderr(),
+               PerlIO_printf(Perl_error_log,
                              "Failed to unixify @INC element \"%s\"\n",
                              SvPV(libdir,len));
 #endif
@@ -2903,7 +2920,6 @@ S_init_main_thread(pTHX)
     thr->threadsv = newAV();
     /* thr->threadsvp is set when find_threadsv is called */
     thr->specific = newAV();
-    thr->errhv = newHV();
     thr->flags = THRf_R_JOINABLE;
     MUTEX_INIT(&thr->mutex);
     /* Handcraft thrsv similarly to mess_sv */
@@ -3003,7 +3019,7 @@ Perl_call_list(pTHX_ I32 oldscope, AV *paramList)
                LEAVE;
            FREETMPS;
            PL_curstash = PL_defstash;
-           if (PL_endav)
+           if (PL_endav && !PL_minus_c)
                call_list(oldscope, PL_endav);
            PL_curcop = &PL_compiling;
            PL_curcop->cop_line = oldline;
@@ -3021,7 +3037,7 @@ Perl_call_list(pTHX_ I32 oldscope, AV *paramList)
                PL_curcop->cop_line = oldline;
                JMPENV_JUMP(3);
            }
-           PerlIO_printf(PerlIO_stderr(), "panic: restartop\n");
+           PerlIO_printf(Perl_error_log, "panic: restartop\n");
            FREETMPS;
            break;
        }