avoid temp file littering in tests

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

diff --git a/op.c b/op.c
index 98239d9..daefb14 100644 (file)
--- a/op.c
+++ b/op.c
@@ -20,6 +20,8 @@
 #include "perl.h"
 #include "keywords.h"
 
+#define CALL_PEEP(o) CALL_FPTR(PL_peepp)(aTHX_ o)
+
 /* #define PL_OP_SLAB_ALLOC */
 
 #ifdef PL_OP_SLAB_ALLOC
@@ -850,8 +852,14 @@ clear_pmop:
 #endif
        }
        cPMOPo->op_pmreplroot = Nullop;
-       ReREFCNT_dec(PM_GETRE(cPMOPo));
-       PM_SETRE(cPMOPo, (REGEXP*)NULL);
+        /* we use the "SAFE" version of the PM_ macros here
+         * since sv_clean_all might release some PMOPs
+         * after PL_regex_padav has been cleared
+         * and the clearing of PL_regex_padav needs to
+         * happen before sv_clean_all
+         */
+       ReREFCNT_dec(PM_GETRE_SAFE(cPMOPo));
+       PM_SETRE_SAFE(cPMOPo, (REGEXP*)NULL);
        break;
     }
 
@@ -2174,7 +2182,7 @@ Perl_newPROG(pTHX_ OP *o)
        PL_eval_root->op_private |= OPpREFCOUNTED;
        OpREFCNT_set(PL_eval_root, 1);
        PL_eval_root->op_next = 0;
-       peep(PL_eval_start);
+       CALL_PEEP(PL_eval_start);
     }
     else {
        if (!o)
@@ -2185,7 +2193,7 @@ Perl_newPROG(pTHX_ OP *o)
        PL_main_root->op_private |= OPpREFCOUNTED;
        OpREFCNT_set(PL_main_root, 1);
        PL_main_root->op_next = 0;
-       peep(PL_main_start);
+       CALL_PEEP(PL_main_start);
        PL_compcv = 0;
 
        /* Register with debugger */
@@ -2208,9 +2216,14 @@ Perl_localize(pTHX_ OP *o, I32 lex)
     if (o->op_flags & OPf_PARENS)
        list(o);
     else {
-       if (ckWARN(WARN_PARENTHESIS) && PL_bufptr > PL_oldbufptr && PL_bufptr[-1] == ',') {
-           char *s;
-           for (s = PL_bufptr; *s && (isALNUM(*s) || UTF8_IS_CONTINUED(*s) || strchr("@$%, ",*s)); s++) ;
+       if (ckWARN(WARN_PARENTHESIS)
+           && PL_bufptr > PL_oldbufptr && PL_bufptr[-1] == ',')
+       {
+           char *s = PL_bufptr;
+
+           while (*s && (isALNUM(*s) || UTF8_IS_CONTINUED(*s) || strchr("@$%, ", *s)))
+               s++;
+
            if (*s == ';' || *s == '=')
                Perl_warner(aTHX_ WARN_PARENTHESIS,
                            "Parentheses missing around \"%s\" list",
@@ -2369,7 +2382,7 @@ Perl_gen_constant_list(pTHX_ register OP *o)
 
     PL_op = curop = LINKLIST(o);
     o->op_next = 0;
-    peep(curop);
+    CALL_PEEP(curop);
     pp_pushmark();
     CALLRUNOPS(aTHX);
     PL_op = curop;
@@ -3217,6 +3230,9 @@ Perl_utilize(pTHX_ int aver, I32 floor, OP *version, OP *id, OP *arg)
     OP *pack;
     OP *imop;
     OP *veop;
+    char *packname = Nullch;
+    STRLEN packlen = 0;
+    SV *packsv;
 
     if (id->op_type != OP_CONST)
        Perl_croak(aTHX_ "Module name must be constant");
@@ -3274,6 +3290,15 @@ Perl_utilize(pTHX_ int aver, I32 floor, OP *version, OP *id, OP *arg)
                                   newSVOP(OP_METHOD_NAMED, 0, meth)));
     }
 
+    if (ckWARN(WARN_MISC) &&
+        imop && (imop != arg) && /* no warning on use 5.0; or explicit () */
+        SvPOK(packsv = ((SVOP*)id)->op_sv))
+    {
+        /* BEGIN will free the ops, so we need to make a copy */
+        packlen = SvCUR(packsv);
+        packname = savepvn(SvPVX(packsv), packlen);
+    }
+
     /* Fake up the BEGIN {}, which does its thing immediately. */
     newATTRSUB(floor,
        newSVOP(OP_CONST, 0, newSVpvn("BEGIN", 5)),
@@ -3285,6 +3310,15 @@ Perl_utilize(pTHX_ int aver, I32 floor, OP *version, OP *id, OP *arg)
                newSTATEOP(0, Nullch, veop)),
            newSTATEOP(0, Nullch, imop) ));
 
