diag.t: Load test.pl in BEGIN

[perl5.git] / mg.c

diff --git a/mg.c b/mg.c
index b8ef4cc..14965da 100644 (file)
--- a/mg.c
+++ b/mg.c
@@ -789,6 +789,11 @@ Perl_emulate_cop_io(pTHX_ const COP *const c, SV *const sv)
     }
 }
 
+#ifdef VMS
+#include <descrip.h>
+#include <starlet.h>
+#endif
+
 int
 Perl_magic_get(pTHX_ SV *sv, MAGIC *mg)
 {
@@ -823,8 +828,6 @@ Perl_magic_get(pTHX_ SV *sv, MAGIC *mg)
         if (nextchar == '\0') {
 #if defined(VMS)
             {
-#                include <descrip.h>
-#                include <starlet.h>
                  char msg[255];
                  $DESCRIPTOR(msgdsc,msg);
                  sv_setnv(sv,(NV) vaxc$errno);
@@ -1079,9 +1082,12 @@ Perl_magic_get(pTHX_ SV *sv, MAGIC *mg)
     case '$': /* $$ */
        {
            IV const pid = (IV)PerlProc_getpid();
-           if (isGV(mg->mg_obj) || SvIV(mg->mg_obj) != pid)
+           if (isGV(mg->mg_obj) || SvIV(mg->mg_obj) != pid) {
                /* never set manually, or at least not since last fork */
                sv_setiv(sv, pid);
+               /* never unsafe, even if reading in a tainted expression */
+               SvTAINTED_off(sv);
+           }
            /* else a value has been assigned manually, so do nothing */
        }
        break;
@@ -1688,18 +1694,6 @@ Perl_magic_clearisa(pTHX_ SV *sv, MAGIC *mg)
 }
 
 int
-Perl_magic_setamagic(pTHX_ SV *sv, MAGIC *mg)
-{
-    dVAR;
-    PERL_ARGS_ASSERT_MAGIC_SETAMAGIC;
-    PERL_UNUSED_ARG(sv);
-    PERL_UNUSED_ARG(mg);
-    PL_amagic_generation++;
-
-    return 0;
-}
-
-int
 Perl_magic_getnkeys(pTHX_ SV *sv, MAGIC *mg)
 {
     HV * const hv = MUTABLE_HV(LvTARG(sv));
@@ -2049,6 +2043,25 @@ Perl_magic_setarylen(pTHX_ SV *sv, MAGIC *mg)
 }
 
 int
+Perl_magic_cleararylen_p(pTHX_ SV *sv, MAGIC *mg)
+{
+    dVAR;
+
+    PERL_ARGS_ASSERT_MAGIC_CLEARARYLEN_P;
+    PERL_UNUSED_ARG(sv);
+
+    /* Reset the iterator when the array is cleared */
+#if IVSIZE == I32SIZE
+    *((IV *) &(mg->mg_len)) = 0;
+#else
+    if (mg->mg_ptr)
+        *((IV *) mg->mg_ptr) = 0;
+#endif
+
+    return 0;
+}
+
+int
 Perl_magic_freearylen_p(pTHX_ SV *sv, MAGIC *mg)
 {
     dVAR;
@@ -2438,9 +2451,6 @@ Perl_magic_setregexp(pTHX_ SV *sv, MAGIC *mg)
     } else if (type == PERL_MAGIC_bm) {
        SvTAIL_off(sv);
        SvVALID_off(sv);
-    } else if (type == PERL_MAGIC_study) {
-       if (!isGV_with_GP(sv))
-           SvSCREAM_off(sv);
     } else {
        assert(type == PERL_MAGIC_fm);
     }
@@ -2516,11 +2526,13 @@ Perl_magic_set(pTHX_ SV *sv, MAGIC *mg)
       paren = atoi(mg->mg_ptr);
       setparen:
        if (PL_curpm && (rx = PM_GETRE(PL_curpm))) {
+      setparen_got_rx:
             CALLREG_NUMBUF_STORE((REGEXP * const)rx,paren,sv);
        } else {
             /* Croak with a READONLY error when a numbered match var is
              * set without a previous pattern match. Unless it's C<local $1>
              */
+      croakparen:
             if (!PL_localizing) {
                 Perl_croak_no_modify(aTHX);
             }
@@ -2595,6 +2607,10 @@ Perl_magic_set(pTHX_ SV *sv, MAGIC *mg)
        Safefree(PL_inplace);
        PL_inplace = SvOK(sv) ? savesvpv(sv) : NULL;
        break;
+    case '\016':       /* ^N */
+       if (PL_curpm && (rx = PM_GETRE(PL_curpm))
+        && (paren = RX_LASTCLOSEPAREN(rx))) goto setparen_got_rx;
+       goto croakparen;
     case '\017':       /* ^O */
        if (*(mg->mg_ptr+1) == '\0') {
            Safefree(PL_osname);
@@ -2844,7 +2860,7 @@ Perl_magic_set(pTHX_ SV *sv, MAGIC *mg)
        (void)setresuid((Uid_t)-1, (Uid_t)new_euid, (Uid_t)-1);
 #else
        if (new_euid == PerlProc_getuid())              /* special case $> = $< */
-           PerlProc_setuid(my_euid);
+           PerlProc_setuid(new_euid);
        else {
            Perl_croak(aTHX_ "seteuid() not implemented");
        }
@@ -3095,6 +3111,7 @@ Perl_sighandler(int sig)
     U32 flags = 0;
     XPV * const tXpv = PL_Xpv;
     I32 old_ss_ix = PL_savestack_ix;
+    SV *errsv_save = NULL;
 
 
     if (!PL_psig_ptr[sig]) {
@@ -3173,10 +3190,13 @@ Perl_sighandler(int sig)
 #endif
     PUTBACK;
 
+    errsv_save = newSVsv(ERRSV);
+
     call_sv(MUTABLE_SV(cv), G_DISCARD|G_EVAL);
 
     POPSTACK;
     if (SvTRUE(ERRSV)) {
+        SvREFCNT_dec(errsv_save);
 #ifndef PERL_MICRO
        /* Handler "died", for example to get out of a restart-able read().
         * Before we re-do that on its behalf re-enable the signal which was
@@ -3200,6 +3220,11 @@ Perl_sighandler(int sig)
 #endif /* !PERL_MICRO */
        die_sv(ERRSV);
     }
+    else {
+        sv_setsv(ERRSV, errsv_save);
+        SvREFCNT_dec(errsv_save);
+    }
+
 cleanup:
     /* pop any of SAVEFREESV, SAVEDESTRUCTOR_X and "save in progress" */
     PL_savestack_ix = old_ss_ix;
@@ -3352,14 +3377,13 @@ Perl_magic_clearhint(pTHX_ SV *sv, MAGIC *mg)
     PERL_ARGS_ASSERT_MAGIC_CLEARHINT;
     PERL_UNUSED_ARG(sv);
 
-    assert(mg->mg_len == HEf_SVKEY);
-
-    PERL_UNUSED_ARG(sv);
-
     PL_hints |= HINT_LOCALIZE_HH;
     CopHINTHASH_set(&PL_compiling,
-       cophh_delete_sv(CopHINTHASH_get(&PL_compiling),
-                                MUTABLE_SV(mg->mg_ptr), 0, 0));
+       mg->mg_len == HEf_SVKEY
+        ? cophh_delete_sv(CopHINTHASH_get(&PL_compiling),
+                                MUTABLE_SV(mg->mg_ptr), 0, 0)
+        : cophh_delete_pvn(CopHINTHASH_get(&PL_compiling),
+                                mg->mg_ptr, mg->mg_len, 0, 0));
     return 0;
 }
 
@@ -3381,12 +3405,31 @@ Perl_magic_clearhints(pTHX_ SV *sv, MAGIC *mg)
     return 0;
 }
 
+int
+Perl_magic_copycallchecker(pTHX_ SV *sv, MAGIC *mg, SV *nsv,
+                                const char *name, I32 namlen)
+{
+    MAGIC *nmg;
+
+    PERL_ARGS_ASSERT_MAGIC_COPYCALLCHECKER;
+    PERL_UNUSED_ARG(name);
+    PERL_UNUSED_ARG(namlen);
+
+    sv_magic(nsv, &PL_sv_undef, mg->mg_type, NULL, 0);
+    nmg = mg_find(nsv, mg->mg_type);
+    if (nmg->mg_flags & MGf_REFCOUNTED) SvREFCNT_dec(nmg->mg_obj);
+    nmg->mg_ptr = mg->mg_ptr;
+    nmg->mg_obj = SvREFCNT_inc_simple(mg->mg_obj);
+    nmg->mg_flags |= MGf_REFCOUNTED;
+    return 1;
+}
+
 /*
  * Local variables:
  * c-indentation-style: bsd
  * c-basic-offset: 4
- * indent-tabs-mode: t
+ * indent-tabs-mode: nil
  * End:
  *
- * ex: set ts=8 sts=4 sw=4 noet:
+ * ex: set ts=8 sts=4 sw=4 et:
  */