no_plan support in test.pl

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

diff --git a/pad.c b/pad.c
index e8296a3..8b5f86a 100644 (file)
--- a/pad.c
+++ b/pad.c
@@ -1,6 +1,6 @@
 /*    pad.c
  *
- *    Copyright (C) 2002,2003 by Larry Wall and others
+ *    Copyright (C) 2002, 2003, 2004, by Larry Wall and others
  *
  *    You may distribute under the terms of either the GNU General Public
  *    License or the Artistic License, as specified in the README file.
@@ -91,6 +91,12 @@ become so if C<my sub foo {}> is implemented.)
 Note that formats are treated as anon subs, and are cloned each time
 write is called (if necessary).
 
+The flag SVf_PADSTALE is cleared on lexicals each time the my() is executed,
+and set on scope exit. This allows the 'Variable $x is not available' warning
+to be generated in evals, such as 
+
+    { my $x = 1; sub f { eval '$x'} } f();
+
 =cut
 */
 
@@ -251,17 +257,28 @@ Perl_pad_undef(pTHX_ CV* cv)
                CV *innercv = (CV*)curpad[ix];
                namepad[ix] = Nullsv;
                SvREFCNT_dec(namesv);
-               curpad[ix] = Nullsv;
-               SvREFCNT_dec(innercv);
+
+               if (SvREFCNT(comppad) < 2) { /* allow for /(?{ sub{} })/  */
+                   curpad[ix] = Nullsv;
+                   SvREFCNT_dec(innercv);
+               }
                if (SvREFCNT(innercv) /* in use, not just a prototype */
                    && CvOUTSIDE(innercv) == cv)
                {
                    assert(CvWEAKOUTSIDE(innercv));
-                   CvWEAKOUTSIDE_off(innercv);
-                   CvOUTSIDE(innercv) = outercv;
-                   CvOUTSIDE_SEQ(innercv) = seq;
-                   SvREFCNT_inc(outercv);
+                   /* don't relink to grandfather if he's being freed */
+                   if (outercv && SvREFCNT(outercv)) {
+                       CvWEAKOUTSIDE_off(innercv);
+                       CvOUTSIDE(innercv) = outercv;
+                       CvOUTSIDE_SEQ(innercv) = seq;
+                       SvREFCNT_inc(outercv);
+                   }
+                   else {
+                       CvOUTSIDE(innercv) = Nullcv;
+                   }
+
                }
+
            }
        }
     }
@@ -537,11 +554,47 @@ Perl_pad_findmy(pTHX_ char *name)
 {
     SV *out_sv;
     int out_flags;
+    I32 offset;
+    AV *nameav;
+    SV **name_svp;
 
-    return pad_findlex(name, PL_compcv, PL_cop_seqmax, 1,
+    offset =  pad_findlex(name, PL_compcv, PL_cop_seqmax, 1,
                Null(SV**), &out_sv, &out_flags);
+    if (offset != NOT_IN_PAD) 
+       return offset;
+
+    /* look for an our that's being introduced; this allows
+     *    our $foo = 0 unless defined $foo;
+     * to not give a warning. (Yes, this is a hack) */
+
+    nameav = (AV*)AvARRAY(CvPADLIST(PL_compcv))[0];
+    name_svp = AvARRAY(nameav);
+    for (offset = AvFILLp(nameav); offset > 0; offset--) {
+       SV *namesv = name_svp[offset];
+       if (namesv && namesv != &PL_sv_undef
+           && !SvFAKE(namesv)
+           && (SvFLAGS(namesv) & SVpad_OUR)
+           && strEQ(SvPVX(namesv), name)
+           && U_32(SvNVX(namesv)) == PAD_MAX /* min */
+       )
+           return offset;
+    }
+    return NOT_IN_PAD;
 }
 
+/*
+ * Returns the offset of a lexical $_, if there is one, at run time.
+ * Used by the UNDERBAR XS macro.
+ */
+
+PADOFFSET
+Perl_find_rundefsvoffset(pTHX)
+{
+    SV *out_sv;
+    int out_flags;
+    return pad_findlex("$_", find_runcv(NULL), PL_curcop->cop_seq, 1,
+           Null(SV**), &out_sv, &out_flags);
+}
 
 /*
 =for apidoc pad_findlex
@@ -608,8 +661,8 @@ S_pad_findlex(pTHX_ char *name, CV* cv, U32 seq, int warn,
            {
                if (SvFAKE(namesv))
                    fake_offset = offset; /* in case we don't find a real one */
-               else if (  seq >  (U32)I_32(SvNVX(namesv))      /* min */
-                       && seq <= (U32)SvIVX(namesv))           /* max */
+               else if (  seq >  U_32(SvNVX(namesv))   /* min */
+                       && seq <= (U32)SvIVX(namesv))   /* max */
                    break;
            }
        }
@@ -633,7 +686,7 @@ S_pad_findlex(pTHX_ char *name, CV* cv, U32 seq, int warn,
 
                DEBUG_Xv(PerlIO_printf(Perl_debug_log,
                    "Pad findlex cv=0x%"UVxf" matched: offset=%ld (%ld,%ld)\n",
-                   PTR2UV(cv), (long)offset, (long)I_32(SvNVX(*out_name_sv)),
+                   PTR2UV(cv), (long)offset, (long)U_32(SvNVX(*out_name_sv)),
                    (long)SvIVX(*out_name_sv)));
            }
            else { /* fake match */
@@ -641,7 +694,7 @@ S_pad_findlex(pTHX_ char *name, CV* cv, U32 seq, int warn,
                *out_name_sv = name_svp[offset]; /* return the namesv */
                *out_flags = SvIVX(*out_name_sv);
                DEBUG_Xv(PerlIO_printf(Perl_debug_log,
-                   "Pad findlex cv=0x%"UVxf" matched: offset=%ld flags=0x%x index=%lu\n",
+                   "Pad findlex cv=0x%"UVxf" matched: offset=%ld flags=0x%lx index=%lu\n",
                    PTR2UV(cv), (long)offset, (unsigned long)*out_flags,
                        (unsigned long)SvNVX(*out_name_sv) 
                ));
@@ -697,7 +750,7 @@ S_pad_findlex(pTHX_ char *name, CV* cv, U32 seq, int warn,
                                    CvDEPTH(cv) ? CvDEPTH(cv) : 1])[offset];
                    DEBUG_Xv(PerlIO_printf(Perl_debug_log,
                        "Pad findlex cv=0x%"UVxf" found lex=0x%"UVxf"\n",
-                       PTR2UV(cv), *out_capture));
+                       PTR2UV(cv), PTR2UV(*out_capture)));
 
                    if (SvPADSTALE(*out_capture)) {
                        if (ckWARN(WARN_CLOSURE))
@@ -902,7 +955,7 @@ Perl_intro_my(pTHX)
            DEBUG_Xv(PerlIO_printf(Perl_debug_log,
                "Pad intromy: %ld \"%s\", (%ld,%ld)\n",
                (long)i, SvPVX(sv),
-               (long)I_32(SvNVX(sv)), (long)SvIVX(sv))
+               (long)U_32(SvNVX(sv)), (long)SvIVX(sv))
            );
        }
     }
@@ -950,7 +1003,7 @@ Perl_pad_leavemy(pTHX)
            DEBUG_Xv(PerlIO_printf(Perl_debug_log,
                "Pad leavemy: %ld \"%s\", (%ld,%ld)\n",
                (long)off, SvPVX(sv),
-               (long)I_32(SvNVX(sv)), (long)SvIVX(sv))
+               (long)U_32(SvNVX(sv)), (long)SvIVX(sv))
            );
        }
     }
@@ -1220,7 +1273,7 @@ Perl_do_dump_pad(pTHX_ I32 level, PerlIO *file, PADLIST *padlist, int full)
        if (namesv) {
            if (SvFAKE(namesv))
                Perl_dump_indent(aTHX_ level+1, file,
-                   "%2d. 0x%"UVxf"<%lu> FAKE \"%s\" flags=0x%x index=%lu\n",
+                   "%2d. 0x%"UVxf"<%lu> FAKE \"%s\" flags=0x%lx index=%lu\n",
                    (int) ix,
                    PTR2UV(ppad[ix]),
                    (unsigned long) (ppad[ix] ? SvREFCNT(ppad[ix]) : 0),
@@ -1235,7 +1288,7 @@ Perl_do_dump_pad(pTHX_ I32 level, PerlIO *file, PADLIST *padlist, int full)
                    (int) ix,
                    PTR2UV(ppad[ix]),
                    (unsigned long) (ppad[ix] ? SvREFCNT(ppad[ix]) : 0),
-                   (long)I_32(SvNVX(namesv)),
+                   (long)U_32(SvNVX(namesv)),
                    (long)SvIVX(namesv),
                    SvPVX(namesv)
                );
@@ -1483,6 +1536,9 @@ If has_args is true, give the new pad an @_ in slot zero.
 =cut
 */
 
+/* XXX pad_push is now always called with has_args == 1. Get rid of
+ * this arg at some point */
+
 void
 Perl_pad_push(pTHX_ PADLIST *padlist, int depth, int has_args)
 {