perlreapi: use parent in example, not base

[perl5.git] / perl.c

diff --git a/perl.c b/perl.c
index 90b5695..d832572 100644 (file)
--- a/perl.c
+++ b/perl.c
@@ -238,6 +238,10 @@ perl_construct(pTHXx)
 #endif
     PL_curcop = &PL_compiling; /* needed by ckWARN, right away */
 
+#ifdef PERL_TRACE_OPS
+    Zero(PL_op_exec_cnt, OP_max+2, UV);
+#endif
+
     init_constants();
 
     SvREADONLY_on(&PL_sv_placeholder);
@@ -498,7 +502,7 @@ Perl_dump_sv_child(pTHX_ SV *sv)
     if (returned_errno || *buffer) {
        Perl_warn(aTHX_ "Debug leaking scalars child failed%s%.*s with errno"
                  " %d: %s", (*buffer ? " at " : ""), (int) *buffer, buffer + 1,
-                 returned_errno, strerror(returned_errno));
+                 returned_errno, Strerror(returned_errno));
     }
 }
 #endif
@@ -568,6 +572,20 @@ perl_destruct(pTHXx)
     /* Need to flush since END blocks can produce output */
     my_fflush_all();
 
+#ifdef PERL_TRACE_OPS
+    /* If we traced all Perl OP usage, report and clean up */
+    PerlIO_printf(Perl_debug_log, "Trace of all OPs executed:\n");
+    for (i = 0; i <= OP_max; ++i) {
+        PerlIO_printf(Perl_debug_log, "  %s: %"UVuf"\n", PL_op_name[i], PL_op_exec_cnt[i]);
+        PL_op_exec_cnt[i] = 0;
+    }
+    /* Utility slot for easily doing little tracing experiments in the runloop: */
+    if (PL_op_exec_cnt[OP_max+1] != 0)
+        PerlIO_printf(Perl_debug_log, "  SPECIAL: %"UVuf"\n", PL_op_exec_cnt[OP_max+1]);
+    PerlIO_printf(Perl_debug_log, "\n");
+#endif
+
+
     if (PL_threadhook(aTHX)) {
         /* Threads hook has vetoed further cleanup */
        PL_veto_cleanup = TRUE;
@@ -740,6 +758,7 @@ perl_destruct(pTHXx)
        /* ensure comppad/curpad to refer to main's pad */
        if (CvPADLIST(PL_main_cv)) {
            PAD_SET_CUR_NOSAVE(CvPADLIST(PL_main_cv), 1);
+           PL_comppad_name = PadlistNAMES(CvPADLIST(PL_main_cv));
        }
        op_free(PL_main_root);
        PL_main_root = NULL;
@@ -1329,13 +1348,11 @@ perl_free(pTHXx)
     {
 #    ifdef NETWARE
        void *host = nw_internal_host;
-#    else
-       void *host = w32_internal_host;
-#    endif
        PerlMem_free(aTHXx);
-#    ifdef NETWARE
        nw_delete_internal_host(host);
 #    else
+       void *host = w32_internal_host;
+       PerlMem_free(aTHXx);
        win32_delete_internal_host(host);
 #    endif
     }
@@ -1364,7 +1381,11 @@ __attribute__((destructor))
 perl_fini(void)
 {
     dVAR;
-    if (PL_curinterp  && !PL_veto_cleanup)
+    if (
+#ifdef PERL_GLOBAL_STRUCT_PRIVATE
+        my_vars &&
+#endif
+        PL_curinterp && !PL_veto_cleanup)
        FREE_THREAD_KEY;
 }
 
@@ -2709,7 +2730,6 @@ Perl_call_sv(pTHX_ SV *sv, VOL I32 flags)
 {
     dVAR; dSP;
     LOGOP myop;                /* fake syntax tree node */
-    OP* method;
     UNOP method_unop;
     SVOP method_svop;
     I32 oldmark;
@@ -3194,13 +3214,16 @@ Perl_moreswitches(pTHX_ const char *s)
            PL_utf8cache = -1;
        return s;
     case 'F':
+       PL_minus_a = TRUE;
        PL_minus_F = TRUE;
+        PL_minus_n = TRUE;
        PL_splitstr = ++s;
        while (*s && !isSPACE(*s)) ++s;
        PL_splitstr = savepvn(PL_splitstr, s - PL_splitstr);
        return s;
     case 'a':
        PL_minus_a = TRUE;
+        PL_minus_n = TRUE;
        s++;
        return s;
     case 'c':
@@ -3819,7 +3842,7 @@ S_open_script(pTHX_ const char *scriptname, bool dosearch, bool *suidscript)
         && S_ISDIR(tmpstatbuf.st_mode))
         Perl_croak(aTHX_ "Can't open perl script \"%s\": %s\n",
             CopFILE(PL_curcop),
-            strerror(EISDIR));
+            Strerror(EISDIR));
 
     return rsfp;
 }
@@ -4755,9 +4778,9 @@ S_incpush(pTHX_ const char *const dir, STRLEN len, U32 flags)
        /* finally add this lib directory at the end of @INC */
        if (unshift) {
 #ifdef PERL_IS_MINIPERL
-           const U32 extra = 0;
+           const Size_t extra = 0;
 #else
-           U32 extra = av_len(av) + 1;
+           Size_t extra = av_len(av) + 1;
 #endif
            av_unshift(inc, extra + push_basedir);
            if (push_basedir)
@@ -4927,6 +4950,14 @@ void
 Perl_my_exit(pTHX_ U32 status)
 {
     dVAR;
+    if (PL_exit_flags & PERL_EXIT_ABORT) {
+       abort();
+    }
+    if (PL_exit_flags & PERL_EXIT_WARN) {
+       PL_exit_flags |= PERL_EXIT_ABORT; /* Protect against reentrant calls */
+       Perl_warn(aTHX_ "Unexpected exit %u", status);
+       PL_exit_flags &= ~PERL_EXIT_ABORT;
+    }
     switch (status) {
     case 0:
        STATUS_ALL_SUCCESS;
@@ -5024,6 +5055,14 @@ Perl_my_failure_exit(pTHX)
            STATUS_UNIX_SET(255);
     }
 #endif
+    if (PL_exit_flags & PERL_EXIT_ABORT) {
+       abort();
+    }
+    if (PL_exit_flags & PERL_EXIT_WARN) {
+       PL_exit_flags |= PERL_EXIT_ABORT; /* Protect against reentrant calls */
+       Perl_warn(aTHX_ "Unexpected exit failure %u", PL_statusvalue);
+       PL_exit_flags &= ~PERL_EXIT_ABORT;
+    }
     my_exit_jump();
 }