This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
https://perl5.git.perl.org / perl5.git / blobdiff
? search:
summary | shortlog | log | commit | commitdiff | tree
raw | inline | side by side
do FILE should not see outside lexicals (from Rick Delaney
[perl5.git] / pp_ctl.c
diff --git a/pp_ctl.c b/pp_ctl.c
index 24fad37..42811f5 100644 (file)
--- a/pp_ctl.c
+++ b/pp_ctl.c
@@ -859,7 +859,7 @@ PP(pp_sort)
     up = myorigmark + 1;
     while (MARK < SP) {        /* This may or may not shift down one here. */
        /*SUPPRESS 560*/
-       if (*up = *++MARK) {                    /* Weed out nulls. */
+       if ((*up = *++MARK)) {                  /* Weed out nulls. */
            SvTEMP_off(*up);
            if (!PL_sortcop && !SvPOK(*up)) {
                STRLEN n_a;
@@ -1075,28 +1075,28 @@ S_dopoptolabel(pTHX_ char *label)
        cx = &cxstack[i];
        switch (CxTYPE(cx)) {
        case CXt_SUBST:
-           if (ckWARN(WARN_UNSAFE))
-               Perl_warner(aTHX_ WARN_UNSAFE, "Exiting substitution via %s", 
+           if (ckWARN(WARN_EXITING))
+               Perl_warner(aTHX_ WARN_EXITING, "Exiting substitution via %s", 
                        PL_op_name[PL_op->op_type]);
            break;
        case CXt_SUB:
-           if (ckWARN(WARN_UNSAFE))
-               Perl_warner(aTHX_ WARN_UNSAFE, "Exiting subroutine via %s", 
+           if (ckWARN(WARN_EXITING))
+               Perl_warner(aTHX_ WARN_EXITING, "Exiting subroutine via %s", 
                        PL_op_name[PL_op->op_type]);
            break;
        case CXt_FORMAT:
-           if (ckWARN(WARN_UNSAFE))
-               Perl_warner(aTHX_ WARN_UNSAFE, "Exiting format via %s", 
+           if (ckWARN(WARN_EXITING))
+               Perl_warner(aTHX_ WARN_EXITING, "Exiting format via %s", 
                        PL_op_name[PL_op->op_type]);
            break;
        case CXt_EVAL:
-           if (ckWARN(WARN_UNSAFE))
-               Perl_warner(aTHX_ WARN_UNSAFE, "Exiting eval via %s", 
+           if (ckWARN(WARN_EXITING))
+               Perl_warner(aTHX_ WARN_EXITING, "Exiting eval via %s", 
                        PL_op_name[PL_op->op_type]);
            break;
        case CXt_NULL:
-           if (ckWARN(WARN_UNSAFE))
-               Perl_warner(aTHX_ WARN_UNSAFE, "Exiting pseudo-block via %s", 
+           if (ckWARN(WARN_EXITING))
+               Perl_warner(aTHX_ WARN_EXITING, "Exiting pseudo-block via %s", 
                        PL_op_name[PL_op->op_type]);
            return -1;
        case CXt_LOOP:
@@ -1201,28 +1201,28 @@ S_dopoptoloop(pTHX_ I32 startingblock)
        cx = &cxstack[i];
        switch (CxTYPE(cx)) {
        case CXt_SUBST:
-           if (ckWARN(WARN_UNSAFE))
-               Perl_warner(aTHX_ WARN_UNSAFE, "Exiting substitution via %s", 
+           if (ckWARN(WARN_EXITING))
+               Perl_warner(aTHX_ WARN_EXITING, "Exiting substitution via %s", 
                        PL_op_name[PL_op->op_type]);
            break;
        case CXt_SUB:
-           if (ckWARN(WARN_UNSAFE))
-               Perl_warner(aTHX_ WARN_UNSAFE, "Exiting subroutine via %s", 
+           if (ckWARN(WARN_EXITING))
+               Perl_warner(aTHX_ WARN_EXITING, "Exiting subroutine via %s", 
                        PL_op_name[PL_op->op_type]);
            break;
        case CXt_FORMAT:
-           if (ckWARN(WARN_UNSAFE))
-               Perl_warner(aTHX_ WARN_UNSAFE, "Exiting format via %s", 
+           if (ckWARN(WARN_EXITING))
+               Perl_warner(aTHX_ WARN_EXITING, "Exiting format via %s", 
                        PL_op_name[PL_op->op_type]);
            break;
        case CXt_EVAL:
-           if (ckWARN(WARN_UNSAFE))
-               Perl_warner(aTHX_ WARN_UNSAFE, "Exiting eval via %s", 
+           if (ckWARN(WARN_EXITING))
+               Perl_warner(aTHX_ WARN_EXITING, "Exiting eval via %s", 
                        PL_op_name[PL_op->op_type]);
            break;
        case CXt_NULL:
-           if (ckWARN(WARN_UNSAFE))
-               Perl_warner(aTHX_ WARN_UNSAFE, "Exiting pseudo-block via %s", 
+           if (ckWARN(WARN_EXITING))
+               Perl_warner(aTHX_ WARN_EXITING, "Exiting pseudo-block via %s", 
                        PL_op_name[PL_op->op_type]);
            return -1;
        case CXt_LOOP:
@@ -1238,7 +1238,6 @@ Perl_dounwind(pTHX_ I32 cxix)
 {
     dTHR;
     register PERL_CONTEXT *cx;
-    SV **newsp;
     I32 optype;
 
     while (cxstack_ix > cxix) {
@@ -1322,7 +1321,6 @@ Perl_qerror(pTHX_ SV *err)
 OP *
 Perl_die_where(pTHX_ char *message, STRLEN msglen)
 {
-    dSP;
     STRLEN n_a;
     if (PL_in_eval) {
        I32 cxix;
@@ -1347,9 +1345,9 @@ Perl_die_where(pTHX_ char *message, STRLEN msglen)
                    SvGROW(err, SvCUR(err)+sizeof(prefix)+msglen);
                    sv_catpvn(err, prefix, sizeof(prefix)-1);
                    sv_catpvn(err, message, msglen);
-                   if (ckWARN(WARN_UNSAFE)) {
+                   if (ckWARN(WARN_MISC)) {
                        STRLEN start = SvCUR(err)-msglen-sizeof(prefix)+1;
-                       Perl_warner(aTHX_ WARN_UNSAFE, SvPVX(err)+start);
+                       Perl_warner(aTHX_ WARN_MISC, SvPVX(err)+start);
                    }
                }
            }
@@ -1456,7 +1454,7 @@ PP(pp_caller)
 
     if (MAXARG)
        count = POPi;
-    EXTEND(SP, 7);
+    EXTEND(SP, 10);
     for (;;) {
        /* we may be in a higher stacklevel, so dig down deeper */
        while (cxix < 0 && top_si->si_type != PERLSI_MAIN) {
@@ -1561,6 +1559,17 @@ PP(pp_caller)
      * use the global PL_hints) */
     PUSHs(sv_2mortal(newSViv((I32)cx->blk_oldcop->op_private &
                             HINT_PRIVATE_MASK)));
+    {
+       SV * mask ;
+       SV * old_warnings = cx->blk_oldcop->cop_warnings ;
+       if  (old_warnings == WARN_NONE || old_warnings == WARN_STD)
+            mask = newSVpvn(WARN_NONEstring, WARNsize) ;
+        else if (old_warnings == WARN_ALL)
+            mask = newSVpvn(WARN_ALLstring, WARNsize) ;
+        else
+            mask = newSVsv(old_warnings);
+        PUSHs(sv_2mortal(mask));
+    }
     RETURN;
 }
 
@@ -1972,17 +1981,14 @@ PP(pp_next)
     if (cxix < cxstack_ix)
        dounwind(cxix);
 
-    cx = &cxstack[cxstack_ix];
-    {
-       OP *nextop = cx->blk_loop.next_op;
-       /* clean scope, but only if there's no continue block */
-       if (nextop == cUNOPx(cx->blk_loop.last_op)->op_first->op_next) {
-           TOPBLOCK(cx);
-           oldsave = PL_scopestack[PL_scopestack_ix - 1];
-           LEAVE_SCOPE(oldsave);
-       }
-       return nextop;
+    TOPBLOCK(cx);
+
+    /* clean scope, but only if there's no continue block */
+    if (!(cx->blk_loop.last_op->op_private & OPpLOOP_CONTINUE)) {
+       oldsave = PL_scopestack[PL_scopestack_ix - 1];
+       LEAVE_SCOPE(oldsave);
     }
+    return cx->blk_loop.next_op;
 }
 
 PP(pp_redo)
@@ -2045,7 +2051,7 @@ S_dofindlabel(pTHX_ OP *o, char *label, OP **opstack, OP **oplimit)
                 (ops[-1]->op_type != OP_NEXTSTATE &&
                  ops[-1]->op_type != OP_DBSTATE)))
                *ops++ = kid;
-           if (o = dofindlabel(kid, label, ops, oplimit))
+           if ((o = dofindlabel(kid, label, ops, oplimit)))
                return o;
        }
     }
@@ -2139,7 +2145,6 @@ PP(pp_goto)
            }
            else if (CvXSUB(cv)) {      /* put GvAV(defgv) back onto stack */
                AV* av;
-               int i;
 #ifdef USE_THREADS
                av = (AV*)PL_curpad[0];
 #else
@@ -2380,10 +2385,12 @@ PP(pp_goto)
                gotoprobe = PL_main_root;
                break;
            }
-           retop = dofindlabel(gotoprobe, label,
-                               enterops, enterops + GOTO_DEPTH);
-           if (retop)
-               break;
+           if (gotoprobe) {
+               retop = dofindlabel(gotoprobe, label,
+                                   enterops, enterops + GOTO_DEPTH);
+               if (retop)
+                   break;
+           }
            PL_lastgotoprobe = gotoprobe;
        }
        if (!retop)
@@ -2592,7 +2599,7 @@ Perl_sv_compile_2op(pTHX_ SV *sv, OP** startop, char *code, AV** avp)
     I32 gimme = 0;   /* SUSPECT - INITIALZE TO WHAT?  NI-S */
     I32 optype;
     OP dummy;
-    OP *oop = PL_op, *rop;
+    OP *rop;
     char tbuf[TYPE_DIGITS(long) + 12 + 10];
     char *tmpbuf = tbuf;
     char *safestr;
@@ -2720,8 +2727,11 @@ S_doeval(pTHX_ int gimme, OP** startop)
     av_store(comppadlist, 1, (SV*)PL_comppad);
     CvPADLIST(PL_compcv) = comppadlist;
 
-    if (!saveop || saveop->op_type != OP_REQUIRE)
+    if (!saveop ||
+       (saveop->op_type != OP_REQUIRE && saveop->op_type != OP_DOFILE))
+    {
        CvOUTSIDE(PL_compcv) = (CV*)SvREFCNT_inc(caller);
+    }
 
     SAVEFREESV(PL_compcv);
 
@@ -2920,15 +2930,17 @@ PP(pp_require)
            }
        }
        else if (!SvPOKp(sv)) {                 /* require 5.005_03 */
-           NV n = SvNV(sv);
-           rev = (UV)n;
-           ver = (UV)((n-rev)*1000);
-           sver = (UV)((((n-rev)*1000 - ver) + 0.0009) * 1000);
-
            if ((NV)PERL_REVISION + ((NV)PERL_VERSION/(NV)1000)
                + ((NV)PERL_SUBVERSION/(NV)1000000)
                + 0.00000099 < SvNV(sv))
            {
+               NV nrev = SvNV(sv);
+               UV rev = (UV)nrev;
+               NV nver = (nrev - rev) * 1000;
+               UV ver = (UV)(nver + 0.0009);
+               NV nsver = (nver - ver) * 1000;
+               UV sver = (UV)(nsver + 0.0009);
+
                DIE(aTHX_ "Perl v%"UVuf".%"UVuf".%"UVuf" required--this is only version "
                    "v%d.%d.%d, stopped", rev, ver, sver, PERL_REVISION,
                    PERL_VERSION, PERL_SUBVERSION);
@@ -3987,7 +3999,7 @@ S_qsortsv(pTHX_ SV ** array, size_t num_elts, SVCOMPARE_t compare)
                on the correct side of the partition. If I find a greater
                value, then stop the scan.
             */
-            while (still_work_on_left = (u_right >= part_left)) {
+            while ((still_work_on_left = (u_right >= part_left))) {
                s = qsort_cmp(u_right, pc_left);
                if (s < 0) {
                   --u_right;
@@ -4008,7 +4020,7 @@ S_qsortsv(pTHX_ SV ** array, size_t num_elts, SVCOMPARE_t compare)
 
             /* Do a mirror image scan of uncompared values on the right
             */
-            while (still_work_on_right = (u_left <= part_right)) {
+            while ((still_work_on_right = (u_left <= part_right))) {
                s = qsort_cmp(pc_right, u_left);
                if (s < 0) {
                   ++u_left;
Unnamed repository; edit this file 'description' to name the repository.