Add Perl_mro_register() to register Method Resolution Orders,
[p5sagit/p5-mst-13.2.git] / perl.c
diff --git a/perl.c b/perl.c
index 3876a78..27aff77 100644 (file)
--- a/perl.c
+++ b/perl.c
@@ -149,13 +149,13 @@ static I32 read_e_script(pTHX_ int idx, SV *buf_sv, int maxlen);
 
 #define CALL_BODY_EVAL(myop) \
     if (PL_op == (myop)) \
-       PL_op = Perl_pp_entereval(aTHX); \
+       PL_op = PL_ppaddr[OP_ENTEREVAL](aTHX); \
     if (PL_op) \
        CALLRUNOPS(aTHX);
 
 #define CALL_BODY_SUB(myop) \
     if (PL_op == (myop)) \
-       PL_op = Perl_pp_entersub(aTHX); \
+       PL_op = PL_ppaddr[OP_ENTERSUB](aTHX); \
     if (PL_op) \
        CALLRUNOPS(aTHX);
 
@@ -461,6 +461,8 @@ perl_construct(pTHXx)
     PL_timesbase.tms_cstime = 0;
 #endif
 
+    PL_registered_mros = newHV();
+
     ENTER;
 }
 
@@ -849,6 +851,8 @@ perl_destruct(pTHXx)
     PL_exitlist = NULL;
     PL_exitlistlen = 0;
 
+    SvREFCNT_dec(PL_registered_mros);
+
     /* jettison our possibly duplicated environment */
     /* if PERL_USE_SAFE_PUTENV is defined environ will not have been copied
      * so we certainly shouldn't free it here
@@ -1826,7 +1830,7 @@ S_parse_body(pTHX_ char **env, XSINIT_t xsinit)
            if (s && *s) {
                STRLEN len = strlen(s);
                const char * const p = savepvn(s, len);
-               incpush(p, TRUE, TRUE, FALSE, FALSE);
+               incpush(p, TRUE, TRUE, FALSE, FALSE, FALSE);
                sv_catpvs(sv, "-I");
                sv_catpvn(sv, p, len);
                sv_catpvs(sv, " ");
@@ -1876,6 +1880,9 @@ S_parse_body(pTHX_ char **env, XSINIT_t xsinit)
 #  ifdef PERL_MEM_LOG_TIMESTAMP
                             " PERL_MEM_LOG_TIMESTAMP"
 #  endif
+#  ifdef PERL_USE_DEVEL
+                            " PERL_USE_DEVEL"
+#  endif
 #  ifdef PERL_USE_SAFE_PUTENV
                             " PERL_USE_SAFE_PUTENV"
 #  endif
@@ -1895,7 +1902,7 @@ S_parse_body(pTHX_ char **env, XSINIT_t xsinit)
 #else
                    sv_catpvs(opts_prog,"\"\\nCharacteristics of this binary (from libperl): \\n");
 #endif
-
+                   sv_catpvs(opts_prog,"  Source revision: " STRINGIFY(PERL_GIT_SHA1) "\\n");
                    sv_catpvs(opts_prog,"  Compile-time options: $_\\n\",");
 
 #if defined(LOCAL_PATCH_COUNT)
@@ -1905,7 +1912,15 @@ S_parse_body(pTHX_ char **env, XSINIT_t xsinit)
                                 "\"  Locally applied patches:\\n\",");
                        for (i = 1; i <= LOCAL_PATCH_COUNT; i++) {
                            if (PL_localpatches[i])
-                               Perl_sv_catpvf(aTHX_ opts_prog,"q%c\t%s\n%c,",
+#ifdef X_PERL_PATCHNUM
+/* this is ifdef'ed out, we would enable this if we want to transform 
+   "DEVEL" registered patches into the git name */
+                               if (strEQ(PL_localpatches[i],"DEVEL"))
+                                   Perl_sv_catpvf(aTHX_ opts_prog,"q%c\t%s\n%c,",
+                                              0, STRINGIFY(PERL_PATCHNUM), 0);
+                               else
+#endif
+                                   Perl_sv_catpvf(aTHX_ opts_prog,"q%c\t%s\n%c,",
                                               0, PL_localpatches[i], 0);
                        }
                    }
@@ -2892,17 +2907,6 @@ Perl_require_pv(pTHX_ const char *pv)
     POPSTACK;
 }
 
-void
-Perl_magicname(pTHX_ const char *sym, const char *name, I32 namlen)
-{
-    register GV * const gv = gv_fetchpv(sym, GV_ADD, SVt_PV);
-
-    PERL_ARGS_ASSERT_MAGICNAME;
-
-    if (gv)
-       sv_magic(GvSV(gv), MUTABLE_SV(gv), PERL_MAGIC_sv, name, namlen);
-}
-
 STATIC void
 S_usage(pTHX_ const char *name)                /* XXX move this out into a module ? */
 {
@@ -3183,7 +3187,7 @@ Perl_moreswitches(pTHX_ const char *s)
                    p++;
            } while (*p && *p != '-');
            e = savepvn(s, e-s);
-           incpush(e, TRUE, TRUE, FALSE, FALSE);
+           incpush(e, TRUE, TRUE, FALSE, FALSE, TRUE);
            Safefree(e);
            s = p;
            if (*s == '-')
@@ -3311,9 +3315,6 @@ Perl_moreswitches(pTHX_ const char *s)
 #if !defined(DGUX)
        PerlIO_printf(PerlIO_stdout(),
                "\nThis is perl, %"SVf
-#ifdef PERL_PATCHNUM
-               " DEVEL" STRINGIFY(PERL_PATCHNUM)
-#endif
                " built for %s",
                SVfARG(vstringify(PL_patchlevel)),
                ARCHNAME);
@@ -3329,7 +3330,9 @@ Perl_moreswitches(pTHX_ const char *s)
                        Perl_form(aTHX_ "        OS Specific Release: %s\n",
                                        OSVERS));
 #endif /* !DGUX */