+    if (packname) {
+        if (ckWARN(WARN_MISC) && !gv_stashpvn(packname, packlen, FALSE)) {
+            Perl_warner(aTHX_ WARN_MISC,
+                        "Package `%s' not found "
+                        "(did you use the incorrect case?)", packname);
+        }
+        safefree(packname);
+    }
+
     PL_hints |= HINT_BLOCK_SCOPE;
     PL_copline = NOLINE;
     PL_expect = XSTATE;
@@ -4750,6 +4784,8 @@ Perl_newATTRSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block)
        }
        /* ... before we throw it away */
        SvREFCNT_dec(PL_compcv);
+       if (PERLDB_INTER)/* Advice debugger on the new sub. */
+         ++PL_sub_generation;
     }
     else {
        cv = PL_compcv;
@@ -4809,7 +4845,7 @@ Perl_newATTRSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block)
     OpREFCNT_set(CvROOT(cv), 1);
     CvSTART(cv) = LINKLIST(CvROOT(cv));
     CvROOT(cv)->op_next = 0;
-    peep(CvSTART(cv));
+    CALL_PEEP(CvSTART(cv));
 
     /* now that optimizer has done its work, adjust pad values */
     if (CvCLONE(cv)) {
@@ -5150,7 +5186,7 @@ Perl_newFORM(pTHX_ I32 floor, OP *o, OP *block)
     OpREFCNT_set(CvROOT(cv), 1);
     CvSTART(cv) = LINKLIST(CvROOT(cv));
     CvROOT(cv)->op_next = 0;
-    peep(CvSTART(cv));
+    CALL_PEEP(CvSTART(cv));
     op_free(o);
     PL_copline = NOLINE;
     LEAVE_SCOPE(floor);
@@ -6323,7 +6359,7 @@ Perl_ck_sort(pTHX_ OP *o)
                    kid->op_next = 0;           /* just disconnect the leave */
                k = kLISTOP->op_first;
            }
-           peep(k);
+           CALL_PEEP(k);
 
            kid = firstkid;
            if (o->op_type == OP_SORT) {
@@ -6779,7 +6815,15 @@ Perl_peep(pTHX_ register OP *o)
            {
                PL_curcop = ((COP*)o);
            }
-           goto nothin;
+           /* XXX: We avoid setting op_seq here to prevent later calls
+              to peep() from mistakenly concluding that optimisation
+              has already occurred. This doesn't fix the real problem,
+              though (See 20010220.007). AMS 20010719 */
+           if (oldop && o->op_next) {
+               oldop->op_next = o->op_next;
+               continue;
+           }
+           break;
        case OP_SCALAR:
        case OP_LINESEQ:
        case OP_SCOPE:
@@ -6853,7 +6897,7 @@ Perl_peep(pTHX_ register OP *o)
            o->op_seq = PL_op_seqmax++;
            while (cLOGOP->op_other->op_type == OP_NULL)
                cLOGOP->op_other = cLOGOP->op_other->op_next;
-           peep(cLOGOP->op_other);
+           peep(cLOGOP->op_other); /* Recursive calls are not replaced by fptr calls */
            break;
 
        case OP_ENTERLOOP: