stab at UNITCHECK blocks

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

diff --git a/perl.c b/perl.c
index 7e0f842..7353d32 100644 (file)
--- a/perl.c
+++ b/perl.c
@@ -137,6 +137,22 @@ static I32 read_e_script(pTHX_ int idx, SV *buf_sv, int maxlen);
 #endif
 #endif
 
+#define CALL_BODY_EVAL(myop) \
+    if (PL_op == (myop)) \
+       PL_op = Perl_pp_entereval(aTHX); \
+    if (PL_op) \
+       CALLRUNOPS(aTHX);
+
+#define CALL_BODY_SUB(myop) \
+    if (PL_op == (myop)) \
+       PL_op = Perl_pp_entersub(aTHX); \
+    if (PL_op) \
+       CALLRUNOPS(aTHX);
+
+#define CALL_LIST_BODY(cv) \
+    PUSHMARK(PL_stack_sp); \
+    call_sv((SV*)(cv), G_EVAL|G_DISCARD);
+
 static void
 S_init_tls_and_interp(PerlInterpreter *my_perl)
 {
@@ -148,6 +164,7 @@ S_init_tls_and_interp(PerlInterpreter *my_perl)
        ALLOC_THREAD_KEY;
        PERL_SET_THX(my_perl);
        OP_REFCNT_INIT;
+       HINTS_REFCNT_INIT;
        MUTEX_INIT(&PL_dollarzero_mutex);
 #  endif
 #ifdef PERL_IMPLICIT_CONTEXT
@@ -228,7 +245,7 @@ void
 perl_construct(pTHXx)
 {
     dVAR;
-    PERL_UNUSED_CONTEXT;
+    PERL_UNUSED_ARG(my_perl);
 #ifdef MULTIPLICITY
     init_interp();
     PL_perl_destruct_level = 1;
@@ -360,7 +377,7 @@ perl_construct(pTHXx)
        if ((long) PL_mmap_page_size < 0) {
          if (errno) {
            SV * const error = ERRSV;
-           (void) SvUPGRADE(error, SVt_PV);
+           SvUPGRADE(error, SVt_PV);
            Perl_croak(aTHX_ "panic: sysconf: %s", SvPV_nolen_const(error));
          }
          else
@@ -528,7 +545,7 @@ perl_destruct(pTHXx)
     pid_t child;
 #endif
 
-    PERL_UNUSED_CONTEXT;
+    PERL_UNUSED_ARG(my_perl);
 
     /* wait for all pseudo-forked children to finish */
     PERL_WAIT_FOR_CHILDREN;
@@ -927,12 +944,16 @@ perl_destruct(pTHXx)
     SvREFCNT_dec(PL_endav);
     SvREFCNT_dec(PL_checkav);
     SvREFCNT_dec(PL_checkav_save);
+    SvREFCNT_dec(PL_unitcheckav);
+    SvREFCNT_dec(PL_unitcheckav_save);
     SvREFCNT_dec(PL_initav);
     PL_beginav = NULL;
     PL_beginav_save = NULL;
     PL_endav = NULL;
     PL_checkav = NULL;
     PL_checkav_save = NULL;
+    PL_unitcheckav = NULL;
+    PL_unitcheckav_save = NULL;
     PL_initav = NULL;
 
     /* shortcuts just get cleared */
@@ -1034,11 +1055,10 @@ perl_destruct(pTHXx)
     PL_utf8_idcont     = NULL;
 
     if (!specialWARN(PL_compiling.cop_warnings))
-       SvREFCNT_dec(PL_compiling.cop_warnings);
+       PerlMemShared_free(PL_compiling.cop_warnings);
     PL_compiling.cop_warnings = NULL;
-    if (!specialCopIO(PL_compiling.cop_io))
-       SvREFCNT_dec(PL_compiling.cop_io);
-    PL_compiling.cop_io = NULL;
+    Perl_refcounted_he_free(aTHX_ PL_compiling.cop_hints_hash);
+    PL_compiling.cop_hints_hash = NULL;
     CopFILE_free(&PL_compiling);
     CopSTASH_free(&PL_compiling);
 
@@ -1255,6 +1275,12 @@ perl_destruct(pTHXx)
 
     sv_free_arenas();
 
+    while (PL_regmatch_slab) {
+       regmatch_slab  *s = PL_regmatch_slab;
+       PL_regmatch_slab = PL_regmatch_slab->next;
+       Safefree(s);
+    }
+
     /* As the absolutely last thing, free the non-arena SV for mess() */
 
     if (PL_mess_sv) {
@@ -1336,6 +1362,8 @@ perl_free(pTHXx)
 
 #if defined(__hpux) && !(defined(__ux_version) && __ux_version <= 1020) && !defined(__GNUC__)
 #pragma fini "perl_fini"
+#elif defined(__sun) && !defined(__GNUC__)
+#pragma fini (perl_fini)
 #endif
 
 static void
@@ -1430,7 +1458,7 @@ perl_parse(pTHXx_ XSINIT_t xsinit, int argc, char **argv, char **env)
     int ret;
     dJMPENV;
 
-    PERL_UNUSED_VAR(my_perl);
+    PERL_UNUSED_ARG(my_perl);
 
 #ifdef SETUID_SCRIPTS_ARE_SECURE_NOW
 #ifdef IAMSUID
@@ -1581,6 +1609,8 @@ setuid perl scripts securely.\n");
     switch (ret) {
     case 0:
        parse_body(env,xsinit);
+       if (PL_unitcheckav)
+           call_list(oldscope, PL_unitcheckav);
        if (PL_checkav)
            call_list(oldscope, PL_checkav);
        ret = 0;
@@ -1594,6 +1624,8 @@ setuid perl scripts securely.\n");
            LEAVE;
        FREETMPS;
        PL_curstash = PL_defstash;
+       if (PL_unitcheckav)
+           call_list(oldscope, PL_unitcheckav);
        if (PL_checkav)
            call_list(oldscope, PL_checkav);
        ret = STATUS_EXIT;
@@ -2026,7 +2058,8 @@ S_parse_body(pTHX_ char **env, XSINIT_t xsinit)
 #endif
 
     if (PL_taint_warn && PL_dowarn != G_WARN_ALL_OFF) {
-       PL_compiling.cop_warnings = newSVpvn(WARN_TAINTstring, WARNsize);
+        PL_compiling.cop_warnings
+           = Perl_new_warnings_bitfield(aTHX_ NULL, WARN_TAINTstring, WARNsize);
     }
 
     if (!scriptname)
@@ -2269,7 +2302,7 @@ perl_run(pTHXx)
     int ret = 0;
     dJMPENV;
 
-    PERL_UNUSED_CONTEXT;
+    PERL_UNUSED_ARG(my_perl);
 
     oldscope = PL_scopestack_ix;
 #ifdef VMS
@@ -2597,7 +2630,7 @@ Perl_call_sv(pTHX_ SV *sv, I32 flags)
 
     if (!(flags & G_EVAL)) {
        CATCH_SET(TRUE);
-       call_body((OP*)&myop, FALSE);
+       CALL_BODY_SUB((OP*)&myop);
        retval = PL_stack_sp - (PL_stack_base + oldmark);
        CATCH_SET(oldcatch);
     }
@@ -2612,7 +2645,7 @@ Perl_call_sv(pTHX_ SV *sv, I32 flags)
        switch (ret) {
        case 0:
  redo_body:
-           call_body((OP*)&myop, FALSE);
+           CALL_BODY_SUB((OP*)&myop);
            retval = PL_stack_sp - (PL_stack_base + oldmark);
            if (!(flags & G_KEEPERR))
                sv_setpvn(ERRSV,"",0);
@@ -2660,20 +2693,6 @@ Perl_call_sv(pTHX_ SV *sv, I32 flags)
     return retval;
 }
 
-STATIC void
-S_call_body(pTHX_ const OP *myop, bool is_eval)
-{
-    dVAR;
-    if (PL_op == myop) {
-       if (is_eval)
-           PL_op = Perl_pp_entereval(aTHX);    /* this doesn't do a POPMARK */
-       else
-           PL_op = Perl_pp_entersub(aTHX);     /* this does */
-    }
-    if (PL_op)
-       CALLRUNOPS(aTHX);
-}
-
 /* Eval a string. The G_EVAL flag is always assumed. */
 
 /*
@@ -2727,7 +2746,7 @@ Perl_eval_sv(pTHX_ SV *sv, I32 flags)
     switch (ret) {
     case 0:
  redo_body:
-       call_body((OP*)&myop,TRUE);
+       CALL_BODY_EVAL((OP*)&myop);
        retval = PL_stack_sp - (PL_stack_base + oldmark);
        if (!(flags & G_KEEPERR))
            sv_setpvn(ERRSV,"",0);
@@ -2922,7 +2941,7 @@ Perl_get_debug_opts(pTHX_ const char **s, bool givehelp)
     int i = 0;
     if (isALPHA(**s)) {
        /* if adding extra options, remember to update DEBUG_MASK */
-       static const char debopts[] = "psltocPmfrxu HXDSTRJvCAq";
+       static const char debopts[] = "psltocPmfrxuUHXDSTRJvCAq";
 
        for (; isALNUM(**s); (*s)++) {
            const char * const d = strchr(debopts,**s);
@@ -3004,6 +3023,8 @@ Perl_moreswitches(pTHX_ char *s)
     case 'C':
         s++;
         PL_unicode = parse_unicode_opts( (const char **)&s );
+       if (PL_unicode & PERL_UNICODE_UTF8CACHEASSERT_FLAG)
+           PL_utf8cache = -1;
        return s;
     case 'F':
        PL_minus_F = TRUE;
@@ -3079,7 +3100,7 @@ Perl_moreswitches(pTHX_ char *s)
        }
 #endif /* __CYGWIN__ */
        {
-           const char *start = ++s;
+           const char * const start = ++s;
            while (*s && !isSPACE(*s))
                ++s;
 
@@ -3249,8 +3270,8 @@ Perl_moreswitches(pTHX_ char *s)
                          " DEVEL" STRINGIFY(PERL_PATCHNUM)
 #endif
                          " built for %s",
-                   vstringify(PL_patchlevel),
-                   ARCHNAME));
+                         (void*)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(),
@@ -3269,7 +3290,7 @@ Perl_moreswitches(pTHX_ char *s)
            PerlIO_printf(PerlIO_stdout(),
                          "\n(with %d registered patch%s, "
                          "see perl -V for more detail)",
-                         (int)LOCAL_PATCH_COUNT,
+                         LOCAL_PATCH_COUNT,
                          (LOCAL_PATCH_COUNT!=1) ? "es" : "");
 #endif
 
@@ -3358,14 +3379,14 @@ Internet, point your browser at http://www.perl.org/, the Perl Home Page.\n\n");
     case 'W':
        PL_dowarn = G_WARN_ALL_ON|G_WARN_ON;
         if (!specialWARN(PL_compiling.cop_warnings))
-            SvREFCNT_dec(PL_compiling.cop_warnings);
+            PerlMemShared_free(PL_compiling.cop_warnings);
        PL_compiling.cop_warnings = pWARN_ALL ;
        s++;
        return s;
     case 'X':
        PL_dowarn = G_WARN_ALL_OFF;
         if (!specialWARN(PL_compiling.cop_warnings))
-            SvREFCNT_dec(PL_compiling.cop_warnings);
+            PerlMemShared_free(PL_compiling.cop_warnings);
        PL_compiling.cop_warnings = pWARN_NONE ;
        s++;
        return s;
@@ -3463,6 +3484,10 @@ S_init_interp(pTHX)
 #  undef PERLVARIC
 #endif
 
+    /* As these are inside a structure, PERLVARI isn't capable of initialising
+       them  */
+    PL_reg_oldcurpm = PL_reg_curpm = NULL;
+    PL_reg_poscache = PL_reg_starttry = NULL;
 }
 
 STATIC void
@@ -3650,8 +3675,8 @@ S_open_script(pTHX_ const char *scriptname, bool dosearch, SV *sv,
 
         Perl_sv_setpvf(aTHX_ cmd, "\
 %s -ne%s%s%s %s | %"SVf" %s %"SVf" %s",
-                       perl, quote, code, quote, scriptname, cpp,
-                       cpp_discard_flag, sv, CPPMINUS);
+                       perl, quote, code, quote, scriptname, (void*)cpp,
+                       cpp_discard_flag, (void*)sv, CPPMINUS);
 
        PL_doextract = FALSE;
 
@@ -4781,7 +4806,8 @@ S_init_perllib(pTHX)
 #  endif
 #endif
 
-#ifdef SITELIB_STEM /* Search for version-specific dirs below here */
+#if defined(SITELIB_STEM) && defined(PERL_INC_VERSION_LIST)
+    /* Search for version-specific dirs below here */
     incpush(SITELIB_STEM, FALSE, TRUE, TRUE, TRUE);
 #endif
 
@@ -5029,19 +5055,21 @@ S_incpush(pTHX_ const char *dir, bool addsubdirs, bool addoldvers, bool usesep,
 #endif
                /* .../version/archname if -d .../version/archname */
                Perl_sv_setpvf(aTHX_ subdir, "%"SVf PERL_ARCH_FMT_PATH PERL_ARCH_FMT,
-                               libdir,
+                              (void*)libdir,
                               (int)PERL_REVISION, (int)PERL_VERSION,
                               (int)PERL_SUBVERSION, ARCHNAME);
                subdir = S_incpush_if_exists(aTHX_ subdir);
 
                /* .../version if -d .../version */
-               Perl_sv_setpvf(aTHX_ subdir, "%"SVf PERL_ARCH_FMT_PATH, libdir,
+               Perl_sv_setpvf(aTHX_ subdir, "%"SVf PERL_ARCH_FMT_PATH,
+                              (void*)libdir,
                               (int)PERL_REVISION, (int)PERL_VERSION,
                               (int)PERL_SUBVERSION);
                subdir = S_incpush_if_exists(aTHX_ subdir);
 
                /* .../archname if -d .../archname */
-               Perl_sv_setpvf(aTHX_ subdir, "%"SVf PERL_ARCH_FMT, libdir, ARCHNAME);
+               Perl_sv_setpvf(aTHX_ subdir, "%"SVf PERL_ARCH_FMT,
+                              (void*)libdir, ARCHNAME);
                subdir = S_incpush_if_exists(aTHX_ subdir);
 
            }
@@ -5050,7 +5078,7 @@ S_incpush(pTHX_ const char *dir, bool addsubdirs, bool addoldvers, bool usesep,
            if (addoldvers) {
                for (incver = incverlist; *incver; incver++) {
                    /* .../xxx if -d .../xxx */
-                   Perl_sv_setpvf(aTHX_ subdir, "%"SVf PERL_ARCH_FMT, libdir, *incver);
+                   Perl_sv_setpvf(aTHX_ subdir, "%"SVf PERL_ARCH_FMT, (void *)libdir, *incver);
                    subdir = S_incpush_if_exists(aTHX_ subdir);
                }
            }
@@ -5093,6 +5121,12 @@ Perl_call_list(pTHX_ I32 oldscope, AV *paramList)
                    PL_checkav_save = newAV();
                av_push(PL_checkav_save, (SV*)cv);
            }
+           else if (paramList == PL_unitcheckav) {
+               /* save PL_unitcheckav for compiler */
+               if (! PL_unitcheckav_save)
+                   PL_unitcheckav_save = newAV();
+               av_push(PL_unitcheckav_save, (SV*)cv);
+           }
        } else {
            if (!PL_madskills)
                SAVEFREESV(cv);
@@ -5104,7 +5138,7 @@ Perl_call_list(pTHX_ I32 oldscope, AV *paramList)
            if (PL_madskills)
                PL_madskills |= 16384;
 #endif
-           call_list_body(cv);
+           CALL_LIST_BODY(cv);
 #ifdef PERL_MAD
            if (PL_madskills)
                PL_madskills &= ~16384;
@@ -5123,11 +5157,12 @@ Perl_call_list(pTHX_ I32 oldscope, AV *paramList)
                                   "%s failed--call queue aborted",
                                   paramList == PL_checkav ? "CHECK"
                                   : paramList == PL_initav ? "INIT"
+                                  : paramList == PL_unitcheckav ? "UNITCHECK"
                                   : "END");
                while (PL_scopestack_ix > oldscope)
                    LEAVE;
                JMPENV_POP;
-               Perl_croak(aTHX_ "%"SVf"", atsv);
+               Perl_croak(aTHX_ "%"SVf"", (void*)atsv);
            }
            break;
        case 1:
@@ -5151,6 +5186,7 @@ Perl_call_list(pTHX_ I32 oldscope, AV *paramList)
                    Perl_croak(aTHX_ "%s failed--call queue aborted",
                               paramList == PL_checkav ? "CHECK"
                               : paramList == PL_initav ? "INIT"
+                              : paramList == PL_unitcheckav ? "UNITCHECK"
                               : "END");
            }
            my_exit_jump();
@@ -5169,15 +5205,6 @@ Perl_call_list(pTHX_ I32 oldscope, AV *paramList)
     }
 }
 
-STATIC void *
-S_call_list_body(pTHX_ CV *cv)
-{
-    dVAR;
-    PUSHMARK(PL_stack_sp);
-    call_sv((SV*)cv, G_EVAL|G_DISCARD);
-    return NULL;
-}
-
 void
 Perl_my_exit(pTHX_ U32 status)
 {