-
+#if defined PERL_PATCHNUM
+       PerlIO_printf(PerlIO_stdout(),"\nCompiled from: %s",STRINGIFY(PERL_PATCHNUM));
+#endif
 #if defined(LOCAL_PATCH_COUNT)
        if (LOCAL_PATCH_COUNT > 0)
            PerlIO_printf(PerlIO_stdout(),
@@ -4654,7 +4657,11 @@ S_init_postdump_symbols(pTHX_ register int argc, register char **argv, register
        sv_setpv(GvSV(tmpgv),MacPerl_MPWFileName(PL_origfilename));
 #else
        sv_setpv(GvSV(tmpgv),PL_origfilename);
-       magicname("0", "0", 1);
+       {
+           GV * const gv = gv_fetchpv("0", GV_ADD, SVt_PV);
+           if (gv)
+               sv_magic(GvSV(gv), MUTABLE_SV(gv), PERL_MAGIC_sv, "0", 1);
+       }
 #endif
     }
     if ((PL_envgv = gv_fetchpvs("ENV", GV_ADD|GV_NOTQUAL, SVt_PVHV))) {
@@ -4738,9 +4745,9 @@ S_init_perllib(pTHX)
 #else
        if (s)
 #endif
-           incpush(s, TRUE, TRUE, TRUE, FALSE);
+           incpush(s, TRUE, TRUE, TRUE, FALSE, FALSE);
        else
-           incpush(PerlEnv_getenv("PERLLIB"), FALSE, FALSE, TRUE, FALSE);
+           incpush(PerlEnv_getenv("PERLLIB"), FALSE, FALSE, TRUE, FALSE, FALSE);
 #else /* VMS */
        /* Treat PERL5?LIB as a possible search list logical name -- the
         * "natural" VMS idiom for a Unix path string.  We allow each
@@ -4749,9 +4756,9 @@ S_init_perllib(pTHX)
        char buf[256];
        int idx = 0;
        if (my_trnlnm("PERL5LIB",buf,0))
-           do { incpush(buf,TRUE,TRUE,TRUE,FALSE); } while (my_trnlnm("PERL5LIB",buf,++idx));
+           do { incpush(buf,TRUE,TRUE,TRUE,FALSE, FALSE); } while (my_trnlnm("PERL5LIB",buf,++idx));
        else
-           while (my_trnlnm("PERLLIB",buf,idx++)) incpush(buf,FALSE,FALSE,TRUE,FALSE);
+           while (my_trnlnm("PERLLIB",buf,idx++)) incpush(buf,FALSE,FALSE,TRUE,FALSE, FALSE);
 #endif /* VMS */
     }
 
@@ -4759,11 +4766,11 @@ S_init_perllib(pTHX)
     ARCHLIB PRIVLIB SITEARCH SITELIB VENDORARCH and VENDORLIB
 */
 #ifdef APPLLIB_EXP
-    incpush(APPLLIB_EXP, TRUE, TRUE, TRUE, TRUE);
+    incpush(APPLLIB_EXP, TRUE, TRUE, TRUE, TRUE, FALSE);
 #endif
 
 #ifdef ARCHLIB_EXP
-    incpush(ARCHLIB_EXP, FALSE, FALSE, TRUE, TRUE);
+    incpush(ARCHLIB_EXP, FALSE, FALSE, TRUE, TRUE, FALSE);
 #endif
 #ifdef MACOS_TRADITIONAL
     {
@@ -4776,73 +4783,74 @@ S_init_perllib(pTHX)
        
        Perl_sv_setpvf(aTHX_ privdir, "%slib:", macperl);
        if (PerlLIO_stat(SvPVX(privdir), &tmpstatbuf) >= 0 && S_ISDIR(tmpstatbuf.st_mode))
-           incpush(SvPVX(privdir), TRUE, FALSE, TRUE, FALSE);
+           incpush(SvPVX(privdir), TRUE, FALSE, TRUE, FALSE, FALSE);
        Perl_sv_setpvf(aTHX_ privdir, "%ssite_perl:", macperl);
        if (PerlLIO_stat(SvPVX(privdir), &tmpstatbuf) >= 0 && S_ISDIR(tmpstatbuf.st_mode))
-           incpush(SvPVX(privdir), TRUE, FALSE, TRUE, FALSE);
+           incpush(SvPVX(privdir), TRUE, FALSE, TRUE, FALSE, FALSE);
        
        SvREFCNT_dec(privdir);
     }
     if (!PL_tainting)
-       incpush(":", FALSE, FALSE, TRUE, FALSE);
+       incpush(":", FALSE, FALSE, FALSE, FALSE, FALSE);
 #else
 #ifndef PRIVLIB_EXP
 #  define PRIVLIB_EXP "/usr/local/lib/perl5:/usr/local/lib/perl"
 #endif
 #if defined(WIN32)
-    incpush(PRIVLIB_EXP, TRUE, FALSE, TRUE, TRUE);
+    incpush(PRIVLIB_EXP, TRUE, FALSE, TRUE, TRUE, FALSE);
 #else
-    incpush(PRIVLIB_EXP, FALSE, FALSE, TRUE, TRUE);
+    incpush(PRIVLIB_EXP, FALSE, FALSE, TRUE, TRUE, FALSE);
 #endif
 
 #ifdef SITEARCH_EXP
     /* sitearch is always relative to sitelib on Windows for
      * DLL-based path intuition to work correctly */
 #  if !defined(WIN32)
-    incpush(SITEARCH_EXP, FALSE, FALSE, TRUE, TRUE);
+    incpush(SITEARCH_EXP, FALSE, FALSE, TRUE, TRUE, FALSE);
 #  endif
 #endif
 
 #ifdef SITELIB_EXP
 #  if defined(WIN32)
     /* this picks up sitearch as well */
-    incpush(SITELIB_EXP, TRUE, FALSE, TRUE, TRUE);
+    incpush(SITELIB_EXP, TRUE, FALSE, TRUE, TRUE, FALSE);
 #  else
-    incpush(SITELIB_EXP, FALSE, FALSE, TRUE, TRUE);
+    incpush(SITELIB_EXP, FALSE, FALSE, TRUE, TRUE, FALSE);
 #  endif
 #endif
 
 #if defined(SITELIB_STEM) && defined(PERL_INC_VERSION_LIST)
     /* Search for version-specific dirs below here */
-    incpush(SITELIB_STEM, FALSE, TRUE, TRUE, TRUE);
+    incpush(SITELIB_STEM, FALSE, TRUE, TRUE, TRUE, FALSE);
 #endif
 
 #ifdef PERL_VENDORARCH_EXP
     /* vendorarch is always relative to vendorlib on Windows for
      * DLL-based path intuition to work correctly */
 #  if !defined(WIN32)
-    incpush(PERL_VENDORARCH_EXP, FALSE, FALSE, TRUE, TRUE);
+    incpush(PERL_VENDORARCH_EXP, FALSE, FALSE, TRUE, TRUE, FALSE);
 #  endif
 #endif
 
 #ifdef PERL_VENDORLIB_EXP
 #  if defined(WIN32)
-    incpush(PERL_VENDORLIB_EXP, TRUE, FALSE, TRUE, TRUE);      /* this picks up vendorarch as well */
+    incpush(PERL_VENDORLIB_EXP, TRUE, FALSE, TRUE, TRUE, FALSE);       /* this picks up vendorarch as well */
 #  else
-    incpush(PERL_VENDORLIB_EXP, FALSE, FALSE, TRUE, TRUE);
+    incpush(PERL_VENDORLIB_EXP, FALSE, FALSE, TRUE, TRUE, FALSE);
 #  endif
 #endif
 
-#ifdef PERL_VENDORLIB_STEM /* Search for version-specific dirs below here */
-    incpush(PERL_VENDORLIB_STEM, FALSE, TRUE, TRUE, TRUE);
+#if defined(PERL_VENDORLIB_STEM) && defined(PERL_INC_VERSION_LIST)
+    /* Search for version-specific dirs below here */
+    incpush(PERL_VENDORLIB_STEM, FALSE, TRUE, TRUE, TRUE, FALSE);
 #endif
 
 #ifdef PERL_OTHERLIBDIRS
-    incpush(PERL_OTHERLIBDIRS, TRUE, TRUE, TRUE, TRUE);
+    incpush(PERL_OTHERLIBDIRS, TRUE, TRUE, TRUE, TRUE, FALSE);
 #endif
 
     if (!PL_tainting)
-       incpush(".", FALSE, FALSE, TRUE, FALSE);
+       incpush(".", FALSE, FALSE, FALSE, FALSE, FALSE);
 #endif /* MACOS_TRADITIONAL */
 }
 
@@ -4884,7 +4892,7 @@ S_incpush_if_exists(pTHX_ SV *dir)
 
 STATIC void
 S_incpush(pTHX_ const char *dir, bool addsubdirs, bool addoldvers, bool usesep,
-         bool canrelocate)
+         bool canrelocate, bool unshift)
 {
     dVAR;
     SV *subdir = NULL;
@@ -5096,8 +5104,14 @@ S_incpush(pTHX_ const char *dir, bool addsubdirs, bool addoldvers, bool usesep,
 #endif
        }
 
-       /* finally push this lib directory on the end of @INC */
-       av_push(GvAVn(PL_incgv), libdir);
+       /* finally add this lib directory at the end of @INC */
+       if (unshift) {
+           av_unshift( GvAVn( PL_incgv ), 1 );
+           av_store( GvAVn( PL_incgv ), 0, libdir );
+       }
+       else {
+           av_push(GvAVn(PL_incgv), libdir);
+       }
     }
     if (subdir) {
        assert (SvREFCNT(subdir) == 1);