pp_ctl.c

   1 /*    pp_ctl.c
   2  *
   3  *    Copyright (C) 1991, 1992, 1993, 1994, 1995, 1996, 1997, 1998, 1999, 2000,
   4  *    2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008 by Larry Wall and others
   5  *
   6  *    You may distribute under the terms of either the GNU General Public
   7  *    License or the Artistic License, as specified in the README file.
   8  *
   9  */
  10
  11 /*
  12  *      Now far ahead the Road has gone,
  13  *          And I must follow, if I can,
  14  *      Pursuing it with eager feet,
  15  *          Until it joins some larger way
  16  *      Where many paths and errands meet.
  17  *          And whither then?  I cannot say.
  18  *
  19  *     [Bilbo on p.35 of _The Lord of the Rings_, I/i: "A Long-Expected Party"]
  20  */
  21
  22 /* This file contains control-oriented pp ("push/pop") functions that
  23  * execute the opcodes that make up a perl program. A typical pp function
  24  * expects to find its arguments on the stack, and usually pushes its
  25  * results onto the stack, hence the 'pp' terminology. Each OP structure
  26  * contains a pointer to the relevant pp_foo() function.
  27  *
  28  * Control-oriented means things like pp_enteriter() and pp_next(), which
  29  * alter the flow of control of the program.
  30  */
  31
  32
  33 #include "EXTERN.h"
  34 #define PERL_IN_PP_CTL_C
  35 #include "perl.h"
  36
  37 #ifndef WORD_ALIGN
  38 #define WORD_ALIGN sizeof(U32)
  39 #endif
  40
  41 #define DOCATCH(o) ((CATCH_GET == TRUE) ? docatch(o) : (o))
  42
  43 #define dopoptosub(plop)        dopoptosub_at(cxstack, (plop))
  44
  45 PP(pp_wantarray)
  46 {
  47     dVAR;
  48     dSP;
  49     I32 cxix;
  50     EXTEND(SP, 1);
  51
  52     cxix = dopoptosub(cxstack_ix);
  53     if (cxix < 0)
  54         RETPUSHUNDEF;
  55
  56     switch (cxstack[cxix].blk_gimme) {
  57     case G_ARRAY:
  58         RETPUSHYES;
  59     case G_SCALAR:
  60         RETPUSHNO;
  61     default:
  62         RETPUSHUNDEF;
  63     }
  64 }
  65
  66 PP(pp_regcreset)
  67 {
  68     dVAR;
  69     /* XXXX Should store the old value to allow for tie/overload - and
  70        restore in regcomp, where marked with XXXX. */
  71     PL_reginterp_cnt = 0;
  72     TAINT_NOT;
  73     return NORMAL;
  74 }
  75
  76 PP(pp_regcomp)
  77 {
  78     dVAR;
  79     dSP;
  80     register PMOP *pm = (PMOP*)cLOGOP->op_other;
  81     SV *tmpstr;
  82     REGEXP *re = NULL;
  83
  84     /* prevent recompiling under /o and ithreads. */
  85 #if defined(USE_ITHREADS)
  86     if (pm->op_pmflags & PMf_KEEP && PM_GETRE(pm)) {
  87         if (PL_op->op_flags & OPf_STACKED) {
  88             dMARK;
  89             SP = MARK;
  90         }
  91         else
  92             (void)POPs;
  93         RETURN;
  94     }
  95 #endif
  96
  97 #define tryAMAGICregexp(rx)                     \
  98     STMT_START {                                \
  99         if (SvROK(rx) && SvAMAGIC(rx)) {        \
 100             SV *sv = AMG_CALLun(rx, regexp);    \
 101             if (sv) {                           \
 102                 if (SvROK(sv))                  \
 103                     sv = SvRV(sv);              \
 104                 if (SvTYPE(sv) != SVt_REGEXP)   \
 105                     Perl_croak(aTHX_ "Overloaded qr did not return a REGEXP"); \
 106                 rx = sv;                        \
 107             }                                   \
 108         }                                       \
 109     } STMT_END
 110
 111
 112     if (PL_op->op_flags & OPf_STACKED) {
 113         /* multiple args; concatentate them */
 114         dMARK; dORIGMARK;
 115         tmpstr = PAD_SV(ARGTARG);
 116         sv_setpvs(tmpstr, "");
 117         while (++MARK <= SP) {
 118             SV *msv = *MARK;
 119             if (PL_amagic_generation) {
 120                 SV *sv;
 121
 122                 tryAMAGICregexp(msv);
 123
 124                 if ((SvAMAGIC(tmpstr) || SvAMAGIC(msv)) &&
 125                     (sv = amagic_call(tmpstr, msv, concat_amg, AMGf_assign)))
 126                 {
 127                    sv_setsv(tmpstr, sv);
 128                    continue;
 129                 }
 130             }
 131             sv_catsv(tmpstr, msv);
 132         }
 133         SvSETMAGIC(tmpstr);
 134         SP = ORIGMARK;
 135     }
 136     else {
 137         tmpstr = POPs;
 138         tryAMAGICregexp(tmpstr);
 139     }
 140
 141 #undef tryAMAGICregexp
 142
 143     if (SvROK(tmpstr)) {
 144         SV * const sv = SvRV(tmpstr);
 145         if (SvTYPE(sv) == SVt_REGEXP)
 146             re = (REGEXP*) sv;
 147     }
 148     else if (SvTYPE(tmpstr) == SVt_REGEXP)
 149         re = (REGEXP*) tmpstr;
 150
 151     if (re) {
 152         /* The match's LHS's get-magic might need to access this op's reg-
 153            exp (as is sometimes the case with $';  see bug 70764).  So we
 154            must call get-magic now before we replace the regexp. Hopeful-
 155            ly this hack can be replaced with the approach described at
 156            http://www.nntp.perl.org/group/perl.perl5.porters/2007/03
 157            /msg122415.html some day. */
 158         if(pm->op_type == OP_MATCH) {
 159          SV *lhs;
 160          const bool was_tainted = PL_tainted;
 161          if (pm->op_flags & OPf_STACKED)
 162             lhs = TOPs;
 163          else if (pm->op_private & OPpTARGET_MY)
 164             lhs = PAD_SV(pm->op_targ);
 165          else lhs = DEFSV;
 166          SvGETMAGIC(lhs);
 167          /* Restore the previous value of PL_tainted (which may have been
 168             modified by get-magic), to avoid incorrectly setting the
 169             RXf_TAINTED flag further down. */
 170          PL_tainted = was_tainted;
 171         }
 172
 173         re = reg_temp_copy(NULL, re);
 174         ReREFCNT_dec(PM_GETRE(pm));
 175         PM_SETRE(pm, re);
 176     }
 177     else {
 178         STRLEN len;
 179         const char *t = SvOK(tmpstr) ? SvPV_const(tmpstr, len) : "";
 180         re = PM_GETRE(pm);
 181         assert (re != (REGEXP*) &PL_sv_undef);
 182
 183         /* Check against the last compiled regexp. */
 184         if (!re || !RX_PRECOMP(re) || RX_PRELEN(re) != len ||
 185             memNE(RX_PRECOMP(re), t, len))
 186         {
 187             const regexp_engine *eng = re ? RX_ENGINE(re) : NULL;
 188             U32 pm_flags = pm->op_pmflags & PMf_COMPILETIME;
 189             if (re) {
 190                 ReREFCNT_dec(re);
 191 #ifdef USE_ITHREADS
 192                 PM_SETRE(pm, (REGEXP*) &PL_sv_undef);
 193 #else
 194                 PM_SETRE(pm, NULL);     /* crucial if regcomp aborts */
 195 #endif
 196             } else if (PL_curcop->cop_hints_hash) {
 197                 SV *ptr = Perl_refcounted_he_fetch(aTHX_ PL_curcop->cop_hints_hash, 0,
 198                                        "regcomp", 7, 0, 0);
 199                 if (ptr && SvIOK(ptr) && SvIV(ptr))
 200                     eng = INT2PTR(regexp_engine*,SvIV(ptr));
 201             }
 202
 203             if (PL_op->op_flags & OPf_SPECIAL)
 204                 PL_reginterp_cnt = I32_MAX; /* Mark as safe.  */
 205
 206             if (DO_UTF8(tmpstr)) {
 207                 assert (SvUTF8(tmpstr));
 208             } else if (SvUTF8(tmpstr)) {
 209                 /* Not doing UTF-8, despite what the SV says. Is this only if
 210                    we're trapped in use 'bytes'?  */
 211                 /* Make a copy of the octet sequence, but without the flag on,
 212                    as the compiler now honours the SvUTF8 flag on tmpstr.  */
 213                 STRLEN len;
 214                 const char *const p = SvPV(tmpstr, len);
 215                 tmpstr = newSVpvn_flags(p, len, SVs_TEMP);
 216             }
 217
 218                 if (eng)
 219                 PM_SETRE(pm, CALLREGCOMP_ENG(eng, tmpstr, pm_flags));
 220                 else
 221                 PM_SETRE(pm, CALLREGCOMP(tmpstr, pm_flags));
 222
 223             PL_reginterp_cnt = 0;       /* XXXX Be extra paranoid - needed
 224                                            inside tie/overload accessors.  */
 225         }
 226     }
 227
 228     re = PM_GETRE(pm);
 229
 230 #ifndef INCOMPLETE_TAINTS
 231     if (PL_tainting) {
 232         if (PL_tainted)
 233             RX_EXTFLAGS(re) |= RXf_TAINTED;
 234         else
 235             RX_EXTFLAGS(re) &= ~RXf_TAINTED;
 236     }
 237 #endif
 238
 239     if (!RX_PRELEN(PM_GETRE(pm)) && PL_curpm)
 240         pm = PL_curpm;
 241
 242
 243 #if !defined(USE_ITHREADS)
 244     /* can't change the optree at runtime either */
 245     /* PMf_KEEP is handled differently under threads to avoid these problems */
 246     if (pm->op_pmflags & PMf_KEEP) {
 247         pm->op_private &= ~OPpRUNTIME;  /* no point compiling again */
 248         cLOGOP->op_first->op_next = PL_op->op_next;
 249     }
 250 #endif
 251     RETURN;
 252 }
 253
 254 PP(pp_substcont)
 255 {
 256     dVAR;
 257     dSP;
 258     register PERL_CONTEXT *cx = &cxstack[cxstack_ix];
 259     register PMOP * const pm = (PMOP*) cLOGOP->op_other;
 260     register SV * const dstr = cx->sb_dstr;
 261     register char *s = cx->sb_s;
 262     register char *m = cx->sb_m;
 263     char *orig = cx->sb_orig;
 264     register REGEXP * const rx = cx->sb_rx;
 265     SV *nsv = NULL;
 266     REGEXP *old = PM_GETRE(pm);
 267
 268     PERL_ASYNC_CHECK();
 269
 270     if(old != rx) {
 271         if(old)
 272             ReREFCNT_dec(old);
 273         PM_SETRE(pm,ReREFCNT_inc(rx));
 274     }
 275
 276     rxres_restore(&cx->sb_rxres, rx);
 277     RX_MATCH_UTF8_set(rx, DO_UTF8(cx->sb_targ));
 278
 279     if (cx->sb_iters++) {
 280         const I32 saviters = cx->sb_iters;
 281         if (cx->sb_iters > cx->sb_maxiters)
 282             DIE(aTHX_ "Substitution loop");
 283
 284         SvGETMAGIC(TOPs); /* possibly clear taint on $1 etc: #67962 */
 285
 286         if (!(cx->sb_rxtainted & 2) && SvTAINTED(TOPs))
 287             cx->sb_rxtainted |= 2;
 288         sv_catsv_nomg(dstr, POPs);
 289         /* XXX: adjust for positive offsets of \G for instance s/(.)\G//g with positive pos() */
 290         s -= RX_GOFS(rx);
 291
 292         /* Are we done */
 293         if (CxONCE(cx) || s < orig ||
 294                 !CALLREGEXEC(rx, s, cx->sb_strend, orig,
 295                              (s == m) + RX_GOFS(rx), cx->sb_targ, NULL,
 296                              ((cx->sb_rflags & REXEC_COPY_STR)
 297                               ? (REXEC_IGNOREPOS|REXEC_NOT_FIRST)
 298                               : (REXEC_COPY_STR|REXEC_IGNOREPOS|REXEC_NOT_FIRST))))
 299         {
 300             SV * const targ = cx->sb_targ;
 301
 302             assert(cx->sb_strend >= s);
 303             if(cx->sb_strend > s) {
 304                  if (DO_UTF8(dstr) && !SvUTF8(targ))
 305                       sv_catpvn_utf8_upgrade(dstr, s, cx->sb_strend - s, nsv);
 306                  else
 307                       sv_catpvn(dstr, s, cx->sb_strend - s);
 308             }
 309             cx->sb_rxtainted |= RX_MATCH_TAINTED(rx);
 310
 311 #ifdef PERL_OLD_COPY_ON_WRITE
 312             if (SvIsCOW(targ)) {
 313                 sv_force_normal_flags(targ, SV_COW_DROP_PV);
 314             } else
 315 #endif
 316             {
 317                 SvPV_free(targ);
 318             }
 319             SvPV_set(targ, SvPVX(dstr));
 320             SvCUR_set(targ, SvCUR(dstr));
 321             SvLEN_set(targ, SvLEN(dstr));
 322             if (DO_UTF8(dstr))
 323                 SvUTF8_on(targ);
 324             SvPV_set(dstr, NULL);
 325
 326             TAINT_IF(cx->sb_rxtainted & 1);
 327             mPUSHi(saviters - 1);
 328
 329             (void)SvPOK_only_UTF8(targ);
 330             TAINT_IF(cx->sb_rxtainted);
 331             SvSETMAGIC(targ);
 332             SvTAINT(targ);
 333
 334             LEAVE_SCOPE(cx->sb_oldsave);
 335             POPSUBST(cx);
 336             RETURNOP(pm->op_next);
 337         }
 338         cx->sb_iters = saviters;
 339     }
 340     if (RX_MATCH_COPIED(rx) && RX_SUBBEG(rx) != orig) {
 341         m = s;
 342         s = orig;
 343         cx->sb_orig = orig = RX_SUBBEG(rx);
 344         s = orig + (m - s);
 345         cx->sb_strend = s + (cx->sb_strend - m);
 346     }
 347     cx->sb_m = m = RX_OFFS(rx)[0].start + orig;
 348     if (m > s) {
 349         if (DO_UTF8(dstr) && !SvUTF8(cx->sb_targ))
 350             sv_catpvn_utf8_upgrade(dstr, s, m - s, nsv);
 351         else
 352             sv_catpvn(dstr, s, m-s);
 353     }
 354     cx->sb_s = RX_OFFS(rx)[0].end + orig;
 355     { /* Update the pos() information. */
 356         SV * const sv = cx->sb_targ;
 357         MAGIC *mg;
 358         SvUPGRADE(sv, SVt_PVMG);
 359         if (!(mg = mg_find(sv, PERL_MAGIC_regex_global))) {
 360 #ifdef PERL_OLD_COPY_ON_WRITE
 361             if (SvIsCOW(sv))
 362                 sv_force_normal_flags(sv, 0);
 363 #endif
 364             mg = sv_magicext(sv, NULL, PERL_MAGIC_regex_global, &PL_vtbl_mglob,
 365                              NULL, 0);
 366         }
 367         mg->mg_len = m - orig;
 368     }
 369     if (old != rx)
 370         (void)ReREFCNT_inc(rx);
 371     cx->sb_rxtainted |= RX_MATCH_TAINTED(rx);
 372     rxres_save(&cx->sb_rxres, rx);
 373     RETURNOP(pm->op_pmstashstartu.op_pmreplstart);
 374 }
 375
 376 void
 377 Perl_rxres_save(pTHX_ void **rsp, REGEXP *rx)
 378 {
 379     UV *p = (UV*)*rsp;
 380     U32 i;
 381
 382     PERL_ARGS_ASSERT_RXRES_SAVE;
 383     PERL_UNUSED_CONTEXT;
 384
 385     if (!p || p[1] < RX_NPARENS(rx)) {
 386 #ifdef PERL_OLD_COPY_ON_WRITE
 387         i = 7 + RX_NPARENS(rx) * 2;
 388 #else
 389         i = 6 + RX_NPARENS(rx) * 2;
 390 #endif
 391         if (!p)
 392             Newx(p, i, UV);
 393         else
 394             Renew(p, i, UV);
 395         *rsp = (void*)p;
 396     }
 397
 398     *p++ = PTR2UV(RX_MATCH_COPIED(rx) ? RX_SUBBEG(rx) : NULL);
 399     RX_MATCH_COPIED_off(rx);
 400
 401 #ifdef PERL_OLD_COPY_ON_WRITE
 402     *p++ = PTR2UV(RX_SAVED_COPY(rx));
 403     RX_SAVED_COPY(rx) = NULL;
 404 #endif
 405
 406     *p++ = RX_NPARENS(rx);
 407
 408     *p++ = PTR2UV(RX_SUBBEG(rx));
 409     *p++ = (UV)RX_SUBLEN(rx);
 410     for (i = 0; i <= RX_NPARENS(rx); ++i) {
 411         *p++ = (UV)RX_OFFS(rx)[i].start;
 412         *p++ = (UV)RX_OFFS(rx)[i].end;
 413     }
 414 }
 415
 416 static void
 417 S_rxres_restore(pTHX_ void **rsp, REGEXP *rx)
 418 {
 419     UV *p = (UV*)*rsp;
 420     U32 i;
 421
 422     PERL_ARGS_ASSERT_RXRES_RESTORE;
 423     PERL_UNUSED_CONTEXT;
 424
 425     RX_MATCH_COPY_FREE(rx);
 426     RX_MATCH_COPIED_set(rx, *p);
 427     *p++ = 0;
 428
 429 #ifdef PERL_OLD_COPY_ON_WRITE
 430     if (RX_SAVED_COPY(rx))
 431         SvREFCNT_dec (RX_SAVED_COPY(rx));
 432     RX_SAVED_COPY(rx) = INT2PTR(SV*,*p);
 433     *p++ = 0;
 434 #endif
 435
 436     RX_NPARENS(rx) = *p++;
 437
 438     RX_SUBBEG(rx) = INT2PTR(char*,*p++);
 439     RX_SUBLEN(rx) = (I32)(*p++);
 440     for (i = 0; i <= RX_NPARENS(rx); ++i) {
 441         RX_OFFS(rx)[i].start = (I32)(*p++);
 442         RX_OFFS(rx)[i].end = (I32)(*p++);
 443     }
 444 }
 445
 446 static void
 447 S_rxres_free(pTHX_ void **rsp)
 448 {
 449     UV * const p = (UV*)*rsp;
 450
 451     PERL_ARGS_ASSERT_RXRES_FREE;
 452     PERL_UNUSED_CONTEXT;
 453
 454     if (p) {
 455 #ifdef PERL_POISON
 456         void *tmp = INT2PTR(char*,*p);
 457         Safefree(tmp);
 458         if (*p)
 459             PoisonFree(*p, 1, sizeof(*p));
 460 #else
 461         Safefree(INT2PTR(char*,*p));
 462 #endif
 463 #ifdef PERL_OLD_COPY_ON_WRITE
 464         if (p[1]) {
 465             SvREFCNT_dec (INT2PTR(SV*,p[1]));
 466         }
 467 #endif
 468         Safefree(p);
 469         *rsp = NULL;
 470     }
 471 }
 472
 473 PP(pp_formline)
 474 {
 475     dVAR; dSP; dMARK; dORIGMARK;
 476     register SV * const tmpForm = *++MARK;
 477     register U32 *fpc;
 478     register char *t;
 479     const char *f;
 480     register I32 arg;
 481     register SV *sv = NULL;
 482     const char *item = NULL;
 483     I32 itemsize  = 0;
 484     I32 fieldsize = 0;
 485     I32 lines = 0;
 486     bool chopspace = (strchr(PL_chopset, ' ') != NULL);
 487     const char *chophere = NULL;
 488     char *linemark = NULL;
 489     NV value;
 490     bool gotsome = FALSE;
 491     STRLEN len;
 492     const STRLEN fudge = SvPOK(tmpForm)
 493                         ? (SvCUR(tmpForm) * (IN_BYTES ? 1 : 3) + 1) : 0;
 494     bool item_is_utf8 = FALSE;
 495     bool targ_is_utf8 = FALSE;
 496     SV * nsv = NULL;
 497     OP * parseres = NULL;
 498     const char *fmt;
 499
 500     if (!SvMAGICAL(tmpForm) || !SvCOMPILED(tmpForm)) {
 501         if (SvREADONLY(tmpForm)) {
 502             SvREADONLY_off(tmpForm);
 503             parseres = doparseform(tmpForm);
 504             SvREADONLY_on(tmpForm);
 505         }
 506         else
 507             parseres = doparseform(tmpForm);
 508         if (parseres)
 509             return parseres;
 510     }
 511     SvPV_force(PL_formtarget, len);
 512     if (DO_UTF8(PL_formtarget))
 513         targ_is_utf8 = TRUE;
 514     t = SvGROW(PL_formtarget, len + fudge + 1);  /* XXX SvCUR bad */
 515     t += len;
 516     f = SvPV_const(tmpForm, len);
 517     /* need to jump to the next word */
 518     fpc = (U32*)(f + len + WORD_ALIGN - SvCUR(tmpForm) % WORD_ALIGN);
 519
 520     for (;;) {
 521         DEBUG_f( {
 522             const char *name = "???";
 523             arg = -1;
 524             switch (*fpc) {
 525             case FF_LITERAL:    arg = fpc[1]; name = "LITERAL"; break;
 526             case FF_BLANK:      arg = fpc[1]; name = "BLANK";   break;
 527             case FF_SKIP:       arg = fpc[1]; name = "SKIP";    break;
 528             case FF_FETCH:      arg = fpc[1]; name = "FETCH";   break;
 529             case FF_DECIMAL:    arg = fpc[1]; name = "DECIMAL"; break;
 530
 531             case FF_CHECKNL:    name = "CHECKNL";       break;
 532             case FF_CHECKCHOP:  name = "CHECKCHOP";     break;
 533             case FF_SPACE:      name = "SPACE";         break;
 534             case FF_HALFSPACE:  name = "HALFSPACE";     break;
 535             case FF_ITEM:       name = "ITEM";          break;
 536             case FF_CHOP:       name = "CHOP";          break;
 537             case FF_LINEGLOB:   name = "LINEGLOB";      break;
 538             case FF_NEWLINE:    name = "NEWLINE";       break;
 539             case FF_MORE:       name = "MORE";          break;
 540             case FF_LINEMARK:   name = "LINEMARK";      break;
 541             case FF_END:        name = "END";           break;
 542             case FF_0DECIMAL:   name = "0DECIMAL";      break;
 543             case FF_LINESNGL:   name = "LINESNGL";      break;
 544             }
 545             if (arg >= 0)
 546                 PerlIO_printf(Perl_debug_log, "%-16s%ld\n", name, (long) arg);
 547             else
 548                 PerlIO_printf(Perl_debug_log, "%-16s\n", name);
 549         } );
 550         switch (*fpc++) {
 551         case FF_LINEMARK:
 552             linemark = t;
 553             lines++;
 554             gotsome = FALSE;
 555             break;
 556
 557         case FF_LITERAL:
 558             arg = *fpc++;
 559             if (targ_is_utf8 && !SvUTF8(tmpForm)) {
 560                 SvCUR_set(PL_formtarget, t - SvPVX_const(PL_formtarget));
 561                 *t = '\0';
 562                 sv_catpvn_utf8_upgrade(PL_formtarget, f, arg, nsv);
 563                 t = SvEND(PL_formtarget);
 564                 f += arg;
 565                 break;
 566             }
 567             if (!targ_is_utf8 && DO_UTF8(tmpForm)) {
 568                 SvCUR_set(PL_formtarget, t - SvPVX_const(PL_formtarget));
 569                 *t = '\0';
 570                 sv_utf8_upgrade_flags_grow(PL_formtarget, SV_GMAGIC, fudge + 1);
 571                 t = SvEND(PL_formtarget);
 572                 targ_is_utf8 = TRUE;
 573             }
 574             while (arg--)
 575                 *t++ = *f++;
 576             break;
 577
 578         case FF_SKIP:
 579             f += *fpc++;
 580             break;
 581
 582         case FF_FETCH:
 583             arg = *fpc++;
 584             f += arg;
 585             fieldsize = arg;
 586
 587             if (MARK < SP)
 588                 sv = *++MARK;
 589             else {
 590                 sv = &PL_sv_no;
 591                 Perl_ck_warner(aTHX_ packWARN(WARN_SYNTAX), "Not enough format arguments");
 592             }
 593             break;
 594
 595         case FF_CHECKNL:
 596             {
 597                 const char *send;
 598                 const char *s = item = SvPV_const(sv, len);
 599                 itemsize = len;
 600                 if (DO_UTF8(sv)) {
 601                     itemsize = sv_len_utf8(sv);
 602                     if (itemsize != (I32)len) {
 603                         I32 itembytes;
 604                         if (itemsize > fieldsize) {
 605                             itemsize = fieldsize;
 606                             itembytes = itemsize;
 607                             sv_pos_u2b(sv, &itembytes, 0);
 608                         }
 609                         else
 610                             itembytes = len;
 611                         send = chophere = s + itembytes;
 612                         while (s < send) {
 613                             if (*s & ~31)
 614                                 gotsome = TRUE;
 615                             else if (*s == '\n')
 616                                 break;
 617                             s++;
 618                         }
 619                         item_is_utf8 = TRUE;
 620                         itemsize = s - item;
 621                         sv_pos_b2u(sv, &itemsize);
 622                         break;
 623                     }
 624                 }
 625                 item_is_utf8 = FALSE;
 626                 if (itemsize > fieldsize)
 627                     itemsize = fieldsize;
 628                 send = chophere = s + itemsize;
 629                 while (s < send) {
 630                     if (*s & ~31)
 631                         gotsome = TRUE;
 632                     else if (*s == '\n')
 633                         break;
 634                     s++;
 635                 }
 636                 itemsize = s - item;
 637                 break;
 638             }
 639
 640         case FF_CHECKCHOP:
 641             {
 642                 const char *s = item = SvPV_const(sv, len);
 643                 itemsize = len;
 644                 if (DO_UTF8(sv)) {
 645                     itemsize = sv_len_utf8(sv);
 646                     if (itemsize != (I32)len) {
 647                         I32 itembytes;
 648                         if (itemsize <= fieldsize) {
 649                             const char *send = chophere = s + itemsize;
 650                             while (s < send) {
 651                                 if (*s == '\r') {
 652                                     itemsize = s - item;
 653                                     chophere = s;
 654                                     break;
 655                                 }
 656                                 if (*s++ & ~31)
 657                                     gotsome = TRUE;
 658                             }
 659                         }
 660                         else {
 661                             const char *send;
 662                             itemsize = fieldsize;
 663                             itembytes = itemsize;
 664                             sv_pos_u2b(sv, &itembytes, 0);
 665                             send = chophere = s + itembytes;
 666                             while (s < send || (s == send && isSPACE(*s))) {
 667                                 if (isSPACE(*s)) {
 668                                     if (chopspace)
 669                                         chophere = s;
 670                                     if (*s == '\r')
 671                                         break;
 672                                 }
 673                                 else {
 674                                     if (*s & ~31)
 675                                         gotsome = TRUE;
 676                                     if (strchr(PL_chopset, *s))
 677                                         chophere = s + 1;
 678                                 }
 679                                 s++;
 680                             }
 681                             itemsize = chophere - item;
 682                             sv_pos_b2u(sv, &itemsize);
 683                         }
 684                         item_is_utf8 = TRUE;
 685                         break;
 686                     }
 687                 }
 688                 item_is_utf8 = FALSE;
 689                 if (itemsize <= fieldsize) {
 690                     const char *const send = chophere = s + itemsize;
 691                     while (s < send) {
 692                         if (*s == '\r') {
 693                             itemsize = s - item;
 694                             chophere = s;
 695                             break;
 696                         }
 697                         if (*s++ & ~31)
 698                             gotsome = TRUE;
 699                     }
 700                 }
 701                 else {
 702                     const char *send;
 703                     itemsize = fieldsize;
 704                     send = chophere = s + itemsize;
 705                     while (s < send || (s == send && isSPACE(*s))) {
 706                         if (isSPACE(*s)) {
 707                             if (chopspace)
 708                                 chophere = s;
 709                             if (*s == '\r')
 710                                 break;
 711                         }
 712                         else {
 713                             if (*s & ~31)
 714                                 gotsome = TRUE;
 715                             if (strchr(PL_chopset, *s))
 716                                 chophere = s + 1;
 717                         }
 718                         s++;
 719                     }
 720                     itemsize = chophere - item;
 721                 }
 722                 break;
 723             }
 724
 725         case FF_SPACE:
 726             arg = fieldsize - itemsize;
 727             if (arg) {
 728                 fieldsize -= arg;
 729                 while (arg-- > 0)
 730                     *t++ = ' ';
 731             }
 732             break;
 733
 734         case FF_HALFSPACE:
 735             arg = fieldsize - itemsize;
 736             if (arg) {
 737                 arg /= 2;
 738                 fieldsize -= arg;
 739                 while (arg-- > 0)
 740                     *t++ = ' ';
 741             }
 742             break;
 743
 744         case FF_ITEM:
 745             {
 746                 const char *s = item;
 747                 arg = itemsize;
 748                 if (item_is_utf8) {
 749                     if (!targ_is_utf8) {
 750                         SvCUR_set(PL_formtarget, t - SvPVX_const(PL_formtarget));
 751                         *t = '\0';
 752                         sv_utf8_upgrade_flags_grow(PL_formtarget, SV_GMAGIC,
 753                                                                     fudge + 1);
 754                         t = SvEND(PL_formtarget);
 755                         targ_is_utf8 = TRUE;
 756                     }
 757                     while (arg--) {
 758                         if (UTF8_IS_CONTINUED(*s)) {
 759                             STRLEN skip = UTF8SKIP(s);
 760                             switch (skip) {
 761                             default:
 762                                 Move(s,t,skip,char);
 763                                 s += skip;
 764                                 t += skip;
 765                                 break;
 766                             case 7: *t++ = *s++;
 767                             case 6: *t++ = *s++;
 768                             case 5: *t++ = *s++;
 769                             case 4: *t++ = *s++;
 770                             case 3: *t++ = *s++;
 771                             case 2: *t++ = *s++;
 772                             case 1: *t++ = *s++;
 773                             }
 774                         }
 775                         else {
 776                             if ( !((*t++ = *s++) & ~31) )
 777                                 t[-1] = ' ';
 778                         }
 779                     }
 780                     break;
 781                 }
 782                 if (targ_is_utf8 && !item_is_utf8) {
 783                     SvCUR_set(PL_formtarget, t - SvPVX_const(PL_formtarget));
 784                     *t = '\0';
 785                     sv_catpvn_utf8_upgrade(PL_formtarget, s, arg, nsv);
 786                     for (; t < SvEND(PL_formtarget); t++) {
 787 #ifdef EBCDIC
 788                         const int ch = *t;
 789                         if (iscntrl(ch))
 790 #else
 791                             if (!(*t & ~31))
 792 #endif
 793                                 *t = ' ';
 794                     }
 795                     break;
 796                 }
 797                 while (arg--) {
 798 #ifdef EBCDIC
 799                     const int ch = *t++ = *s++;
 800                     if (iscntrl(ch))
 801 #else
 802                         if ( !((*t++ = *s++) & ~31) )
 803 #endif
 804                             t[-1] = ' ';
 805                 }
 806                 break;
 807             }
 808
 809         case FF_CHOP:
 810             {
 811                 const char *s = chophere;
 812                 if (chopspace) {
 813                     while (isSPACE(*s))
 814                         s++;
 815                 }
 816                 sv_chop(sv,s);
 817                 SvSETMAGIC(sv);
 818                 break;
 819             }
 820
 821         case FF_LINESNGL:
 822             chopspace = 0;
 823         case FF_LINEGLOB:
 824             {
 825                 const bool oneline = fpc[-1] == FF_LINESNGL;
 826                 const char *s = item = SvPV_const(sv, len);
 827                 item_is_utf8 = DO_UTF8(sv);
 828                 itemsize = len;
 829                 if (itemsize) {
 830                     STRLEN to_copy = itemsize;
 831                     const char *const send = s + len;
 832                     const U8 *source = (const U8 *) s;
 833                     U8 *tmp = NULL;
 834
 835                     gotsome = TRUE;
 836                     chophere = s + itemsize;
 837                     while (s < send) {
 838                         if (*s++ == '\n') {
 839                             if (oneline) {
 840                                 to_copy = s - SvPVX_const(sv) - 1;
 841                                 chophere = s;
 842                                 break;
 843                             } else {
 844                                 if (s == send) {
 845                                     itemsize--;
 846                                     to_copy--;
 847                                 } else
 848                                     lines++;
 849                             }
 850                         }
 851                     }
 852                     if (targ_is_utf8 && !item_is_utf8) {
 853                         source = tmp = bytes_to_utf8(source, &to_copy);
 854                         SvCUR_set(PL_formtarget,
 855                                   t - SvPVX_const(PL_formtarget));
 856                     } else {
 857                         if (item_is_utf8 && !targ_is_utf8) {
 858                             /* Upgrade targ to UTF8, and then we reduce it to
 859                                a problem we have a simple solution for.  */
 860                             SvCUR_set(PL_formtarget,
 861                                       t - SvPVX_const(PL_formtarget));
 862                             targ_is_utf8 = TRUE;
 863                             /* Don't need get magic.  */
 864                             sv_utf8_upgrade_nomg(PL_formtarget);
 865                         } else {
 866                             SvCUR_set(PL_formtarget,
 867                                       t - SvPVX_const(PL_formtarget));
 868                         }
 869
 870                         /* Easy. They agree.  */
 871                         assert (item_is_utf8 == targ_is_utf8);
 872                     }
 873                     SvGROW(PL_formtarget,
 874                            SvCUR(PL_formtarget) + to_copy + fudge + 1);
 875                     t = SvPVX(PL_formtarget) + SvCUR(PL_formtarget);
 876
 877                     Copy(source, t, to_copy, char);
 878                     t += to_copy;
 879                     SvCUR_set(PL_formtarget, SvCUR(PL_formtarget) + to_copy);
 880                     if (item_is_utf8) {
 881                         if (SvGMAGICAL(sv)) {
 882                             /* Mustn't call sv_pos_b2u() as it does a second
 883                                mg_get(). Is this a bug? Do we need a _flags()
 884                                variant? */
 885                             itemsize = utf8_length(source, source + itemsize);
 886                         } else {
 887                             sv_pos_b2u(sv, &itemsize);
 888                         }
 889                         assert(!tmp);
 890                     } else if (tmp) {
 891                         Safefree(tmp);
 892                     }
 893                 }
 894                 break;
 895             }
 896
 897         case FF_0DECIMAL:
 898             arg = *fpc++;
 899 #if defined(USE_LONG_DOUBLE)
 900             fmt = (const char *)
 901                 ((arg & 256) ?
 902                  "%#0*.*" PERL_PRIfldbl : "%0*.*" PERL_PRIfldbl);
 903 #else
 904             fmt = (const char *)
 905                 ((arg & 256) ?
 906                  "%#0*.*f"              : "%0*.*f");
 907 #endif
 908             goto ff_dec;
 909         case FF_DECIMAL:
 910             arg = *fpc++;
 911 #if defined(USE_LONG_DOUBLE)
 912             fmt = (const char *)
 913                 ((arg & 256) ? "%#*.*" PERL_PRIfldbl : "%*.*" PERL_PRIfldbl);
 914 #else
 915             fmt = (const char *)
 916                 ((arg & 256) ? "%#*.*f"              : "%*.*f");
 917 #endif
 918         ff_dec:
 919             /* If the field is marked with ^ and the value is undefined,
 920                blank it out. */
 921             if ((arg & 512) && !SvOK(sv)) {
 922                 arg = fieldsize;
 923                 while (arg--)
 924                     *t++ = ' ';
 925                 break;
 926             }
 927             gotsome = TRUE;
 928             value = SvNV(sv);
 929             /* overflow evidence */
 930             if (num_overflow(value, fieldsize, arg)) {
 931                 arg = fieldsize;
 932                 while (arg--)
 933                     *t++ = '#';
 934                 break;
 935             }
 936             /* Formats aren't yet marked for locales, so assume "yes". */
 937             {
 938                 STORE_NUMERIC_STANDARD_SET_LOCAL();
 939                 my_snprintf(t, SvLEN(PL_formtarget) - (t - SvPVX(PL_formtarget)), fmt, (int) fieldsize, (int) arg & 255, value);
 940                 RESTORE_NUMERIC_STANDARD();
 941             }
 942             t += fieldsize;
 943             break;
 944
 945         case FF_NEWLINE:
 946             f++;
 947             while (t-- > linemark && *t == ' ') ;
 948             t++;
 949             *t++ = '\n';
 950             break;
 951
 952         case FF_BLANK:
 953             arg = *fpc++;
 954             if (gotsome) {
 955                 if (arg) {              /* repeat until fields exhausted? */
 956                     *t = '\0';
 957                     SvCUR_set(PL_formtarget, t - SvPVX_const(PL_formtarget));
 958                     lines += FmLINES(PL_formtarget);
 959                     if (targ_is_utf8)
 960                         SvUTF8_on(PL_formtarget);
 961                     FmLINES(PL_formtarget) = lines;
 962                     SP = ORIGMARK;
 963                     RETURNOP(cLISTOP->op_first);
 964                 }
 965             }
 966             else {
 967                 t = linemark;
 968                 lines--;
 969             }
 970             break;
 971
 972         case FF_MORE:
 973             {
 974                 const char *s = chophere;
 975                 const char *send = item + len;
 976                 if (chopspace) {
 977                     while (isSPACE(*s) && (s < send))
 978                         s++;
 979                 }
 980                 if (s < send) {
 981                     char *s1;
 982                     arg = fieldsize - itemsize;
 983                     if (arg) {
 984                         fieldsize -= arg;
 985                         while (arg-- > 0)
 986                             *t++ = ' ';
 987                     }
 988                     s1 = t - 3;
 989                     if (strnEQ(s1,"   ",3)) {
 990                         while (s1 > SvPVX_const(PL_formtarget) && isSPACE(s1[-1]))
 991                             s1--;
 992                     }
 993                     *s1++ = '.';
 994                     *s1++ = '.';
 995                     *s1++ = '.';
 996                 }
 997                 break;
 998             }
 999         case FF_END:
1000             *t = '\0';
1001             SvCUR_set(PL_formtarget, t - SvPVX_const(PL_formtarget));
1002             if (targ_is_utf8)
1003                 SvUTF8_on(PL_formtarget);
1004             FmLINES(PL_formtarget) += lines;
1005             SP = ORIGMARK;
1006             RETPUSHYES;
1007         }
1008     }
1009 }
1010
1011 PP(pp_grepstart)
1012 {
1013     dVAR; dSP;
1014     SV *src;
1015
1016     if (PL_stack_base + *PL_markstack_ptr == SP) {
1017         (void)POPMARK;
1018         if (GIMME_V == G_SCALAR)
1019             mXPUSHi(0);
1020         RETURNOP(PL_op->op_next->op_next);
1021     }
1022     PL_stack_sp = PL_stack_base + *PL_markstack_ptr + 1;
1023     pp_pushmark();                              /* push dst */
1024     pp_pushmark();                              /* push src */
1025     ENTER_with_name("grep");                                    /* enter outer scope */
1026
1027     SAVETMPS;
1028     if (PL_op->op_private & OPpGREP_LEX)
1029         SAVESPTR(PAD_SVl(PL_op->op_targ));
1030     else
1031         SAVE_DEFSV;
1032     ENTER_with_name("grep_item");                                       /* enter inner scope */
1033     SAVEVPTR(PL_curpm);
1034
1035     src = PL_stack_base[*PL_markstack_ptr];
1036     SvTEMP_off(src);
1037     if (PL_op->op_private & OPpGREP_LEX)
1038         PAD_SVl(PL_op->op_targ) = src;
1039     else
1040         DEFSV_set(src);
1041
1042     PUTBACK;
1043     if (PL_op->op_type == OP_MAPSTART)
1044         pp_pushmark();                  /* push top */
1045     return ((LOGOP*)PL_op->op_next)->op_other;
1046 }
1047
1048 PP(pp_mapwhile)
1049 {
1050     dVAR; dSP;
1051     const I32 gimme = GIMME_V;
1052     I32 items = (SP - PL_stack_base) - *PL_markstack_ptr; /* how many new items */
1053     I32 count;
1054     I32 shift;
1055     SV** src;
1056     SV** dst;
1057
1058     /* first, move source pointer to the next item in the source list */
1059     ++PL_markstack_ptr[-1];
1060
1061     /* if there are new items, push them into the destination list */
1062     if (items && gimme != G_VOID) {
1063         /* might need to make room back there first */
1064         if (items > PL_markstack_ptr[-1] - PL_markstack_ptr[-2]) {
1065             /* XXX this implementation is very pessimal because the stack
1066              * is repeatedly extended for every set of items.  Is possible
1067              * to do this without any stack extension or copying at all
1068              * by maintaining a separate list over which the map iterates
1069              * (like foreach does). --gsar */
1070
1071             /* everything in the stack after the destination list moves
1072              * towards the end the stack by the amount of room needed */
1073             shift = items - (PL_markstack_ptr[-1] - PL_markstack_ptr[-2]);
1074
1075             /* items to shift up (accounting for the moved source pointer) */
1076             count = (SP - PL_stack_base) - (PL_markstack_ptr[-1] - 1);
1077
1078             /* This optimization is by Ben Tilly and it does
1079              * things differently from what Sarathy (gsar)
1080              * is describing.  The downside of this optimization is
1081              * that leaves "holes" (uninitialized and hopefully unused areas)
1082              * to the Perl stack, but on the other hand this
1083              * shouldn't be a problem.  If Sarathy's idea gets
1084              * implemented, this optimization should become
1085              * irrelevant.  --jhi */
1086             if (shift < count)
1087                 shift = count; /* Avoid shifting too often --Ben Tilly */
1088
1089             EXTEND(SP,shift);
1090             src = SP;
1091             dst = (SP += shift);
1092             PL_markstack_ptr[-1] += shift;
1093             *PL_markstack_ptr += shift;
1094             while (count--)
1095                 *dst-- = *src--;
1096         }
1097         /* copy the new items down to the destination list */
1098         dst = PL_stack_base + (PL_markstack_ptr[-2] += items) - 1;
1099         if (gimme == G_ARRAY) {
1100             while (items-- > 0)
1101                 *dst-- = SvTEMP(TOPs) ? POPs : sv_mortalcopy(POPs);
1102         }
1103         else {
1104             /* scalar context: we don't care about which values map returns
1105              * (we use undef here). And so we certainly don't want to do mortal
1106              * copies of meaningless values. */
1107             while (items-- > 0) {
1108                 (void)POPs;
1109                 *dst-- = &PL_sv_undef;
1110             }
1111         }
1112     }
1113     LEAVE_with_name("grep_item");                                       /* exit inner scope */
1114
1115     /* All done yet? */
1116     if (PL_markstack_ptr[-1] > *PL_markstack_ptr) {
1117
1118         (void)POPMARK;                          /* pop top */
1119         LEAVE_with_name("grep");                                        /* exit outer scope */
1120         (void)POPMARK;                          /* pop src */
1121         items = --*PL_markstack_ptr - PL_markstack_ptr[-1];
1122         (void)POPMARK;                          /* pop dst */
1123         SP = PL_stack_base + POPMARK;           /* pop original mark */
1124         if (gimme == G_SCALAR) {
1125             if (PL_op->op_private & OPpGREP_LEX) {
1126                 SV* sv = sv_newmortal();
1127                 sv_setiv(sv, items);
1128                 PUSHs(sv);
1129             }
1130             else {
1131                 dTARGET;
1132                 XPUSHi(items);
1133             }
1134         }
1135         else if (gimme == G_ARRAY)
1136             SP += items;
1137         RETURN;
1138     }
1139     else {
1140         SV *src;
1141
1142         ENTER_with_name("grep_item");                                   /* enter inner scope */
1143         SAVEVPTR(PL_curpm);
1144
1145         /* set $_ to the new source item */
1146         src = PL_stack_base[PL_markstack_ptr[-1]];
1147         SvTEMP_off(src);
1148         if (PL_op->op_private & OPpGREP_LEX)
1149             PAD_SVl(PL_op->op_targ) = src;
1150         else
1151             DEFSV_set(src);
1152
1153         RETURNOP(cLOGOP->op_other);
1154     }
1155 }
1156
1157 /* Range stuff. */
1158
1159 PP(pp_range)
1160 {
1161     dVAR;
1162     if (GIMME == G_ARRAY)
1163         return NORMAL;
1164     if (SvTRUEx(PAD_SV(PL_op->op_targ)))
1165         return cLOGOP->op_other;
1166     else
1167         return NORMAL;
1168 }
1169
1170 PP(pp_flip)
1171 {
1172     dVAR;
1173     dSP;
1174
1175     if (GIMME == G_ARRAY) {
1176         RETURNOP(((LOGOP*)cUNOP->op_first)->op_other);
1177     }
1178     else {
1179         dTOPss;
1180         SV * const targ = PAD_SV(PL_op->op_targ);
1181         int flip = 0;
1182
1183         if (PL_op->op_private & OPpFLIP_LINENUM) {
1184             if (GvIO(PL_last_in_gv)) {
1185                 flip = SvIV(sv) == (IV)IoLINES(GvIOp(PL_last_in_gv));
1186             }
1187             else {
1188                 GV * const gv = gv_fetchpvs(".", GV_ADD|GV_NOTQUAL, SVt_PV);
1189                 if (gv && GvSV(gv))
1190                     flip = SvIV(sv) == SvIV(GvSV(gv));
1191             }
1192         } else {
1193             flip = SvTRUE(sv);
1194         }
1195         if (flip) {
1196             sv_setiv(PAD_SV(cUNOP->op_first->op_targ), 1);
1197             if (PL_op->op_flags & OPf_SPECIAL) {
1198                 sv_setiv(targ, 1);
1199                 SETs(targ);
1200                 RETURN;
1201             }
1202             else {
1203                 sv_setiv(targ, 0);
1204                 SP--;
1205                 RETURNOP(((LOGOP*)cUNOP->op_first)->op_other);
1206             }
1207         }
1208         sv_setpvs(TARG, "");
1209         SETs(targ);
1210         RETURN;
1211     }
1212 }
1213
1214 /* This code tries to decide if "$left .. $right" should use the
1215    magical string increment, or if the range is numeric (we make
1216    an exception for .."0" [#18165]). AMS 20021031. */
1217
1218 #define RANGE_IS_NUMERIC(left,right) ( \
1219         SvNIOKp(left)  || (SvOK(left)  && !SvPOKp(left))  || \
1220         SvNIOKp(right) || (SvOK(right) && !SvPOKp(right)) || \
1221         (((!SvOK(left) && SvOK(right)) || ((!SvOK(left) || \
1222           looks_like_number(left)) && SvPOKp(left) && *SvPVX_const(left) != '0')) \
1223          && (!SvOK(right) || looks_like_number(right))))
1224
1225 PP(pp_flop)
1226 {
1227     dVAR; dSP;
1228
1229     if (GIMME == G_ARRAY) {
1230         dPOPPOPssrl;
1231
1232         SvGETMAGIC(left);
1233         SvGETMAGIC(right);
1234
1235         if (RANGE_IS_NUMERIC(left,right)) {
1236             register IV i, j;
1237             IV max;
1238             if ((SvOK(left) && SvNV(left) < IV_MIN) ||
1239                 (SvOK(right) && SvNV(right) > IV_MAX))
1240                 DIE(aTHX_ "Range iterator outside integer range");
1241             i = SvIV(left);
1242             max = SvIV(right);
1243             if (max >= i) {
1244                 j = max - i + 1;
1245                 EXTEND_MORTAL(j);
1246                 EXTEND(SP, j);
1247             }
1248             else
1249                 j = 0;
1250             while (j--) {
1251                 SV * const sv = sv_2mortal(newSViv(i++));
1252                 PUSHs(sv);
1253             }
1254         }
1255         else {
1256             SV * const final = sv_mortalcopy(right);
1257             STRLEN len;
1258             const char * const tmps = SvPV_const(final, len);
1259
1260             SV *sv = sv_mortalcopy(left);
1261             SvPV_force_nolen(sv);
1262             while (!SvNIOKp(sv) && SvCUR(sv) <= len) {
1263                 XPUSHs(sv);
1264                 if (strEQ(SvPVX_const(sv),tmps))
1265                     break;
1266                 sv = sv_2mortal(newSVsv(sv));
1267                 sv_inc(sv);
1268             }
1269         }
1270     }
1271     else {
1272         dTOPss;
1273         SV * const targ = PAD_SV(cUNOP->op_first->op_targ);
1274         int flop = 0;
1275         sv_inc(targ);
1276
1277         if (PL_op->op_private & OPpFLIP_LINENUM) {
1278             if (GvIO(PL_last_in_gv)) {
1279                 flop = SvIV(sv) == (IV)IoLINES(GvIOp(PL_last_in_gv));
1280             }
1281             else {
1282                 GV * const gv = gv_fetchpvs(".", GV_ADD|GV_NOTQUAL, SVt_PV);
1283                 if (gv && GvSV(gv)) flop = SvIV(sv) == SvIV(GvSV(gv));
1284             }
1285         }
1286         else {
1287             flop = SvTRUE(sv);
1288         }
1289
1290         if (flop) {
1291             sv_setiv(PAD_SV(((UNOP*)cUNOP->op_first)->op_first->op_targ), 0);
1292             sv_catpvs(targ, "E0");
1293         }
1294         SETs(targ);
1295     }
1296
1297     RETURN;
1298 }
1299
1300 /* Control. */
1301
1302 static const char * const context_name[] = {
1303     "pseudo-block",
1304     NULL, /* CXt_WHEN never actually needs "block" */
1305     NULL, /* CXt_BLOCK never actually needs "block" */
1306     NULL, /* CXt_GIVEN never actually needs "block" */
1307     NULL, /* CXt_LOOP_FOR never actually needs "loop" */
1308     NULL, /* CXt_LOOP_PLAIN never actually needs "loop" */
1309     NULL, /* CXt_LOOP_LAZYSV never actually needs "loop" */
1310     NULL, /* CXt_LOOP_LAZYIV never actually needs "loop" */
1311     "subroutine",
1312     "format",
1313     "eval",
1314     "substitution",
1315 };
1316
1317 STATIC I32
1318 S_dopoptolabel(pTHX_ const char *label)
1319 {
1320     dVAR;
1321     register I32 i;
1322
1323     PERL_ARGS_ASSERT_DOPOPTOLABEL;
1324
1325     for (i = cxstack_ix; i >= 0; i--) {
1326         register const PERL_CONTEXT * const cx = &cxstack[i];
1327         switch (CxTYPE(cx)) {
1328         case CXt_SUBST:
1329         case CXt_SUB:
1330         case CXt_FORMAT:
1331         case CXt_EVAL:
1332         case CXt_NULL:
1333             Perl_ck_warner(aTHX_ packWARN(WARN_EXITING), "Exiting %s via %s",
1334                            context_name[CxTYPE(cx)], OP_NAME(PL_op));
1335             if (CxTYPE(cx) == CXt_NULL)
1336                 return -1;
1337             break;
1338         case CXt_LOOP_LAZYIV:
1339         case CXt_LOOP_LAZYSV:
1340         case CXt_LOOP_FOR:
1341         case CXt_LOOP_PLAIN:
1342           {
1343             const char *cx_label = CxLABEL(cx);
1344             if (!cx_label || strNE(label, cx_label) ) {
1345                 DEBUG_l(Perl_deb(aTHX_ "(poptolabel(): skipping label at cx=%ld %s)\n",
1346                         (long)i, cx_label));
1347                 continue;
1348             }
1349             DEBUG_l( Perl_deb(aTHX_ "(poptolabel(): found label at cx=%ld %s)\n", (long)i, label));
1350             return i;
1351           }
1352         }
1353     }
1354     return i;
1355 }
1356
1357
1358
1359 I32
1360 Perl_dowantarray(pTHX)
1361 {
1362     dVAR;
1363     const I32 gimme = block_gimme();
1364     return (gimme == G_VOID) ? G_SCALAR : gimme;
1365 }
1366
1367 I32
1368 Perl_block_gimme(pTHX)
1369 {
1370     dVAR;
1371     const I32 cxix = dopoptosub(cxstack_ix);
1372     if (cxix < 0)
1373         return G_VOID;
1374
1375     switch (cxstack[cxix].blk_gimme) {
1376     case G_VOID:
1377         return G_VOID;
1378     case G_SCALAR:
1379         return G_SCALAR;
1380     case G_ARRAY:
1381         return G_ARRAY;
1382     default:
1383         Perl_croak(aTHX_ "panic: bad gimme: %d\n", cxstack[cxix].blk_gimme);
1384         /* NOTREACHED */
1385         return 0;
1386     }
1387 }
1388
1389 I32
1390 Perl_is_lvalue_sub(pTHX)
1391 {
1392     dVAR;
1393     const I32 cxix = dopoptosub(cxstack_ix);
1394     assert(cxix >= 0);  /* We should only be called from inside subs */
1395
1396     if (CxLVAL(cxstack + cxix) && CvLVALUE(cxstack[cxix].blk_sub.cv))
1397         return CxLVAL(cxstack + cxix);
1398     else
1399         return 0;
1400 }
1401
1402 STATIC I32
1403 S_dopoptosub_at(pTHX_ const PERL_CONTEXT *cxstk, I32 startingblock)
1404 {
1405     dVAR;
1406     I32 i;
1407
1408     PERL_ARGS_ASSERT_DOPOPTOSUB_AT;
1409
1410     for (i = startingblock; i >= 0; i--) {
1411         register const PERL_CONTEXT * const cx = &cxstk[i];
1412         switch (CxTYPE(cx)) {
1413         default:
1414             continue;
1415         case CXt_EVAL:
1416         case CXt_SUB:
1417         case CXt_FORMAT:
1418             DEBUG_l( Perl_deb(aTHX_ "(dopoptosub_at(): found sub at cx=%ld)\n", (long)i));
1419             return i;
1420         }
1421     }
1422     return i;
1423 }
1424
1425 STATIC I32
1426 S_dopoptoeval(pTHX_ I32 startingblock)
1427 {
1428     dVAR;
1429     I32 i;
1430     for (i = startingblock; i >= 0; i--) {
1431         register const PERL_CONTEXT *cx = &cxstack[i];
1432         switch (CxTYPE(cx)) {
1433         default:
1434             continue;
1435         case CXt_EVAL:
1436             DEBUG_l( Perl_deb(aTHX_ "(dopoptoeval(): found eval at cx=%ld)\n", (long)i));
1437             return i;
1438         }
1439     }
1440     return i;
1441 }
1442
1443 STATIC I32
1444 S_dopoptoloop(pTHX_ I32 startingblock)
1445 {
1446     dVAR;
1447     I32 i;
1448     for (i = startingblock; i >= 0; i--) {
1449         register const PERL_CONTEXT * const cx = &cxstack[i];
1450         switch (CxTYPE(cx)) {
1451         case CXt_SUBST:
1452         case CXt_SUB:
1453         case CXt_FORMAT:
1454         case CXt_EVAL:
1455         case CXt_NULL:
1456             Perl_ck_warner(aTHX_ packWARN(WARN_EXITING), "Exiting %s via %s",
1457                            context_name[CxTYPE(cx)], OP_NAME(PL_op));
1458             if ((CxTYPE(cx)) == CXt_NULL)
1459                 return -1;
1460             break;
1461         case CXt_LOOP_LAZYIV:
1462         case CXt_LOOP_LAZYSV:
1463         case CXt_LOOP_FOR:
1464         case CXt_LOOP_PLAIN:
1465             DEBUG_l( Perl_deb(aTHX_ "(dopoptoloop(): found loop at cx=%ld)\n", (long)i));
1466             return i;
1467         }
1468     }
1469     return i;
1470 }
1471
1472 STATIC I32
1473 S_dopoptogiven(pTHX_ I32 startingblock)
1474 {
1475     dVAR;
1476     I32 i;
1477     for (i = startingblock; i >= 0; i--) {
1478         register const PERL_CONTEXT *cx = &cxstack[i];
1479         switch (CxTYPE(cx)) {
1480         default:
1481             continue;
1482         case CXt_GIVEN:
1483             DEBUG_l( Perl_deb(aTHX_ "(dopoptogiven(): found given at cx=%ld)\n", (long)i));
1484             return i;
1485         case CXt_LOOP_PLAIN:
1486             assert(!CxFOREACHDEF(cx));
1487             break;
1488         case CXt_LOOP_LAZYIV:
1489         case CXt_LOOP_LAZYSV:
1490         case CXt_LOOP_FOR:
1491             if (CxFOREACHDEF(cx)) {
1492                 DEBUG_l( Perl_deb(aTHX_ "(dopoptogiven(): found foreach at cx=%ld)\n", (long)i));
1493                 return i;
1494             }
1495         }
1496     }
1497     return i;
1498 }
1499
1500 STATIC I32
1501 S_dopoptowhen(pTHX_ I32 startingblock)
1502 {
1503     dVAR;
1504     I32 i;
1505     for (i = startingblock; i >= 0; i--) {
1506         register const PERL_CONTEXT *cx = &cxstack[i];
1507         switch (CxTYPE(cx)) {
1508         default:
1509             continue;
1510         case CXt_WHEN:
1511             DEBUG_l( Perl_deb(aTHX_ "(dopoptowhen(): found when at cx=%ld)\n", (long)i));
1512             return i;
1513         }
1514     }
1515     return i;
1516 }
1517
1518 void
1519 Perl_dounwind(pTHX_ I32 cxix)
1520 {
1521     dVAR;
1522     I32 optype;
1523
1524     while (cxstack_ix > cxix) {
1525         SV *sv;
1526         register PERL_CONTEXT *cx = &cxstack[cxstack_ix];
1527         DEBUG_CX("UNWIND");                                             \
1528         /* Note: we don't need to restore the base context info till the end. */
1529         switch (CxTYPE(cx)) {
1530         case CXt_SUBST:
1531             POPSUBST(cx);
1532             continue;  /* not break */
1533         case CXt_SUB:
1534             POPSUB(cx,sv);
1535             LEAVESUB(sv);
1536             break;
1537         case CXt_EVAL:
1538             POPEVAL(cx);
1539             break;
1540         case CXt_LOOP_LAZYIV:
1541         case CXt_LOOP_LAZYSV:
1542         case CXt_LOOP_FOR:
1543         case CXt_LOOP_PLAIN:
1544             POPLOOP(cx);
1545             break;
1546         case CXt_NULL:
1547             break;
1548         case CXt_FORMAT:
1549             POPFORMAT(cx);
1550             break;
1551         }
1552         cxstack_ix--;
1553     }
1554     PERL_UNUSED_VAR(optype);
1555 }
1556
1557 void
1558 Perl_qerror(pTHX_ SV *err)
1559 {
1560     dVAR;
1561
1562     PERL_ARGS_ASSERT_QERROR;
1563
1564     if (PL_in_eval)
1565         sv_catsv(ERRSV, err);
1566     else if (PL_errors)
1567         sv_catsv(PL_errors, err);
1568     else
1569         Perl_warn(aTHX_ "%"SVf, SVfARG(err));
1570     if (PL_parser)
1571         ++PL_parser->error_count;
1572 }
1573
1574 void
1575 Perl_die_unwind(pTHX_ SV *msv)
1576 {
1577     dVAR;
1578     SV *exceptsv = sv_mortalcopy(msv);
1579     U8 in_eval = PL_in_eval;
1580     PERL_ARGS_ASSERT_DIE_UNWIND;
1581
1582     if (in_eval) {
1583         I32 cxix;
1584         I32 gimme;
1585
1586         while ((cxix = dopoptoeval(cxstack_ix)) < 0
1587                && PL_curstackinfo->si_prev)
1588         {
1589             dounwind(-1);
1590             POPSTACK;
1591         }
1592
1593         if (cxix >= 0) {
1594             I32 optype;
1595             SV *namesv;
1596             register PERL_CONTEXT *cx;
1597             SV **newsp;
1598
1599             if (cxix < cxstack_ix)
1600                 dounwind(cxix);
1601
1602             POPBLOCK(cx,PL_curpm);
1603             if (CxTYPE(cx) != CXt_EVAL) {
1604                 STRLEN msglen;
1605                 const char* message = SvPVx_const(exceptsv, msglen);
1606                 PerlIO_write(Perl_error_log, (const char *)"panic: die ", 11);
1607                 PerlIO_write(Perl_error_log, message, msglen);
1608                 my_exit(1);
1609             }
1610             POPEVAL(cx);
1611             namesv = cx->blk_eval.old_namesv;
1612
1613             if (gimme == G_SCALAR)
1614                 *++newsp = &PL_sv_undef;
1615             PL_stack_sp = newsp;
1616
1617             LEAVE;
1618
1619             /* LEAVE could clobber PL_curcop (see save_re_context())
1620              * XXX it might be better to find a way to avoid messing with
1621              * PL_curcop in save_re_context() instead, but this is a more
1622              * minimal fix --GSAR */
1623             PL_curcop = cx->blk_oldcop;
1624
1625             if (optype == OP_REQUIRE) {
1626                 const char* const msg = SvPVx_nolen_const(exceptsv);
1627                 (void)hv_store(GvHVn(PL_incgv),
1628                                SvPVX_const(namesv), SvCUR(namesv),
1629                                &PL_sv_undef, 0);
1630                 /* note that unlike pp_entereval, pp_require isn't
1631                  * supposed to trap errors. So now that we've popped the
1632                  * EVAL that pp_require pushed, and processed the error
1633                  * message, rethrow the error */
1634                 DIE(aTHX_ "%sCompilation failed in require",
1635                     *msg ? msg : "Unknown error\n");
1636             }
1637             if (in_eval & EVAL_KEEPERR) {
1638                 Perl_ck_warner(aTHX_ packWARN(WARN_MISC), "\t(in cleanup) %s",
1639                                SvPV_nolen_const(exceptsv));
1640             }
1641             else {
1642                 sv_setsv(ERRSV, exceptsv);
1643             }
1644             assert(CxTYPE(cx) == CXt_EVAL);
1645             PL_restartjmpenv = cx->blk_eval.cur_top_env;
1646             PL_restartop = cx->blk_eval.retop;
1647             JMPENV_JUMP(3);
1648             /* NOTREACHED */
1649         }
1650     }
1651
1652     write_to_stderr(exceptsv);
1653     my_failure_exit();
1654     /* NOTREACHED */
1655 }
1656
1657 PP(pp_xor)
1658 {
1659     dVAR; dSP; dPOPTOPssrl;
1660     if (SvTRUE(left) != SvTRUE(right))
1661         RETSETYES;
1662     else
1663         RETSETNO;
1664 }
1665
1666 PP(pp_caller)
1667 {
1668     dVAR;
1669     dSP;
1670     register I32 cxix = dopoptosub(cxstack_ix);
1671     register const PERL_CONTEXT *cx;
1672     register const PERL_CONTEXT *ccstack = cxstack;
1673     const PERL_SI *top_si = PL_curstackinfo;
1674     I32 gimme;
1675     const char *stashname;
1676     I32 count = 0;
1677
1678     if (MAXARG)
1679         count = POPi;
1680
1681     for (;;) {
1682         /* we may be in a higher stacklevel, so dig down deeper */
1683         while (cxix < 0 && top_si->si_type != PERLSI_MAIN) {
1684             top_si = top_si->si_prev;
1685             ccstack = top_si->si_cxstack;
1686             cxix = dopoptosub_at(ccstack, top_si->si_cxix);
1687         }
1688         if (cxix < 0) {
1689             if (GIMME != G_ARRAY) {
1690                 EXTEND(SP, 1);
1691                 RETPUSHUNDEF;
1692             }
1693             RETURN;
1694         }
1695         /* caller() should not report the automatic calls to &DB::sub */
1696         if (PL_DBsub && GvCV(PL_DBsub) && cxix >= 0 &&
1697                 ccstack[cxix].blk_sub.cv == GvCV(PL_DBsub))
1698             count++;
1699         if (!count--)
1700             break;
1701         cxix = dopoptosub_at(ccstack, cxix - 1);
1702     }
1703
1704     cx = &ccstack[cxix];
1705     if (CxTYPE(cx) == CXt_SUB || CxTYPE(cx) == CXt_FORMAT) {
1706         const I32 dbcxix = dopoptosub_at(ccstack, cxix - 1);
1707         /* We expect that ccstack[dbcxix] is CXt_SUB, anyway, the
1708            field below is defined for any cx. */
1709         /* caller() should not report the automatic calls to &DB::sub */
1710         if (PL_DBsub && GvCV(PL_DBsub) && dbcxix >= 0 && ccstack[dbcxix].blk_sub.cv == GvCV(PL_DBsub))
1711             cx = &ccstack[dbcxix];
1712     }
1713
1714     stashname = CopSTASHPV(cx->blk_oldcop);
1715     if (GIMME != G_ARRAY) {
1716         EXTEND(SP, 1);
1717         if (!stashname)
1718             PUSHs(&PL_sv_undef);
1719         else {
1720             dTARGET;
1721             sv_setpv(TARG, stashname);
1722             PUSHs(TARG);
1723         }
1724         RETURN;
1725     }
1726
1727     EXTEND(SP, 11);
1728
1729     if (!stashname)
1730         PUSHs(&PL_sv_undef);
1731     else
1732         mPUSHs(newSVpv(stashname, 0));
1733     mPUSHs(newSVpv(OutCopFILE(cx->blk_oldcop), 0));
1734     mPUSHi((I32)CopLINE(cx->blk_oldcop));
1735     if (!MAXARG)
1736         RETURN;
1737     if (CxTYPE(cx) == CXt_SUB || CxTYPE(cx) == CXt_FORMAT) {
1738         GV * const cvgv = CvGV(ccstack[cxix].blk_sub.cv);
1739         /* So is ccstack[dbcxix]. */
1740         if (isGV(cvgv)) {
1741             SV * const sv = newSV(0);
1742             gv_efullname3(sv, cvgv, NULL);
1743             mPUSHs(sv);
1744             PUSHs(boolSV(CxHASARGS(cx)));
1745         }
1746         else {
1747             PUSHs(newSVpvs_flags("(unknown)", SVs_TEMP));
1748             PUSHs(boolSV(CxHASARGS(cx)));
1749         }
1750     }
1751     else {
1752         PUSHs(newSVpvs_flags("(eval)", SVs_TEMP));
1753         mPUSHi(0);
1754     }
1755     gimme = (I32)cx->blk_gimme;
1756     if (gimme == G_VOID)
1757         PUSHs(&PL_sv_undef);
1758     else
1759         PUSHs(boolSV((gimme & G_WANT) == G_ARRAY));
1760     if (CxTYPE(cx) == CXt_EVAL) {
1761         /* eval STRING */
1762         if (CxOLD_OP_TYPE(cx) == OP_ENTEREVAL) {
1763             PUSHs(cx->blk_eval.cur_text);
1764             PUSHs(&PL_sv_no);
1765         }
1766         /* require */
1767         else if (cx->blk_eval.old_namesv) {
1768             mPUSHs(newSVsv(cx->blk_eval.old_namesv));
1769             PUSHs(&PL_sv_yes);
1770         }
1771         /* eval BLOCK (try blocks have old_namesv == 0) */
1772         else {
1773             PUSHs(&PL_sv_undef);
1774             PUSHs(&PL_sv_undef);
1775         }
1776     }
1777     else {
1778         PUSHs(&PL_sv_undef);
1779         PUSHs(&PL_sv_undef);
1780     }
1781     if (CxTYPE(cx) == CXt_SUB && CxHASARGS(cx)
1782         && CopSTASH_eq(PL_curcop, PL_debstash))
1783     {
1784         AV * const ary = cx->blk_sub.argarray;
1785         const int off = AvARRAY(ary) - AvALLOC(ary);
1786
1787         if (!PL_dbargs) {
1788             PL_dbargs = GvAV(gv_AVadd(gv_fetchpvs("DB::args", GV_ADDMULTI,
1789                                                   SVt_PVAV)));
1790             AvREAL_off(PL_dbargs);      /* XXX should be REIFY (see av.h) */
1791         }
1792
1793         if (AvMAX(PL_dbargs) < AvFILLp(ary) + off)
1794             av_extend(PL_dbargs, AvFILLp(ary) + off);
1795         Copy(AvALLOC(ary), AvARRAY(PL_dbargs), AvFILLp(ary) + 1 + off, SV*);
1796         AvFILLp(PL_dbargs) = AvFILLp(ary) + off;
1797     }
1798     /* XXX only hints propagated via op_private are currently
1799      * visible (others are not easily accessible, since they
1800      * use the global PL_hints) */
1801     mPUSHi(CopHINTS_get(cx->blk_oldcop));
1802     {
1803         SV * mask ;
1804         STRLEN * const old_warnings = cx->blk_oldcop->cop_warnings ;
1805
1806         if  (old_warnings == pWARN_NONE ||
1807                 (old_warnings == pWARN_STD && (PL_dowarn & G_WARN_ON) == 0))
1808             mask = newSVpvn(WARN_NONEstring, WARNsize) ;
1809         else if (old_warnings == pWARN_ALL ||
1810                   (old_warnings == pWARN_STD && PL_dowarn & G_WARN_ON)) {
1811             /* Get the bit mask for $warnings::Bits{all}, because
1812              * it could have been extended by warnings::register */
1813             SV **bits_all;
1814             HV * const bits = get_hv("warnings::Bits", 0);
1815             if (bits && (bits_all=hv_fetchs(bits, "all", FALSE))) {
1816                 mask = newSVsv(*bits_all);
1817             }
1818             else {
1819                 mask = newSVpvn(WARN_ALLstring, WARNsize) ;
1820             }
1821         }
1822         else
1823             mask = newSVpvn((char *) (old_warnings + 1), old_warnings[0]);
1824         mPUSHs(mask);
1825     }
1826
1827     PUSHs(cx->blk_oldcop->cop_hints_hash ?
1828           sv_2mortal(newRV_noinc(
1829                                  MUTABLE_SV(Perl_refcounted_he_chain_2hv(aTHX_
1830                                               cx->blk_oldcop->cop_hints_hash))))
1831           : &PL_sv_undef);
1832     RETURN;
1833 }
1834
1835 PP(pp_reset)
1836 {
1837     dVAR;
1838     dSP;
1839     const char * const tmps = (MAXARG < 1) ? (const char *)"" : POPpconstx;
1840     sv_reset(tmps, CopSTASH(PL_curcop));
1841     PUSHs(&PL_sv_yes);
1842     RETURN;
1843 }
1844
1845 /* like pp_nextstate, but used instead when the debugger is active */
1846
1847 PP(pp_dbstate)
1848 {
1849     dVAR;
1850     PL_curcop = (COP*)PL_op;
1851     TAINT_NOT;          /* Each statement is presumed innocent */
1852     PL_stack_sp = PL_stack_base + cxstack[cxstack_ix].blk_oldsp;
1853     FREETMPS;
1854
1855     PERL_ASYNC_CHECK();
1856
1857     if (PL_op->op_flags & OPf_SPECIAL /* breakpoint */
1858             || SvIV(PL_DBsingle) || SvIV(PL_DBsignal) || SvIV(PL_DBtrace))
1859     {
1860         dSP;
1861         register PERL_CONTEXT *cx;
1862         const I32 gimme = G_ARRAY;
1863         U8 hasargs;
1864         GV * const gv = PL_DBgv;
1865         register CV * const cv = GvCV(gv);
1866
1867         if (!cv)
1868             DIE(aTHX_ "No DB::DB routine defined");
1869
1870         if (CvDEPTH(cv) >= 1 && !(PL_debug & DEBUG_DB_RECURSE_FLAG))
1871             /* don't do recursive DB::DB call */
1872             return NORMAL;
1873
1874         ENTER;
1875         SAVETMPS;
1876
1877         SAVEI32(PL_debug);
1878         SAVESTACK_POS();
1879         PL_debug = 0;
1880         hasargs = 0;
1881         SPAGAIN;
1882
1883         if (CvISXSUB(cv)) {
1884             CvDEPTH(cv)++;
1885             PUSHMARK(SP);
1886             (void)(*CvXSUB(cv))(aTHX_ cv);
1887             CvDEPTH(cv)--;
1888             FREETMPS;
1889             LEAVE;
1890             return NORMAL;
1891         }
1892         else {
1893             PUSHBLOCK(cx, CXt_SUB, SP);
1894             PUSHSUB_DB(cx);
1895             cx->blk_sub.retop = PL_op->op_next;
1896             CvDEPTH(cv)++;
1897             SAVECOMPPAD();
1898             PAD_SET_CUR_NOSAVE(CvPADLIST(cv), 1);
1899             RETURNOP(CvSTART(cv));
1900         }
1901     }
1902     else
1903         return NORMAL;
1904 }
1905
1906 PP(pp_enteriter)
1907 {
1908     dVAR; dSP; dMARK;
1909     register PERL_CONTEXT *cx;
1910     const I32 gimme = GIMME_V;
1911     SV **svp;
1912     U8 cxtype = CXt_LOOP_FOR;
1913 #ifdef USE_ITHREADS
1914     PAD *iterdata;
1915 #endif
1916
1917     ENTER_with_name("loop1");
1918     SAVETMPS;
1919
1920     if (PL_op->op_targ) {
1921         if (PL_op->op_private & OPpLVAL_INTRO) { /* for my $x (...) */
1922             SvPADSTALE_off(PAD_SVl(PL_op->op_targ));
1923             SAVESETSVFLAGS(PAD_SVl(PL_op->op_targ),
1924                     SVs_PADSTALE, SVs_PADSTALE);
1925         }
1926         SAVEPADSVANDMORTALIZE(PL_op->op_targ);
1927 #ifndef USE_ITHREADS
1928         svp = &PAD_SVl(PL_op->op_targ);         /* "my" variable */
1929 #else
1930         iterdata = NULL;
1931 #endif
1932     }
1933     else {
1934         GV * const gv = MUTABLE_GV(POPs);
1935         svp = &GvSV(gv);                        /* symbol table variable */
1936         SAVEGENERICSV(*svp);
1937         *svp = newSV(0);
1938 #ifdef USE_ITHREADS
1939         iterdata = (PAD*)gv;
1940 #endif
1941     }
1942
1943     if (PL_op->op_private & OPpITER_DEF)
1944         cxtype |= CXp_FOR_DEF;
1945
1946     ENTER_with_name("loop2");
1947
1948     PUSHBLOCK(cx, cxtype, SP);
1949 #ifdef USE_ITHREADS
1950     PUSHLOOP_FOR(cx, iterdata, MARK, PL_op->op_targ);
1951 #else
1952     PUSHLOOP_FOR(cx, svp, MARK, 0);
1953 #endif
1954     if (PL_op->op_flags & OPf_STACKED) {
1955         SV *maybe_ary = POPs;
1956         if (SvTYPE(maybe_ary) != SVt_PVAV) {
1957             dPOPss;
1958             SV * const right = maybe_ary;
1959             SvGETMAGIC(sv);
1960             SvGETMAGIC(right);
1961             if (RANGE_IS_NUMERIC(sv,right)) {
1962                 cx->cx_type &= ~CXTYPEMASK;
1963                 cx->cx_type |= CXt_LOOP_LAZYIV;
1964                 /* Make sure that no-one re-orders cop.h and breaks our
1965                    assumptions */
1966                 assert(CxTYPE(cx) == CXt_LOOP_LAZYIV);
1967 #ifdef NV_PRESERVES_UV
1968                 if ((SvOK(sv) && ((SvNV(sv) < (NV)IV_MIN) ||
1969                                   (SvNV(sv) > (NV)IV_MAX)))
1970                         ||
1971                     (SvOK(right) && ((SvNV(right) > (NV)IV_MAX) ||
1972                                      (SvNV(right) < (NV)IV_MIN))))
1973 #else
1974                 if ((SvOK(sv) && ((SvNV(sv) <= (NV)IV_MIN)
1975                                   ||
1976                                   ((SvNV(sv) > 0) &&
1977                                         ((SvUV(sv) > (UV)IV_MAX) ||
1978                                          (SvNV(sv) > (NV)UV_MAX)))))
1979                         ||
1980                     (SvOK(right) && ((SvNV(right) <= (NV)IV_MIN)
1981                                      ||
1982                                      ((SvNV(right) > 0) &&
1983                                         ((SvUV(right) > (UV)IV_MAX) ||
1984                                          (SvNV(right) > (NV)UV_MAX))))))
1985 #endif
1986                     DIE(aTHX_ "Range iterator outside integer range");
1987                 cx->blk_loop.state_u.lazyiv.cur = SvIV(sv);
1988                 cx->blk_loop.state_u.lazyiv.end = SvIV(right);
1989 #ifdef DEBUGGING
1990                 /* for correct -Dstv display */
1991                 cx->blk_oldsp = sp - PL_stack_base;
1992 #endif
1993             }
1994             else {
1995                 cx->cx_type &= ~CXTYPEMASK;
1996                 cx->cx_type |= CXt_LOOP_LAZYSV;
1997                 /* Make sure that no-one re-orders cop.h and breaks our
1998                    assumptions */
1999                 assert(CxTYPE(cx) == CXt_LOOP_LAZYSV);
2000                 cx->blk_loop.state_u.lazysv.cur = newSVsv(sv);
2001                 cx->blk_loop.state_u.lazysv.end = right;
2002                 SvREFCNT_inc(right);
2003                 (void) SvPV_force_nolen(cx->blk_loop.state_u.lazysv.cur);
2004                 /* This will do the upgrade to SVt_PV, and warn if the value
2005                    is uninitialised.  */
2006                 (void) SvPV_nolen_const(right);
2007                 /* Doing this avoids a check every time in pp_iter in pp_hot.c
2008                    to replace !SvOK() with a pointer to "".  */
2009                 if (!SvOK(right)) {
2010                     SvREFCNT_dec(right);
2011                     cx->blk_loop.state_u.lazysv.end = &PL_sv_no;
2012                 }
2013             }
2014         }
2015         else /* SvTYPE(maybe_ary) == SVt_PVAV */ {
2016             cx->blk_loop.state_u.ary.ary = MUTABLE_AV(maybe_ary);
2017             SvREFCNT_inc(maybe_ary);
2018             cx->blk_loop.state_u.ary.ix =
2019                 (PL_op->op_private & OPpITER_REVERSED) ?
2020                 AvFILL(cx->blk_loop.state_u.ary.ary) + 1 :
2021                 -1;
2022         }
2023     }
2024     else { /* iterating over items on the stack */
2025         cx->blk_loop.state_u.ary.ary = NULL; /* means to use the stack */
2026         if (PL_op->op_private & OPpITER_REVERSED) {
2027             cx->blk_loop.state_u.ary.ix = cx->blk_oldsp + 1;
2028         }
2029         else {
2030             cx->blk_loop.state_u.ary.ix = MARK - PL_stack_base;
2031         }
2032     }
2033
2034     RETURN;
2035 }
2036
2037 PP(pp_enterloop)
2038 {
2039     dVAR; dSP;
2040     register PERL_CONTEXT *cx;
2041     const I32 gimme = GIMME_V;
2042
2043     ENTER_with_name("loop1");
2044     SAVETMPS;
2045     ENTER_with_name("loop2");
2046
2047     PUSHBLOCK(cx, CXt_LOOP_PLAIN, SP);
2048     PUSHLOOP_PLAIN(cx, SP);
2049
2050     RETURN;
2051 }
2052
2053 PP(pp_leaveloop)
2054 {
2055     dVAR; dSP;
2056     register PERL_CONTEXT *cx;
2057     I32 gimme;
2058     SV **newsp;
2059     PMOP *newpm;
2060     SV **mark;
2061
2062     POPBLOCK(cx,newpm);
2063     assert(CxTYPE_is_LOOP(cx));
2064     mark = newsp;
2065     newsp = PL_stack_base + cx->blk_loop.resetsp;
2066
2067     TAINT_NOT;
2068     if (gimme == G_VOID)
2069         NOOP;
2070     else if (gimme == G_SCALAR) {
2071         if (mark < SP)
2072             *++newsp = sv_mortalcopy(*SP);
2073         else
2074             *++newsp = &PL_sv_undef;
2075     }
2076     else {
2077         while (mark < SP) {
2078             *++newsp = sv_mortalcopy(*++mark);
2079             TAINT_NOT;          /* Each item is independent */
2080         }
2081     }
2082     SP = newsp;
2083     PUTBACK;
2084
2085     POPLOOP(cx);        /* Stack values are safe: release loop vars ... */
2086     PL_curpm = newpm;   /* ... and pop $1 et al */
2087
2088     LEAVE_with_name("loop2");
2089     LEAVE_with_name("loop1");
2090
2091     return NORMAL;
2092 }
2093
2094 PP(pp_return)
2095 {
2096     dVAR; dSP; dMARK;
2097     register PERL_CONTEXT *cx;
2098     bool popsub2 = FALSE;
2099     bool clear_errsv = FALSE;
2100     I32 gimme;
2101     SV **newsp;
2102     PMOP *newpm;
2103     I32 optype = 0;
2104     SV *namesv;
2105     SV *sv;
2106     OP *retop = NULL;
2107
2108     const I32 cxix = dopoptosub(cxstack_ix);
2109
2110     if (cxix < 0) {
2111         if (CxMULTICALL(cxstack)) { /* In this case we must be in a
2112                                      * sort block, which is a CXt_NULL
2113                                      * not a CXt_SUB */
2114             dounwind(0);
2115             PL_stack_base[1] = *PL_stack_sp;
2116             PL_stack_sp = PL_stack_base + 1;
2117             return 0;
2118         }
2119         else
2120             DIE(aTHX_ "Can't return outside a subroutine");
2121     }
2122     if (cxix < cxstack_ix)
2123         dounwind(cxix);
2124
2125     if (CxMULTICALL(&cxstack[cxix])) {
2126         gimme = cxstack[cxix].blk_gimme;
2127         if (gimme == G_VOID)
2128             PL_stack_sp = PL_stack_base;
2129         else if (gimme == G_SCALAR) {
2130             PL_stack_base[1] = *PL_stack_sp;
2131             PL_stack_sp = PL_stack_base + 1;
2132         }
2133         return 0;
2134     }
2135
2136     POPBLOCK(cx,newpm);
2137     switch (CxTYPE(cx)) {
2138     case CXt_SUB:
2139         popsub2 = TRUE;
2140         retop = cx->blk_sub.retop;
2141         cxstack_ix++; /* preserve cx entry on stack for use by POPSUB */
2142         break;
2143     case CXt_EVAL:
2144         if (!(PL_in_eval & EVAL_KEEPERR))
2145             clear_errsv = TRUE;
2146         POPEVAL(cx);
2147         namesv = cx->blk_eval.old_namesv;
2148         retop = cx->blk_eval.retop;
2149         if (CxTRYBLOCK(cx))
2150             break;
2151         lex_end();
2152         if (optype == OP_REQUIRE &&
2153             (MARK == SP || (gimme == G_SCALAR && !SvTRUE(*SP))) )
2154         {
2155             /* Unassume the success we assumed earlier. */
2156             (void)hv_delete(GvHVn(PL_incgv),
2157                             SvPVX_const(namesv), SvCUR(namesv),
2158                             G_DISCARD);
2159             DIE(aTHX_ "%"SVf" did not return a true value", SVfARG(namesv));
2160         }
2161         break;
2162     case CXt_FORMAT:
2163         POPFORMAT(cx);
2164         retop = cx->blk_sub.retop;
2165         break;
2166     default:
2167         DIE(aTHX_ "panic: return");
2168     }
2169
2170     TAINT_NOT;
2171     if (gimme == G_SCALAR) {
2172         if (MARK < SP) {
2173             if (popsub2) {
2174                 if (cx->blk_sub.cv && CvDEPTH(cx->blk_sub.cv) > 1) {
2175                     if (SvTEMP(TOPs)) {
2176                         *++newsp = SvREFCNT_inc(*SP);
2177                         FREETMPS;
2178                         sv_2mortal(*newsp);
2179                     }
2180                     else {
2181                         sv = SvREFCNT_inc(*SP); /* FREETMPS could clobber it */
2182                         FREETMPS;
2183                         *++newsp = sv_mortalcopy(sv);
2184                         SvREFCNT_dec(sv);
2185                     }
2186                 }
2187                 else
2188                     *++newsp = (SvTEMP(*SP)) ? *SP : sv_mortalcopy(*SP);
2189             }
2190             else
2191                 *++newsp = sv_mortalcopy(*SP);
2192         }
2193         else
2194             *++newsp = &PL_sv_undef;
2195     }
2196     else if (gimme == G_ARRAY) {
2197         while (++MARK <= SP) {
2198             *++newsp = (popsub2 && SvTEMP(*MARK))
2199                         ? *MARK : sv_mortalcopy(*MARK);
2200             TAINT_NOT;          /* Each item is independent */
2201         }
2202     }
2203     PL_stack_sp = newsp;
2204
2205     LEAVE;
2206     /* Stack values are safe: */
2207     if (popsub2) {
2208         cxstack_ix--;
2209         POPSUB(cx,sv);  /* release CV and @_ ... */
2210     }
2211     else
2212         sv = NULL;
2213     PL_curpm = newpm;   /* ... and pop $1 et al */
2214
2215     LEAVESUB(sv);
2216     if (clear_errsv) {
2217         CLEAR_ERRSV();
2218     }
2219     return retop;
2220 }
2221
2222 PP(pp_last)
2223 {
2224     dVAR; dSP;
2225     I32 cxix;
2226     register PERL_CONTEXT *cx;
2227     I32 pop2 = 0;
2228     I32 gimme;
2229     I32 optype;
2230     OP *nextop = NULL;
2231     SV **newsp;
2232     PMOP *newpm;
2233     SV **mark;
2234     SV *sv = NULL;
2235
2236
2237     if (PL_op->op_flags & OPf_SPECIAL) {
2238         cxix = dopoptoloop(cxstack_ix);
2239         if (cxix < 0)
2240             DIE(aTHX_ "Can't \"last\" outside a loop block");
2241     }
2242     else {
2243         cxix = dopoptolabel(cPVOP->op_pv);
2244         if (cxix < 0)
2245             DIE(aTHX_ "Label not found for \"last %s\"", cPVOP->op_pv);
2246     }
2247     if (cxix < cxstack_ix)
2248         dounwind(cxix);
2249
2250     POPBLOCK(cx,newpm);
2251     cxstack_ix++; /* temporarily protect top context */
2252     mark = newsp;
2253     switch (CxTYPE(cx)) {
2254     case CXt_LOOP_LAZYIV:
2255     case CXt_LOOP_LAZYSV:
2256     case CXt_LOOP_FOR:
2257     case CXt_LOOP_PLAIN:
2258         pop2 = CxTYPE(cx);
2259         newsp = PL_stack_base + cx->blk_loop.resetsp;
2260         nextop = cx->blk_loop.my_op->op_lastop->op_next;
2261         break;
2262     case CXt_SUB:
2263         pop2 = CXt_SUB;
2264         nextop = cx->blk_sub.retop;
2265         break;
2266     case CXt_EVAL:
2267         POPEVAL(cx);
2268         nextop = cx->blk_eval.retop;
2269         break;
2270     case CXt_FORMAT:
2271         POPFORMAT(cx);
2272         nextop = cx->blk_sub.retop;
2273         break;
2274     default:
2275         DIE(aTHX_ "panic: last");
2276     }
2277
2278     TAINT_NOT;
2279     if (gimme == G_SCALAR) {
2280         if (MARK < SP)
2281             *++newsp = ((pop2 == CXt_SUB) && SvTEMP(*SP))
2282                         ? *SP : sv_mortalcopy(*SP);
2283         else
2284             *++newsp = &PL_sv_undef;
2285     }
2286     else if (gimme == G_ARRAY) {
2287         while (++MARK <= SP) {
2288             *++newsp = ((pop2 == CXt_SUB) && SvTEMP(*MARK))
2289                         ? *MARK : sv_mortalcopy(*MARK);
2290             TAINT_NOT;          /* Each item is independent */
2291         }
2292     }
2293     SP = newsp;
2294     PUTBACK;
2295
2296     LEAVE;
2297     cxstack_ix--;
2298     /* Stack values are safe: */
2299     switch (pop2) {
2300     case CXt_LOOP_LAZYIV:
2301     case CXt_LOOP_PLAIN:
2302     case CXt_LOOP_LAZYSV:
2303     case CXt_LOOP_FOR:
2304         POPLOOP(cx);    /* release loop vars ... */
2305         LEAVE;
2306         break;
2307     case CXt_SUB:
2308         POPSUB(cx,sv);  /* release CV and @_ ... */
2309         break;
2310     }
2311     PL_curpm = newpm;   /* ... and pop $1 et al */
2312
2313     LEAVESUB(sv);
2314     PERL_UNUSED_VAR(optype);
2315     PERL_UNUSED_VAR(gimme);
2316     return nextop;
2317 }
2318
2319 PP(pp_next)
2320 {
2321     dVAR;
2322     I32 cxix;
2323     register PERL_CONTEXT *cx;
2324     I32 inner;
2325
2326     if (PL_op->op_flags & OPf_SPECIAL) {
2327         cxix = dopoptoloop(cxstack_ix);
2328         if (cxix < 0)
2329             DIE(aTHX_ "Can't \"next\" outside a loop block");
2330     }
2331     else {
2332         cxix = dopoptolabel(cPVOP->op_pv);
2333         if (cxix < 0)
2334             DIE(aTHX_ "Label not found for \"next %s\"", cPVOP->op_pv);
2335     }
2336     if (cxix < cxstack_ix)
2337         dounwind(cxix);
2338
2339     /* clear off anything above the scope we're re-entering, but
2340      * save the rest until after a possible continue block */
2341     inner = PL_scopestack_ix;
2342     TOPBLOCK(cx);
2343     if (PL_scopestack_ix < inner)
2344         leave_scope(PL_scopestack[PL_scopestack_ix]);
2345     PL_curcop = cx->blk_oldcop;
2346     return CX_LOOP_NEXTOP_GET(cx);
2347 }
2348
2349 PP(pp_redo)
2350 {
2351     dVAR;
2352     I32 cxix;
2353     register PERL_CONTEXT *cx;
2354     I32 oldsave;
2355     OP* redo_op;
2356
2357     if (PL_op->op_flags & OPf_SPECIAL) {
2358         cxix = dopoptoloop(cxstack_ix);
2359         if (cxix < 0)
2360             DIE(aTHX_ "Can't \"redo\" outside a loop block");
2361     }
2362     else {
2363         cxix = dopoptolabel(cPVOP->op_pv);
2364         if (cxix < 0)
2365             DIE(aTHX_ "Label not found for \"redo %s\"", cPVOP->op_pv);
2366     }
2367     if (cxix < cxstack_ix)
2368         dounwind(cxix);
2369
2370     redo_op = cxstack[cxix].blk_loop.my_op->op_redoop;
2371     if (redo_op->op_type == OP_ENTER) {
2372         /* pop one less context to avoid $x being freed in while (my $x..) */
2373         cxstack_ix++;
2374         assert(CxTYPE(&cxstack[cxstack_ix]) == CXt_BLOCK);
2375         redo_op = redo_op->op_next;
2376     }
2377
2378     TOPBLOCK(cx);
2379     oldsave = PL_scopestack[PL_scopestack_ix - 1];
2380     LEAVE_SCOPE(oldsave);
2381     FREETMPS;
2382     PL_curcop = cx->blk_oldcop;
2383     return redo_op;
2384 }
2385
2386 STATIC OP *
2387 S_dofindlabel(pTHX_ OP *o, const char *label, OP **opstack, OP **oplimit)
2388 {
2389     dVAR;
2390     OP **ops = opstack;
2391     static const char too_deep[] = "Target of goto is too deeply nested";
2392
2393     PERL_ARGS_ASSERT_DOFINDLABEL;
2394
2395     if (ops >= oplimit)
2396         Perl_croak(aTHX_ too_deep);
2397     if (o->op_type == OP_LEAVE ||
2398         o->op_type == OP_SCOPE ||
2399         o->op_type == OP_LEAVELOOP ||
2400         o->op_type == OP_LEAVESUB ||
2401         o->op_type == OP_LEAVETRY)
2402     {
2403         *ops++ = cUNOPo->op_first;
2404         if (ops >= oplimit)
2405             Perl_croak(aTHX_ too_deep);
2406     }
2407     *ops = 0;
2408     if (o->op_flags & OPf_KIDS) {
2409         OP *kid;
2410         /* First try all the kids at this level, since that's likeliest. */
2411         for (kid = cUNOPo->op_first; kid; kid = kid->op_sibling) {
2412             if (kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE) {
2413                 const char *kid_label = CopLABEL(kCOP);
2414                 if (kid_label && strEQ(kid_label, label))
2415                     return kid;
2416             }
2417         }
2418         for (kid = cUNOPo->op_first; kid; kid = kid->op_sibling) {
2419             if (kid == PL_lastgotoprobe)
2420                 continue;
2421             if (kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE) {
2422                 if (ops == opstack)
2423                     *ops++ = kid;
2424                 else if (ops[-1]->op_type == OP_NEXTSTATE ||
2425                          ops[-1]->op_type == OP_DBSTATE)
2426                     ops[-1] = kid;
2427                 else
2428                     *ops++ = kid;
2429             }
2430             if ((o = dofindlabel(kid, label, ops, oplimit)))
2431                 return o;
2432         }
2433     }
2434     *ops = 0;
2435     return 0;
2436 }
2437
2438 PP(pp_goto)
2439 {
2440     dVAR; dSP;
2441     OP *retop = NULL;
2442     I32 ix;
2443     register PERL_CONTEXT *cx;
2444 #define GOTO_DEPTH 64
2445     OP *enterops[GOTO_DEPTH];
2446     const char *label = NULL;
2447     const bool do_dump = (PL_op->op_type == OP_DUMP);
2448     static const char must_have_label[] = "goto must have label";
2449
2450     if (PL_op->op_flags & OPf_STACKED) {
2451         SV * const sv = POPs;
2452
2453         /* This egregious kludge implements goto &subroutine */
2454         if (SvROK(sv) && SvTYPE(SvRV(sv)) == SVt_PVCV) {
2455             I32 cxix;
2456             register PERL_CONTEXT *cx;
2457             CV *cv = MUTABLE_CV(SvRV(sv));
2458             SV** mark;
2459             I32 items = 0;
2460             I32 oldsave;
2461             bool reified = 0;
2462
2463         retry:
2464             if (!CvROOT(cv) && !CvXSUB(cv)) {
2465                 const GV * const gv = CvGV(cv);
2466                 if (gv) {
2467                     GV *autogv;
2468                     SV *tmpstr;
2469                     /* autoloaded stub? */
2470                     if (cv != GvCV(gv) && (cv = GvCV(gv)))
2471                         goto retry;
2472                     autogv = gv_autoload4(GvSTASH(gv), GvNAME(gv),
2473                                           GvNAMELEN(gv), FALSE);
2474                     if (autogv && (cv = GvCV(autogv)))
2475                         goto retry;
2476                     tmpstr = sv_newmortal();
2477                     gv_efullname3(tmpstr, gv, NULL);
2478                     DIE(aTHX_ "Goto undefined subroutine &%"SVf"", SVfARG(tmpstr));
2479                 }
2480                 DIE(aTHX_ "Goto undefined subroutine");
2481             }
2482
2483             /* First do some returnish stuff. */
2484             SvREFCNT_inc_simple_void(cv); /* avoid premature free during unwind */
2485             FREETMPS;
2486             cxix = dopoptosub(cxstack_ix);
2487             if (cxix < 0)
2488                 DIE(aTHX_ "Can't goto subroutine outside a subroutine");
2489             if (cxix < cxstack_ix)
2490                 dounwind(cxix);
2491             TOPBLOCK(cx);
2492             SPAGAIN;
2493             /* ban goto in eval: see <20050521150056.GC20213@iabyn.com> */
2494             if (CxTYPE(cx) == CXt_EVAL) {
2495                 if (CxREALEVAL(cx))
2496                     DIE(aTHX_ "Can't goto subroutine from an eval-string");
2497                 else
2498                     DIE(aTHX_ "Can't goto subroutine from an eval-block");
2499             }
2500             else if (CxMULTICALL(cx))
2501                 DIE(aTHX_ "Can't goto subroutine from a sort sub (or similar callback)");
2502             if (CxTYPE(cx) == CXt_SUB && CxHASARGS(cx)) {
2503                 /* put @_ back onto stack */
2504                 AV* av = cx->blk_sub.argarray;
2505
2506                 items = AvFILLp(av) + 1;
2507                 EXTEND(SP, items+1); /* @_ could have been extended. */
2508                 Copy(AvARRAY(av), SP + 1, items, SV*);
2509                 SvREFCNT_dec(GvAV(PL_defgv));
2510                 GvAV(PL_defgv) = cx->blk_sub.savearray;
2511                 CLEAR_ARGARRAY(av);
2512                 /* abandon @_ if it got reified */
2513                 if (AvREAL(av)) {
2514                     reified = 1;
2515                     SvREFCNT_dec(av);
2516                     av = newAV();
2517                     av_extend(av, items-1);
2518                     AvREIFY_only(av);
2519                     PAD_SVl(0) = MUTABLE_SV(cx->blk_sub.argarray = av);
2520                 }
2521             }
2522             else if (CvISXSUB(cv)) {    /* put GvAV(defgv) back onto stack */
2523                 AV* const av = GvAV(PL_defgv);
2524                 items = AvFILLp(av) + 1;
2525                 EXTEND(SP, items+1); /* @_ could have been extended. */
2526                 Copy(AvARRAY(av), SP + 1, items, SV*);
2527             }
2528             mark = SP;
2529             SP += items;
2530             if (CxTYPE(cx) == CXt_SUB &&
2531                 !(CvDEPTH(cx->blk_sub.cv) = cx->blk_sub.olddepth))
2532                 SvREFCNT_dec(cx->blk_sub.cv);
2533             oldsave = PL_scopestack[PL_scopestack_ix - 1];
2534             LEAVE_SCOPE(oldsave);
2535
2536             /* Now do some callish stuff. */
2537             SAVETMPS;
2538             SAVEFREESV(cv); /* later, undo the 'avoid premature free' hack */
2539             if (CvISXSUB(cv)) {
2540                 OP* const retop = cx->blk_sub.retop;
2541                 SV **newsp;
2542                 I32 gimme;
2543                 if (reified) {
2544                     I32 index;
2545                     for (index=0; index<items; index++)
2546                         sv_2mortal(SP[-index]);
2547                 }
2548
2549                 /* XS subs don't have a CxSUB, so pop it */
2550                 POPBLOCK(cx, PL_curpm);
2551                 /* Push a mark for the start of arglist */
2552                 PUSHMARK(mark);
2553                 PUTBACK;
2554                 (void)(*CvXSUB(cv))(aTHX_ cv);
2555                 LEAVE;
2556                 return retop;
2557             }
2558             else {
2559                 AV* const padlist = CvPADLIST(cv);
2560                 if (CxTYPE(cx) == CXt_EVAL) {
2561                     PL_in_eval = CxOLD_IN_EVAL(cx);
2562                     PL_eval_root = cx->blk_eval.old_eval_root;
2563                     cx->cx_type = CXt_SUB;
2564                 }
2565                 cx->blk_sub.cv = cv;
2566                 cx->blk_sub.olddepth = CvDEPTH(cv);
2567
2568                 CvDEPTH(cv)++;
2569                 if (CvDEPTH(cv) < 2)
2570                     SvREFCNT_inc_simple_void_NN(cv);
2571                 else {
2572                     if (CvDEPTH(cv) == PERL_SUB_DEPTH_WARN && ckWARN(WARN_RECURSION))
2573                         sub_crush_depth(cv);
2574                     pad_push(padlist, CvDEPTH(cv));
2575                 }
2576                 SAVECOMPPAD();
2577                 PAD_SET_CUR_NOSAVE(padlist, CvDEPTH(cv));
2578                 if (CxHASARGS(cx))
2579                 {
2580                     AV *const av = MUTABLE_AV(PAD_SVl(0));
2581
2582                     cx->blk_sub.savearray = GvAV(PL_defgv);
2583                     GvAV(PL_defgv) = MUTABLE_AV(SvREFCNT_inc_simple(av));
2584                     CX_CURPAD_SAVE(cx->blk_sub);
2585                     cx->blk_sub.argarray = av;
2586
2587                     if (items >= AvMAX(av) + 1) {
2588                         SV **ary = AvALLOC(av);
2589                         if (AvARRAY(av) != ary) {
2590                             AvMAX(av) += AvARRAY(av) - AvALLOC(av);
2591                             AvARRAY(av) = ary;
2592                         }
2593                         if (items >= AvMAX(av) + 1) {
2594                             AvMAX(av) = items - 1;
2595                             Renew(ary,items+1,SV*);
2596                             AvALLOC(av) = ary;
2597                             AvARRAY(av) = ary;
2598                         }
2599                     }
2600                     ++mark;
2601                     Copy(mark,AvARRAY(av),items,SV*);
2602                     AvFILLp(av) = items - 1;
2603                     assert(!AvREAL(av));
2604                     if (reified) {
2605                         /* transfer 'ownership' of refcnts to new @_ */
2606                         AvREAL_on(av);
2607                         AvREIFY_off(av);
2608                     }
2609                     while (items--) {
2610                         if (*mark)
2611                             SvTEMP_off(*mark);
2612                         mark++;
2613                     }
2614                 }
2615                 if (PERLDB_SUB) {       /* Checking curstash breaks DProf. */
2616                     Perl_get_db_sub(aTHX_ NULL, cv);
2617                     if (PERLDB_GOTO) {
2618                         CV * const gotocv = get_cvs("DB::goto", 0);
2619                         if (gotocv) {
2620                             PUSHMARK( PL_stack_sp );
2621                             call_sv(MUTABLE_SV(gotocv), G_SCALAR | G_NODEBUG);
2622                             PL_stack_sp--;
2623                         }
2624                     }
2625                 }
2626                 RETURNOP(CvSTART(cv));
2627             }
2628         }
2629         else {
2630             label = SvPV_nolen_const(sv);
2631             if (!(do_dump || *label))
2632                 DIE(aTHX_ must_have_label);
2633         }
2634     }
2635     else if (PL_op->op_flags & OPf_SPECIAL) {
2636         if (! do_dump)
2637             DIE(aTHX_ must_have_label);
2638     }
2639     else
2640         label = cPVOP->op_pv;
2641
2642     PERL_ASYNC_CHECK();
2643
2644     if (label && *label) {
2645         OP *gotoprobe = NULL;
2646         bool leaving_eval = FALSE;
2647         bool in_block = FALSE;
2648         PERL_CONTEXT *last_eval_cx = NULL;
2649
2650         /* find label */
2651
2652         PL_lastgotoprobe = NULL;
2653         *enterops = 0;
2654         for (ix = cxstack_ix; ix >= 0; ix--) {
2655             cx = &cxstack[ix];
2656             switch (CxTYPE(cx)) {
2657             case CXt_EVAL:
2658                 leaving_eval = TRUE;
2659                 if (!CxTRYBLOCK(cx)) {
2660                     gotoprobe = (last_eval_cx ?
2661                                 last_eval_cx->blk_eval.old_eval_root :
2662                                 PL_eval_root);
2663                     last_eval_cx = cx;
2664                     break;
2665                 }
2666                 /* else fall through */
2667             case CXt_LOOP_LAZYIV:
2668             case CXt_LOOP_LAZYSV:
2669             case CXt_LOOP_FOR:
2670             case CXt_LOOP_PLAIN:
2671             case CXt_GIVEN:
2672             case CXt_WHEN:
2673                 gotoprobe = cx->blk_oldcop->op_sibling;
2674                 break;
2675             case CXt_SUBST:
2676                 continue;
2677             case CXt_BLOCK:
2678                 if (ix) {
2679                     gotoprobe = cx->blk_oldcop->op_sibling;
2680                     in_block = TRUE;
2681                 } else
2682                     gotoprobe = PL_main_root;
2683                 break;
2684             case CXt_SUB:
2685                 if (CvDEPTH(cx->blk_sub.cv) && !CxMULTICALL(cx)) {
2686                     gotoprobe = CvROOT(cx->blk_sub.cv);
2687                     break;
2688                 }
2689                 /* FALL THROUGH */
2690             case CXt_FORMAT:
2691             case CXt_NULL:
2692                 DIE(aTHX_ "Can't \"goto\" out of a pseudo block");
2693             default:
2694                 if (ix)
2695                     DIE(aTHX_ "panic: goto");
2696                 gotoprobe = PL_main_root;
2697                 break;
2698             }
2699             if (gotoprobe) {
2700                 retop = dofindlabel(gotoprobe, label,
2701                                     enterops, enterops + GOTO_DEPTH);
2702                 if (retop)
2703                     break;
2704             }
2705             PL_lastgotoprobe = gotoprobe;
2706         }
2707         if (!retop)
2708             DIE(aTHX_ "Can't find label %s", label);
2709
2710         /* if we're leaving an eval, check before we pop any frames
2711            that we're not going to punt, otherwise the error
2712            won't be caught */
2713
2714         if (leaving_eval && *enterops && enterops[1]) {
2715             I32 i;
2716             for (i = 1; enterops[i]; i++)
2717                 if (enterops[i]->op_type == OP_ENTERITER)
2718                     DIE(aTHX_ "Can't \"goto\" into the middle of a foreach loop");
2719         }
2720
2721         if (*enterops && enterops[1]) {
2722             I32 i = enterops[1]->op_type == OP_ENTER && in_block ? 2 : 1;
2723             if (enterops[i])
2724                 deprecate("\"goto\" to jump into a construct");
2725         }
2726
2727         /* pop unwanted frames */
2728
2729         if (ix < cxstack_ix) {
2730             I32 oldsave;
2731
2732             if (ix < 0)
2733                 ix = 0;
2734             dounwind(ix);
2735             TOPBLOCK(cx);
2736             oldsave = PL_scopestack[PL_scopestack_ix];
2737             LEAVE_SCOPE(oldsave);
2738         }
2739
2740         /* push wanted frames */
2741
2742         if (*enterops && enterops[1]) {
2743             OP * const oldop = PL_op;
2744             ix = enterops[1]->op_type == OP_ENTER && in_block ? 2 : 1;
2745             for (; enterops[ix]; ix++) {
2746                 PL_op = enterops[ix];
2747                 /* Eventually we may want to stack the needed arguments
2748                  * for each op.  For now, we punt on the hard ones. */
2749                 if (PL_op->op_type == OP_ENTERITER)
2750                     DIE(aTHX_ "Can't \"goto\" into the middle of a foreach loop");
2751                 CALL_FPTR(PL_op->op_ppaddr)(aTHX);
2752             }
2753             PL_op = oldop;
2754         }
2755     }
2756
2757     if (do_dump) {
2758 #ifdef VMS
2759         if (!retop) retop = PL_main_start;
2760 #endif
2761         PL_restartop = retop;
2762         PL_do_undump = TRUE;
2763
2764         my_unexec();
2765
2766         PL_restartop = 0;               /* hmm, must be GNU unexec().. */
2767         PL_do_undump = FALSE;
2768     }
2769
2770     RETURNOP(retop);
2771 }
2772
2773 PP(pp_exit)
2774 {
2775     dVAR;
2776     dSP;
2777     I32 anum;
2778
2779     if (MAXARG < 1)
2780         anum = 0;
2781     else {
2782         anum = SvIVx(POPs);
2783 #ifdef VMS
2784         if (anum == 1 && (PL_op->op_private & OPpEXIT_VMSISH))
2785             anum = 0;
2786         VMSISH_HUSHED  = VMSISH_HUSHED || (PL_op->op_private & OPpHUSH_VMSISH);
2787 #endif
2788     }
2789     PL_exit_flags |= PERL_EXIT_EXPECTED;
2790 #ifdef PERL_MAD
2791     /* KLUDGE: disable exit 0 in BEGIN blocks when we're just compiling */
2792     if (anum || !(PL_minus_c && PL_madskills))
2793         my_exit(anum);
2794 #else
2795     my_exit(anum);
2796 #endif
2797     PUSHs(&PL_sv_undef);
2798     RETURN;
2799 }
2800
2801 /* Eval. */
2802
2803 STATIC void
2804 S_save_lines(pTHX_ AV *array, SV *sv)
2805 {
2806     const char *s = SvPVX_const(sv);
2807     const char * const send = SvPVX_const(sv) + SvCUR(sv);
2808     I32 line = 1;
2809
2810     PERL_ARGS_ASSERT_SAVE_LINES;
2811
2812     while (s && s < send) {
2813         const char *t;
2814         SV * const tmpstr = newSV_type(SVt_PVMG);
2815
2816         t = (const char *)memchr(s, '\n', send - s);
2817         if (t)
2818             t++;
2819         else
2820             t = send;
2821
2822         sv_setpvn(tmpstr, s, t - s);
2823         av_store(array, line++, tmpstr);
2824         s = t;
2825     }
2826 }
2827
2828 /*
2829 =for apidoc docatch
2830
2831 Check for the cases 0 or 3 of cur_env.je_ret, only used inside an eval context.
2832
2833 0 is used as continue inside eval,
2834
2835 3 is used for a die caught by an inner eval - continue inner loop
2836
2837 See cop.h: je_mustcatch, when set at any runlevel to TRUE, means eval ops must
2838 establish a local jmpenv to handle exception traps.
2839
2840 =cut
2841 */
2842 STATIC OP *
2843 S_docatch(pTHX_ OP *o)
2844 {
2845     dVAR;
2846     int ret;
2847     OP * const oldop = PL_op;
2848     dJMPENV;
2849
2850 #ifdef DEBUGGING
2851     assert(CATCH_GET == TRUE);
2852 #endif
2853     PL_op = o;
2854
2855     JMPENV_PUSH(ret);
2856     switch (ret) {
2857     case 0:
2858         assert(cxstack_ix >= 0);
2859         assert(CxTYPE(&cxstack[cxstack_ix]) == CXt_EVAL);
2860         cxstack[cxstack_ix].blk_eval.cur_top_env = PL_top_env;
2861  redo_body:
2862         CALLRUNOPS(aTHX);
2863         break;
2864     case 3:
2865         /* die caught by an inner eval - continue inner loop */
2866         if (PL_restartop && PL_restartjmpenv == PL_top_env) {
2867             PL_restartjmpenv = NULL;
2868             PL_op = PL_restartop;
2869             PL_restartop = 0;
2870             goto redo_body;
2871         }
2872         /* FALL THROUGH */
2873     default:
2874         JMPENV_POP;
2875         PL_op = oldop;
2876         JMPENV_JUMP(ret);
2877         /* NOTREACHED */
2878     }
2879     JMPENV_POP;
2880     PL_op = oldop;
2881     return NULL;
2882 }
2883
2884 /* James Bond: Do you expect me to talk?
2885    Auric Goldfinger: No, Mr. Bond. I expect you to die.
2886
2887    This code is an ugly hack, doesn't work with lexicals in subroutines that are
2888    called more than once, and is only used by regcomp.c, for (?{}) blocks.
2889
2890    Currently it is not used outside the core code. Best if it stays that way.
2891 */
2892 OP *
2893 Perl_sv_compile_2op(pTHX_ SV *sv, OP** startop, const char *code, PAD** padp)
2894 /* sv Text to convert to OP tree. */
2895 /* startop op_free() this to undo. */
2896 /* code Short string id of the caller. */
2897 {
2898     dVAR; dSP;                          /* Make POPBLOCK work. */
2899     PERL_CONTEXT *cx;
2900     SV **newsp;
2901     I32 gimme = G_VOID;
2902     I32 optype;
2903     OP dummy;
2904     char tbuf[TYPE_DIGITS(long) + 12 + 10];
2905     char *tmpbuf = tbuf;
2906     char *safestr;
2907     int runtime;
2908     CV* runcv = NULL;   /* initialise to avoid compiler warnings */
2909     STRLEN len;
2910
2911     PERL_ARGS_ASSERT_SV_COMPILE_2OP;
2912
2913     ENTER_with_name("eval");
2914     lex_start(sv, NULL, FALSE);
2915     SAVETMPS;
2916     /* switch to eval mode */
2917
2918     if (IN_PERL_COMPILETIME) {
2919         SAVECOPSTASH_FREE(&PL_compiling);
2920         CopSTASH_set(&PL_compiling, PL_curstash);
2921     }
2922     if (PERLDB_NAMEEVAL && CopLINE(PL_curcop)) {
2923         SV * const sv = sv_newmortal();
2924         Perl_sv_setpvf(aTHX_ sv, "_<(%.10seval %lu)[%s:%"IVdf"]",
2925                        code, (unsigned long)++PL_evalseq,
2926                        CopFILE(PL_curcop), (IV)CopLINE(PL_curcop));
2927         tmpbuf = SvPVX(sv);
2928         len = SvCUR(sv);
2929     }
2930     else
2931         len = my_snprintf(tmpbuf, sizeof(tbuf), "_<(%.10s_eval %lu)", code,
2932                           (unsigned long)++PL_evalseq);
2933     SAVECOPFILE_FREE(&PL_compiling);
2934     CopFILE_set(&PL_compiling, tmpbuf+2);
2935     SAVECOPLINE(&PL_compiling);
2936     CopLINE_set(&PL_compiling, 1);
2937     /* XXX For C<eval "...">s within BEGIN {} blocks, this ends up
2938        deleting the eval's FILEGV from the stash before gv_check() runs
2939        (i.e. before run-time proper). To work around the coredump that
2940        ensues, we always turn GvMULTI_on for any globals that were
2941        introduced within evals. See force_ident(). GSAR 96-10-12 */
2942     safestr = savepvn(tmpbuf, len);
2943     SAVEDELETE(PL_defstash, safestr, len);
2944     SAVEHINTS();
2945 #ifdef OP_IN_REGISTER
2946     PL_opsave = op;
2947 #else
2948     SAVEVPTR(PL_op);
2949 #endif
2950
2951     /* we get here either during compilation, or via pp_regcomp at runtime */
2952     runtime = IN_PERL_RUNTIME;
2953     if (runtime)
2954         runcv = find_runcv(NULL);
2955
2956     PL_op = &dummy;
2957     PL_op->op_type = OP_ENTEREVAL;
2958     PL_op->op_flags = 0;                        /* Avoid uninit warning. */
2959     PUSHBLOCK(cx, CXt_EVAL|(IN_PERL_COMPILETIME ? 0 : CXp_REAL), SP);
2960     PUSHEVAL(cx, 0);
2961
2962     if (runtime)
2963         (void) doeval(G_SCALAR, startop, runcv, PL_curcop->cop_seq);
2964     else
2965         (void) doeval(G_SCALAR, startop, PL_compcv, PL_cop_seqmax);
2966     POPBLOCK(cx,PL_curpm);
2967     POPEVAL(cx);
2968
2969     (*startop)->op_type = OP_NULL;
2970     (*startop)->op_ppaddr = PL_ppaddr[OP_NULL];
2971     lex_end();
2972     /* XXX DAPM do this properly one year */
2973     *padp = MUTABLE_AV(SvREFCNT_inc_simple(PL_comppad));
2974     LEAVE_with_name("eval");
2975     if (IN_PERL_COMPILETIME)
2976         CopHINTS_set(&PL_compiling, PL_hints);
2977 #ifdef OP_IN_REGISTER
2978     op = PL_opsave;
2979 #endif
2980     PERL_UNUSED_VAR(newsp);
2981     PERL_UNUSED_VAR(optype);
2982
2983     return PL_eval_start;
2984 }
2985
2986
2987 /*
2988 =for apidoc find_runcv
2989
2990 Locate the CV corresponding to the currently executing sub or eval.
2991 If db_seqp is non_null, skip CVs that are in the DB package and populate
2992 *db_seqp with the cop sequence number at the point that the DB:: code was
2993 entered. (allows debuggers to eval in the scope of the breakpoint rather
2994 than in the scope of the debugger itself).
2995
2996 =cut
2997 */
2998
2999 CV*
3000 Perl_find_runcv(pTHX_ U32 *db_seqp)
3001 {
3002     dVAR;
3003     PERL_SI      *si;
3004
3005     if (db_seqp)
3006         *db_seqp = PL_curcop->cop_seq;
3007     for (si = PL_curstackinfo; si; si = si->si_prev) {
3008         I32 ix;
3009         for (ix = si->si_cxix; ix >= 0; ix--) {
3010             const PERL_CONTEXT *cx = &(si->si_cxstack[ix]);
3011             if (CxTYPE(cx) == CXt_SUB || CxTYPE(cx) == CXt_FORMAT) {
3012                 CV * const cv = cx->blk_sub.cv;
3013                 /* skip DB:: code */
3014                 if (db_seqp && PL_debstash && CvSTASH(cv) == PL_debstash) {
3015                     *db_seqp = cx->blk_oldcop->cop_seq;
3016                     continue;
3017                 }
3018                 return cv;
3019             }
3020             else if (CxTYPE(cx) == CXt_EVAL && !CxTRYBLOCK(cx))
3021                 return PL_compcv;
3022         }
3023     }
3024     return PL_main_cv;
3025 }
3026
3027
3028 /* Run yyparse() in a setjmp wrapper. Returns:
3029  *   0: yyparse() successful
3030  *   1: yyparse() failed
3031  *   3: yyparse() died
3032  */
3033 STATIC int
3034 S_try_yyparse(pTHX)
3035 {
3036     int ret;
3037     dJMPENV;
3038
3039     assert(CxTYPE(&cxstack[cxstack_ix]) == CXt_EVAL);
3040     JMPENV_PUSH(ret);
3041     switch (ret) {
3042     case 0:
3043         ret = yyparse() ? 1 : 0;
3044         break;
3045     case 3:
3046         break;
3047     default:
3048         JMPENV_POP;
3049         JMPENV_JUMP(ret);
3050         /* NOTREACHED */
3051     }
3052     JMPENV_POP;
3053     return ret;
3054 }
3055
3056
3057 /* Compile a require/do, an eval '', or a /(?{...})/.
3058  * In the last case, startop is non-null, and contains the address of
3059  * a pointer that should be set to the just-compiled code.
3060  * outside is the lexically enclosing CV (if any) that invoked us.
3061  * Returns a bool indicating whether the compile was successful; if so,
3062  * PL_eval_start contains the first op of the compiled ocde; otherwise,
3063  * pushes undef (also croaks if startop != NULL).
3064  */
3065
3066 STATIC bool
3067 S_doeval(pTHX_ int gimme, OP** startop, CV* outside, U32 seq)
3068 {
3069     dVAR; dSP;
3070     OP * const saveop = PL_op;
3071     bool in_require = (saveop && saveop->op_type == OP_REQUIRE);
3072     int yystatus;
3073
3074     PL_in_eval = (in_require
3075                   ? (EVAL_INREQUIRE | (PL_in_eval & EVAL_INEVAL))
3076                   : EVAL_INEVAL);
3077
3078     PUSHMARK(SP);
3079
3080     SAVESPTR(PL_compcv);
3081     PL_compcv = MUTABLE_CV(newSV_type(SVt_PVCV));
3082     CvEVAL_on(PL_compcv);
3083     assert(CxTYPE(&cxstack[cxstack_ix]) == CXt_EVAL);
3084     cxstack[cxstack_ix].blk_eval.cv = PL_compcv;
3085
3086     CvOUTSIDE_SEQ(PL_compcv) = seq;
3087     CvOUTSIDE(PL_compcv) = MUTABLE_CV(SvREFCNT_inc_simple(outside));
3088
3089     /* set up a scratch pad */
3090
3091     CvPADLIST(PL_compcv) = pad_new(padnew_SAVE);
3092     PL_op = NULL; /* avoid PL_op and PL_curpad referring to different CVs */
3093
3094
3095     if (!PL_madskills)
3096         SAVEMORTALIZESV(PL_compcv);     /* must remain until end of current statement */
3097
3098     /* make sure we compile in the right package */
3099
3100     if (CopSTASH_ne(PL_curcop, PL_curstash)) {
3101         SAVESPTR(PL_curstash);
3102         PL_curstash = CopSTASH(PL_curcop);
3103     }
3104     /* XXX:ajgo do we really need to alloc an AV for begin/checkunit */
3105     SAVESPTR(PL_beginav);
3106     PL_beginav = newAV();
3107     SAVEFREESV(PL_beginav);
3108     SAVESPTR(PL_unitcheckav);
3109     PL_unitcheckav = newAV();
3110     SAVEFREESV(PL_unitcheckav);
3111
3112 #ifdef PERL_MAD
3113     SAVEBOOL(PL_madskills);
3114     PL_madskills = 0;
3115 #endif
3116
3117     /* try to compile it */
3118
3119     PL_eval_root = NULL;
3120     PL_curcop = &PL_compiling;
3121     CopARYBASE_set(PL_curcop, 0);
3122     if (saveop && (saveop->op_type != OP_REQUIRE) && (saveop->op_flags & OPf_SPECIAL))
3123         PL_in_eval |= EVAL_KEEPERR;
3124     else
3125         CLEAR_ERRSV();
3126
3127     /* note that yyparse() may raise an exception, e.g. C<BEGIN{die}>,
3128      * so honour CATCH_GET and trap it here if necessary */
3129
3130     yystatus = (!in_require && CATCH_GET) ? S_try_yyparse(aTHX) : yyparse();
3131
3132     if (yystatus || PL_parser->error_count || !PL_eval_root) {
3133         SV **newsp;                     /* Used by POPBLOCK. */
3134         PERL_CONTEXT *cx = NULL;
3135         I32 optype;                     /* Used by POPEVAL. */
3136         SV *namesv = NULL;
3137         const char *msg;
3138
3139         PERL_UNUSED_VAR(newsp);
3140         PERL_UNUSED_VAR(optype);
3141
3142         /* note that if yystatus == 3, then the EVAL CX block has already
3143          * been popped, and various vars restored */
3144         PL_op = saveop;
3145         if (yystatus != 3) {
3146             if (PL_eval_root) {
3147                 op_free(PL_eval_root);
3148                 PL_eval_root = NULL;
3149             }
3150             SP = PL_stack_base + POPMARK;       /* pop original mark */
3151             if (!startop) {
3152                 POPBLOCK(cx,PL_curpm);
3153                 POPEVAL(cx);
3154                 namesv = cx->blk_eval.old_namesv;
3155             }
3156         }
3157         lex_end();
3158         if (yystatus != 3)
3159             LEAVE_with_name("eval"); /* pp_entereval knows about this LEAVE.  */
3160
3161         msg = SvPVx_nolen_const(ERRSV);
3162         if (in_require) {
3163             if (!cx) {
3164                 /* If cx is still NULL, it means that we didn't go in the
3165                  * POPEVAL branch. */
3166                 cx = &cxstack[cxstack_ix];
3167                 assert(CxTYPE(cx) == CXt_EVAL);
3168                 namesv = cx->blk_eval.old_namesv;
3169             }
3170             (void)hv_store(GvHVn(PL_incgv),
3171                            SvPVX_const(namesv), SvCUR(namesv),
3172                            &PL_sv_undef, 0);
3173             Perl_croak(aTHX_ "%sCompilation failed in require",
3174                        *msg ? msg : "Unknown error\n");
3175         }
3176         else if (startop) {
3177             if (yystatus != 3) {
3178                 POPBLOCK(cx,PL_curpm);
3179                 POPEVAL(cx);
3180             }
3181             Perl_croak(aTHX_ "%sCompilation failed in regexp",
3182                        (*msg ? msg : "Unknown error\n"));
3183         }
3184         else {
3185             if (!*msg) {
3186                 sv_setpvs(ERRSV, "Compilation error");
3187             }
3188         }
3189         PUSHs(&PL_sv_undef);
3190         PUTBACK;
3191         return FALSE;
3192     }
3193     CopLINE_set(&PL_compiling, 0);
3194     if (startop) {
3195         *startop = PL_eval_root;
3196     } else
3197         SAVEFREEOP(PL_eval_root);
3198
3199     /* Set the context for this new optree.
3200      * Propagate the context from the eval(). */
3201     if ((gimme & G_WANT) == G_VOID)
3202         scalarvoid(PL_eval_root);
3203     else if ((gimme & G_WANT) == G_ARRAY)
3204         list(PL_eval_root);
3205     else
3206         scalar(PL_eval_root);
3207
3208     DEBUG_x(dump_eval());
3209
3210     /* Register with debugger: */
3211     if (PERLDB_INTER && saveop && saveop->op_type == OP_REQUIRE) {
3212         CV * const cv = get_cvs("DB::postponed", 0);
3213         if (cv) {
3214             dSP;
3215             PUSHMARK(SP);
3216             XPUSHs(MUTABLE_SV(CopFILEGV(&PL_compiling)));
3217             PUTBACK;
3218             call_sv(MUTABLE_SV(cv), G_DISCARD);
3219         }
3220     }
3221
3222     if (PL_unitcheckav)
3223         call_list(PL_scopestack_ix, PL_unitcheckav);
3224
3225     /* compiled okay, so do it */
3226
3227     CvDEPTH(PL_compcv) = 1;
3228     SP = PL_stack_base + POPMARK;               /* pop original mark */
3229     PL_op = saveop;                     /* The caller may need it. */
3230     PL_parser->lex_state = LEX_NOTPARSING;      /* $^S needs this. */
3231
3232     PUTBACK;
3233     return TRUE;
3234 }
3235
3236 STATIC PerlIO *
3237 S_check_type_and_open(pTHX_ const char *name)
3238 {
3239     Stat_t st;
3240     const int st_rc = PerlLIO_stat(name, &st);
3241
3242     PERL_ARGS_ASSERT_CHECK_TYPE_AND_OPEN;
3243
3244     if (st_rc < 0 || S_ISDIR(st.st_mode) || S_ISBLK(st.st_mode)) {
3245         return NULL;
3246     }
3247
3248     return PerlIO_open(name, PERL_SCRIPT_MODE);
3249 }
3250
3251 #ifndef PERL_DISABLE_PMC
3252 STATIC PerlIO *
3253 S_doopen_pm(pTHX_ const char *name, const STRLEN namelen)
3254 {
3255     PerlIO *fp;
3256
3257     PERL_ARGS_ASSERT_DOOPEN_PM;
3258
3259     if (namelen > 3 && memEQs(name + namelen - 3, 3, ".pm")) {
3260         SV *const pmcsv = newSV(namelen + 2);
3261         char *const pmc = SvPVX(pmcsv);
3262         Stat_t pmcstat;
3263
3264         memcpy(pmc, name, namelen);
3265         pmc[namelen] = 'c';
3266         pmc[namelen + 1] = '\0';
3267
3268         if (PerlLIO_stat(pmc, &pmcstat) < 0) {
3269             fp = check_type_and_open(name);
3270         }
3271         else {
3272             fp = check_type_and_open(pmc);
3273         }
3274         SvREFCNT_dec(pmcsv);
3275     }
3276     else {
3277         fp = check_type_and_open(name);
3278     }
3279     return fp;
3280 }
3281 #else
3282 #  define doopen_pm(name, namelen) check_type_and_open(name)
3283 #endif /* !PERL_DISABLE_PMC */
3284
3285 PP(pp_require)
3286 {
3287     dVAR; dSP;
3288     register PERL_CONTEXT *cx;
3289     SV *sv;
3290     const char *name;
3291     STRLEN len;
3292     char * unixname;
3293     STRLEN unixlen;
3294 #ifdef VMS
3295     int vms_unixname = 0;
3296 #endif
3297     const char *tryname = NULL;
3298     SV *namesv = NULL;
3299     const I32 gimme = GIMME_V;
3300     int filter_has_file = 0;
3301     PerlIO *tryrsfp = NULL;
3302     SV *filter_cache = NULL;
3303     SV *filter_state = NULL;
3304     SV *filter_sub = NULL;
3305     SV *hook_sv = NULL;
3306     SV *encoding;
3307     OP *op;
3308
3309     sv = POPs;
3310     if ( (SvNIOKp(sv) || SvVOK(sv)) && PL_op->op_type != OP_DOFILE) {
3311         sv = new_version(sv);
3312         if (!sv_derived_from(PL_patchlevel, "version"))
3313             upg_version(PL_patchlevel, TRUE);
3314         if (cUNOP->op_first->op_type == OP_CONST && cUNOP->op_first->op_private & OPpCONST_NOVER) {
3315             if ( vcmp(sv,PL_patchlevel) <= 0 )
3316                 DIE(aTHX_ "Perls since %"SVf" too modern--this is %"SVf", stopped",
3317                     SVfARG(vnormal(sv)), SVfARG(vnormal(PL_patchlevel)));
3318         }
3319         else {
3320             if ( vcmp(sv,PL_patchlevel) > 0 ) {
3321                 I32 first = 0;
3322                 AV *lav;
3323                 SV * const req = SvRV(sv);
3324                 SV * const pv = *hv_fetchs(MUTABLE_HV(req), "original", FALSE);
3325
3326                 /* get the left hand term */
3327                 lav = MUTABLE_AV(SvRV(*hv_fetchs(MUTABLE_HV(req), "version", FALSE)));
3328
3329                 first  = SvIV(*av_fetch(lav,0,0));
3330                 if (   first > (int)PERL_REVISION    /* probably 'use 6.0' */
3331                     || hv_exists(MUTABLE_HV(req), "qv", 2 ) /* qv style */
3332                     || av_len(lav) > 1               /* FP with > 3 digits */
3333                     || strstr(SvPVX(pv),".0")        /* FP with leading 0 */
3334                    ) {
3335                     DIE(aTHX_ "Perl %"SVf" required--this is only "
3336                         "%"SVf", stopped", SVfARG(vnormal(req)),
3337                         SVfARG(vnormal(PL_patchlevel)));
3338                 }
3339                 else { /* probably 'use 5.10' or 'use 5.8' */
3340                     SV *hintsv;
3341                     I32 second = 0;
3342
3343                     if (av_len(lav)>=1)
3344                         second = SvIV(*av_fetch(lav,1,0));
3345
3346                     second /= second >= 600  ? 100 : 10;
3347                     hintsv = Perl_newSVpvf(aTHX_ "v%d.%d.0",
3348                                            (int)first, (int)second);
3349                     upg_version(hintsv, TRUE);
3350
3351                     DIE(aTHX_ "Perl %"SVf" required (did you mean %"SVf"?)"
3352                         "--this is only %"SVf", stopped",
3353                         SVfARG(vnormal(req)),
3354                         SVfARG(vnormal(sv_2mortal(hintsv))),
3355                         SVfARG(vnormal(PL_patchlevel)));
3356                 }
3357             }
3358         }
3359
3360         /* We do this only with use, not require. */
3361         if (PL_compcv &&
3362           /* If we request a version >= 5.9.5, load feature.pm with the
3363            * feature bundle that corresponds to the required version. */
3364                 vcmp(sv, sv_2mortal(upg_version(newSVnv(5.009005), FALSE))) >= 0) {
3365             SV *const importsv = vnormal(sv);
3366             *SvPVX_mutable(importsv) = ':';
3367             ENTER_with_name("load_feature");
3368             Perl_load_module(aTHX_ 0, newSVpvs("feature"), NULL, importsv, NULL);
3369             LEAVE_with_name("load_feature");
3370         }
3371         /* If a version >= 5.11.0 is requested, strictures are on by default! */
3372         if (PL_compcv &&
3373                 vcmp(sv, sv_2mortal(upg_version(newSVnv(5.011000), FALSE))) >= 0) {
3374             PL_hints |= (HINT_STRICT_REFS | HINT_STRICT_SUBS | HINT_STRICT_VARS);
3375         }
3376
3377         RETPUSHYES;
3378     }
3379     name = SvPV_const(sv, len);
3380     if (!(name && len > 0 && *name))
3381         DIE(aTHX_ "Null filename used");
3382     TAINT_PROPER("require");
3383
3384
3385 #ifdef VMS
3386     /* The key in the %ENV hash is in the syntax of file passed as the argument
3387      * usually this is in UNIX format, but sometimes in VMS format, which
3388      * can result in a module being pulled in more than once.
3389      * To prevent this, the key must be stored in UNIX format if the VMS
3390      * name can be translated to UNIX.
3391      */
3392     if ((unixname = tounixspec(name, NULL)) != NULL) {
3393         unixlen = strlen(unixname);
3394         vms_unixname = 1;
3395     }
3396     else
3397 #endif
3398     {
3399         /* if not VMS or VMS name can not be translated to UNIX, pass it
3400          * through.
3401          */
3402         unixname = (char *) name;
3403         unixlen = len;
3404     }
3405     if (PL_op->op_type == OP_REQUIRE) {
3406         SV * const * const svp = hv_fetch(GvHVn(PL_incgv),
3407                                           unixname, unixlen, 0);
3408         if ( svp ) {
3409             if (*svp != &PL_sv_undef)
3410                 RETPUSHYES;
3411             else
3412                 DIE(aTHX_ "Attempt to reload %s aborted.\n"
3413                             "Compilation failed in require", unixname);
3414         }
3415     }
3416
3417     /* prepare to compile file */
3418
3419     if (path_is_absolute(name)) {
3420         tryname = name;
3421         tryrsfp = doopen_pm(name, len);
3422     }
3423     if (!tryrsfp) {
3424         AV * const ar = GvAVn(PL_incgv);
3425         I32 i;
3426 #ifdef VMS
3427         if (vms_unixname)
3428 #endif
3429         {
3430             namesv = newSV_type(SVt_PV);
3431             for (i = 0; i <= AvFILL(ar); i++) {
3432                 SV * const dirsv = *av_fetch(ar, i, TRUE);
3433
3434                 if (SvTIED_mg((const SV *)ar, PERL_MAGIC_tied))
3435                     mg_get(dirsv);
3436                 if (SvROK(dirsv)) {
3437                     int count;
3438                     SV **svp;
3439                     SV *loader = dirsv;
3440
3441                     if (SvTYPE(SvRV(loader)) == SVt_PVAV
3442                         && !sv_isobject(loader))
3443                     {
3444                         loader = *av_fetch(MUTABLE_AV(SvRV(loader)), 0, TRUE);
3445                     }
3446
3447                     Perl_sv_setpvf(aTHX_ namesv, "/loader/0x%"UVxf"/%s",
3448                                    PTR2UV(SvRV(dirsv)), name);
3449                     tryname = SvPVX_const(namesv);
3450                     tryrsfp = NULL;
3451
3452                     ENTER_with_name("call_INC");
3453                     SAVETMPS;
3454                     EXTEND(SP, 2);
3455
3456                     PUSHMARK(SP);
3457                     PUSHs(dirsv);
3458                     PUSHs(sv);
3459                     PUTBACK;
3460                     if (sv_isobject(loader))
3461                         count = call_method("INC", G_ARRAY);
3462                     else
3463                         count = call_sv(loader, G_ARRAY);
3464                     SPAGAIN;
3465
3466                     /* Adjust file name if the hook has set an %INC entry */
3467                     svp = hv_fetch(GvHVn(PL_incgv), name, len, 0);
3468                     if (svp)
3469                         tryname = SvPV_nolen_const(*svp);
3470
3471                     if (count > 0) {
3472                         int i = 0;
3473                         SV *arg;
3474
3475                         SP -= count - 1;
3476                         arg = SP[i++];
3477
3478                         if (SvROK(arg) && (SvTYPE(SvRV(arg)) <= SVt_PVLV)
3479                             && !isGV_with_GP(SvRV(arg))) {
3480                             filter_cache = SvRV(arg);
3481                             SvREFCNT_inc_simple_void_NN(filter_cache);
3482
3483                             if (i < count) {
3484                                 arg = SP[i++];
3485                             }
3486                         }
3487
3488                         if (SvROK(arg) && isGV_with_GP(SvRV(arg))) {
3489                             arg = SvRV(arg);
3490                         }
3491
3492                         if (isGV_with_GP(arg)) {
3493                             IO * const io = GvIO((const GV *)arg);
3494
3495                             ++filter_has_file;
3496
3497                             if (io) {
3498                                 tryrsfp = IoIFP(io);
3499                                 if (IoOFP(io) && IoOFP(io) != IoIFP(io)) {
3500                                     PerlIO_close(IoOFP(io));
3501                                 }
3502                                 IoIFP(io) = NULL;
3503                                 IoOFP(io) = NULL;
3504                             }
3505
3506                             if (i < count) {
3507                                 arg = SP[i++];
3508                             }
3509                         }
3510
3511                         if (SvROK(arg) && SvTYPE(SvRV(arg)) == SVt_PVCV) {
3512                             filter_sub = arg;
3513                             SvREFCNT_inc_simple_void_NN(filter_sub);
3514
3515                             if (i < count) {
3516                                 filter_state = SP[i];
3517                                 SvREFCNT_inc_simple_void(filter_state);
3518                             }
3519                         }
3520
3521                         if (!tryrsfp && (filter_cache || filter_sub)) {
3522                             tryrsfp = PerlIO_open(BIT_BUCKET,
3523                                                   PERL_SCRIPT_MODE);
3524                         }
3525                         SP--;
3526                     }
3527
3528                     PUTBACK;
3529                     FREETMPS;
3530                     LEAVE_with_name("call_INC");
3531
3532                     if (tryrsfp) {
3533                         hook_sv = dirsv;
3534                         break;
3535                     }
3536
3537                     filter_has_file = 0;
3538                     if (filter_cache) {
3539                         SvREFCNT_dec(filter_cache);
3540                         filter_cache = NULL;
3541                     }
3542                     if (filter_state) {
3543                         SvREFCNT_dec(filter_state);
3544                         filter_state = NULL;
3545                     }
3546                     if (filter_sub) {
3547                         SvREFCNT_dec(filter_sub);
3548                         filter_sub = NULL;
3549                     }
3550                 }
3551                 else {
3552                   if (!path_is_absolute(name)
3553                   ) {
3554                     const char *dir;
3555                     STRLEN dirlen;
3556
3557                     if (SvOK(dirsv)) {
3558                         dir = SvPV_const(dirsv, dirlen);
3559                     } else {
3560                         dir = "";
3561                         dirlen = 0;
3562                     }
3563
3564 #ifdef VMS
3565                     char *unixdir;
3566                     if ((unixdir = tounixpath(dir, NULL)) == NULL)
3567                         continue;
3568                     sv_setpv(namesv, unixdir);
3569                     sv_catpv(namesv, unixname);
3570 #else
3571 #  ifdef __SYMBIAN32__
3572                     if (PL_origfilename[0] &&
3573                         PL_origfilename[1] == ':' &&
3574                         !(dir[0] && dir[1] == ':'))
3575                         Perl_sv_setpvf(aTHX_ namesv,
3576                                        "%c:%s\\%s",
3577                                        PL_origfilename[0],
3578                                        dir, name);
3579                     else
3580                         Perl_sv_setpvf(aTHX_ namesv,
3581                                        "%s\\%s",
3582                                        dir, name);
3583 #  else
3584                     /* The equivalent of
3585                        Perl_sv_setpvf(aTHX_ namesv, "%s/%s", dir, name);
3586                        but without the need to parse the format string, or
3587                        call strlen on either pointer, and with the correct
3588                        allocation up front.  */
3589                     {
3590                         char *tmp = SvGROW(namesv, dirlen + len + 2);
3591
3592                         memcpy(tmp, dir, dirlen);
3593                         tmp +=dirlen;
3594                         *tmp++ = '/';
3595                         /* name came from an SV, so it will have a '\0' at the
3596                            end that we can copy as part of this memcpy().  */
3597                         memcpy(tmp, name, len + 1);
3598
3599                         SvCUR_set(namesv, dirlen + len + 1);
3600
3601                         /* Don't even actually have to turn SvPOK_on() as we
3602                            access it directly with SvPVX() below.  */
3603                     }
3604 #  endif
3605 #endif
3606                     TAINT_PROPER("require");
3607                     tryname = SvPVX_const(namesv);
3608                     tryrsfp = doopen_pm(tryname, SvCUR(namesv));
3609                     if (tryrsfp) {
3610                         if (tryname[0] == '.' && tryname[1] == '/') {
3611                             ++tryname;
3612                             while (*++tryname == '/');
3613                         }
3614                         break;
3615                     }
3616                     else if (errno == EMFILE)
3617                         /* no point in trying other paths if out of handles */
3618                         break;
3619                   }
3620                 }
3621             }
3622         }
3623     }
3624     SAVECOPFILE_FREE(&PL_compiling);
3625     CopFILE_set(&PL_compiling, tryrsfp ? tryname : name);
3626     SvREFCNT_dec(namesv);
3627     if (!tryrsfp) {
3628         if (PL_op->op_type == OP_REQUIRE) {
3629             const char *msgstr = name;
3630             if(errno == EMFILE) {
3631                 SV * const msg
3632                     = sv_2mortal(Perl_newSVpvf(aTHX_ "%s:   %s", msgstr,
3633                                                Strerror(errno)));
3634                 msgstr = SvPV_nolen_const(msg);
3635             } else {
3636                 if (namesv) {                   /* did we lookup @INC? */
3637                     AV * const ar = GvAVn(PL_incgv);
3638                     I32 i;
3639                     SV * const msg = sv_2mortal(Perl_newSVpvf(aTHX_
3640                         "%s in @INC%s%s (@INC contains:",
3641                         msgstr,
3642                         (instr(msgstr, ".h ")
3643                          ? " (change .h to .ph maybe?)" : ""),
3644                         (instr(msgstr, ".ph ")
3645                          ? " (did you run h2ph?)" : "")
3646                                                               ));
3647
3648                     for (i = 0; i <= AvFILL(ar); i++) {
3649                         sv_catpvs(msg, " ");
3650                         sv_catsv(msg, *av_fetch(ar, i, TRUE));
3651                     }
3652                     sv_catpvs(msg, ")");
3653                     msgstr = SvPV_nolen_const(msg);
3654                 }
3655             }
3656             DIE(aTHX_ "Can't locate %s", msgstr);
3657         }
3658
3659         RETPUSHUNDEF;
3660     }
3661     else
3662         SETERRNO(0, SS_NORMAL);
3663
3664     /* Assume success here to prevent recursive requirement. */
3665     /* name is never assigned to again, so len is still strlen(name)  */
3666     /* Check whether a hook in @INC has already filled %INC */
3667     if (!hook_sv) {
3668         (void)hv_store(GvHVn(PL_incgv),
3669                        unixname, unixlen, newSVpv(CopFILE(&PL_compiling),0),0);
3670     } else {
3671         SV** const svp = hv_fetch(GvHVn(PL_incgv), unixname, unixlen, 0);
3672         if (!svp)
3673             (void)hv_store(GvHVn(PL_incgv),
3674                            unixname, unixlen, SvREFCNT_inc_simple(hook_sv), 0 );
3675     }
3676
3677     ENTER_with_name("eval");
3678     SAVETMPS;
3679     lex_start(NULL, tryrsfp, TRUE);
3680
3681     SAVEHINTS();
3682     PL_hints = 0;
3683     hv_clear(GvHV(PL_hintgv));
3684
3685     SAVECOMPILEWARNINGS();
3686     if (PL_dowarn & G_WARN_ALL_ON)
3687         PL_compiling.cop_warnings = pWARN_ALL ;
3688     else if (PL_dowarn & G_WARN_ALL_OFF)
3689         PL_compiling.cop_warnings = pWARN_NONE ;
3690     else
3691         PL_compiling.cop_warnings = pWARN_STD ;
3692
3693     if (filter_sub || filter_cache) {
3694         /* We can use the SvPV of the filter PVIO itself as our cache, rather
3695            than hanging another SV from it. In turn, filter_add() optionally
3696            takes the SV to use as the filter (or creates a new SV if passed
3697            NULL), so simply pass in whatever value filter_cache has.  */
3698         SV * const datasv = filter_add(S_run_user_filter, filter_cache);
3699         IoLINES(datasv) = filter_has_file;
3700         IoTOP_GV(datasv) = MUTABLE_GV(filter_state);
3701         IoBOTTOM_GV(datasv) = MUTABLE_GV(filter_sub);
3702     }
3703
3704     /* switch to eval mode */
3705     PUSHBLOCK(cx, CXt_EVAL, SP);
3706     PUSHEVAL(cx, name);
3707     cx->blk_eval.retop = PL_op->op_next;
3708
3709     SAVECOPLINE(&PL_compiling);
3710     CopLINE_set(&PL_compiling, 0);
3711
3712     PUTBACK;
3713
3714     /* Store and reset encoding. */
3715     encoding = PL_encoding;
3716     PL_encoding = NULL;
3717
3718     if (doeval(gimme, NULL, NULL, PL_curcop->cop_seq))
3719         op = DOCATCH(PL_eval_start);
3720     else
3721         op = PL_op->op_next;
3722
3723     /* Restore encoding. */
3724     PL_encoding = encoding;
3725
3726     return op;
3727 }
3728
3729 /* This is a op added to hold the hints hash for
3730    pp_entereval. The hash can be modified by the code
3731    being eval'ed, so we return a copy instead. */
3732
3733 PP(pp_hintseval)
3734 {
3735     dVAR;
3736     dSP;
3737     mXPUSHs(MUTABLE_SV(Perl_hv_copy_hints_hv(aTHX_ MUTABLE_HV(cSVOP_sv))));
3738     RETURN;
3739 }
3740
3741
3742 PP(pp_entereval)
3743 {
3744     dVAR; dSP;
3745     register PERL_CONTEXT *cx;
3746     SV *sv;
3747     const I32 gimme = GIMME_V;
3748     const U32 was = PL_breakable_sub_gen;
3749     char tbuf[TYPE_DIGITS(long) + 12];
3750     char *tmpbuf = tbuf;
3751     STRLEN len;
3752     CV* runcv;
3753     U32 seq;
3754     HV *saved_hh = NULL;
3755
3756     if (PL_op->op_private & OPpEVAL_HAS_HH) {
3757         saved_hh = MUTABLE_HV(SvREFCNT_inc(POPs));
3758     }
3759     sv = POPs;
3760
3761     TAINT_IF(SvTAINTED(sv));
3762     TAINT_PROPER("eval");
3763
3764     ENTER_with_name("eval");
3765     lex_start(sv, NULL, FALSE);
3766     SAVETMPS;
3767
3768     /* switch to eval mode */
3769
3770     if (PERLDB_NAMEEVAL && CopLINE(PL_curcop)) {
3771         SV * const temp_sv = sv_newmortal();
3772         Perl_sv_setpvf(aTHX_ temp_sv, "_<(eval %lu)[%s:%"IVdf"]",
3773                        (unsigned long)++PL_evalseq,
3774                        CopFILE(PL_curcop), (IV)CopLINE(PL_curcop));
3775         tmpbuf = SvPVX(temp_sv);
3776         len = SvCUR(temp_sv);
3777     }
3778     else
3779         len = my_snprintf(tmpbuf, sizeof(tbuf), "_<(eval %lu)", (unsigned long)++PL_evalseq);
3780     SAVECOPFILE_FREE(&PL_compiling);
3781     CopFILE_set(&PL_compiling, tmpbuf+2);
3782     SAVECOPLINE(&PL_compiling);
3783     CopLINE_set(&PL_compiling, 1);
3784     /* XXX For C<eval "...">s within BEGIN {} blocks, this ends up
3785        deleting the eval's FILEGV from the stash before gv_check() runs
3786        (i.e. before run-time proper). To work around the coredump that
3787        ensues, we always turn GvMULTI_on for any globals that were
3788        introduced within evals. See force_ident(). GSAR 96-10-12 */
3789     SAVEHINTS();
3790     PL_hints = PL_op->op_targ;
3791     if (saved_hh) {
3792         /* SAVEHINTS created a new HV in PL_hintgv, which we need to GC */
3793         SvREFCNT_dec(GvHV(PL_hintgv));
3794         GvHV(PL_hintgv) = saved_hh;
3795     }
3796     SAVECOMPILEWARNINGS();
3797     PL_compiling.cop_warnings = DUP_WARNINGS(PL_curcop->cop_warnings);
3798     if (PL_compiling.cop_hints_hash) {
3799         Perl_refcounted_he_free(aTHX_ PL_compiling.cop_hints_hash);
3800     }
3801     if (Perl_fetch_cop_label(aTHX_ PL_curcop->cop_hints_hash, NULL, NULL)) {
3802         /* The label, if present, is the first entry on the chain. So rather
3803            than writing a blank label in front of it (which involves an
3804            allocation), just use the next entry in the chain.  */
3805         PL_compiling.cop_hints_hash
3806             = PL_curcop->cop_hints_hash->refcounted_he_next;
3807         /* Check the assumption that this removed the label.  */
3808         assert(Perl_fetch_cop_label(aTHX_ PL_compiling.cop_hints_hash, NULL,
3809                                     NULL) == NULL);
3810     }
3811     else
3812         PL_compiling.cop_hints_hash = PL_curcop->cop_hints_hash;
3813     if (PL_compiling.cop_hints_hash) {
3814         HINTS_REFCNT_LOCK;
3815         PL_compiling.cop_hints_hash->refcounted_he_refcnt++;
3816         HINTS_REFCNT_UNLOCK;
3817     }
3818     /* special case: an eval '' executed within the DB package gets lexically
3819      * placed in the first non-DB CV rather than the current CV - this
3820      * allows the debugger to execute code, find lexicals etc, in the
3821      * scope of the code being debugged. Passing &seq gets find_runcv
3822      * to do the dirty work for us */
3823     runcv = find_runcv(&seq);
3824
3825     PUSHBLOCK(cx, (CXt_EVAL|CXp_REAL), SP);
3826     PUSHEVAL(cx, 0);
3827     cx->blk_eval.retop = PL_op->op_next;
3828
3829     /* prepare to compile string */
3830
3831     if ((PERLDB_LINE || PERLDB_SAVESRC) && PL_curstash != PL_debstash)
3832         save_lines(CopFILEAV(&PL_compiling), PL_parser->linestr);
3833     PUTBACK;
3834
3835     if (doeval(gimme, NULL, runcv, seq)) {
3836         if (was != PL_breakable_sub_gen /* Some subs defined here. */
3837             ? (PERLDB_LINE || PERLDB_SAVESRC)
3838             :  PERLDB_SAVESRC_NOSUBS) {
3839             /* Retain the filegv we created.  */
3840         } else {
3841             char *const safestr = savepvn(tmpbuf, len);
3842             SAVEDELETE(PL_defstash, safestr, len);
3843         }
3844         return DOCATCH(PL_eval_start);
3845     } else {
3846         /* We have already left the scope set up earler thanks to the LEAVE
3847            in doeval().  */
3848         if (was != PL_breakable_sub_gen /* Some subs defined here. */
3849             ? (PERLDB_LINE || PERLDB_SAVESRC)
3850             :  PERLDB_SAVESRC_INVALID) {
3851             /* Retain the filegv we created.  */
3852         } else {
3853             (void)hv_delete(PL_defstash, tmpbuf, len, G_DISCARD);
3854         }
3855         return PL_op->op_next;
3856     }
3857 }
3858
3859 PP(pp_leaveeval)
3860 {
3861     dVAR; dSP;
3862     register SV **mark;
3863     SV **newsp;
3864     PMOP *newpm;
3865     I32 gimme;
3866     register PERL_CONTEXT *cx;
3867     OP *retop;
3868     const U8 save_flags = PL_op -> op_flags;
3869     I32 optype;
3870     SV *namesv;
3871
3872     POPBLOCK(cx,newpm);
3873     POPEVAL(cx);
3874     namesv = cx->blk_eval.old_namesv;
3875     retop = cx->blk_eval.retop;
3876
3877     TAINT_NOT;
3878     if (gimme == G_VOID)
3879         MARK = newsp;
3880     else if (gimme == G_SCALAR) {
3881         MARK = newsp + 1;
3882         if (MARK <= SP) {
3883             if (SvFLAGS(TOPs) & SVs_TEMP)
3884                 *MARK = TOPs;
3885             else
3886                 *MARK = sv_mortalcopy(TOPs);
3887         }
3888         else {
3889             MEXTEND(mark,0);
3890             *MARK = &PL_sv_undef;
3891         }
3892         SP = MARK;
3893     }
3894     else {
3895         /* in case LEAVE wipes old return values */
3896         for (mark = newsp + 1; mark <= SP; mark++) {
3897             if (!(SvFLAGS(*mark) & SVs_TEMP)) {
3898                 *mark = sv_mortalcopy(*mark);
3899                 TAINT_NOT;      /* Each item is independent */
3900             }
3901         }
3902     }
3903     PL_curpm = newpm;   /* Don't pop $1 et al till now */
3904
3905 #ifdef DEBUGGING
3906     assert(CvDEPTH(PL_compcv) == 1);
3907 #endif
3908     CvDEPTH(PL_compcv) = 0;
3909     lex_end();
3910
3911     if (optype == OP_REQUIRE &&
3912         !(gimme == G_SCALAR ? SvTRUE(*SP) : SP > newsp))
3913     {
3914         /* Unassume the success we assumed earlier. */
3915         (void)hv_delete(GvHVn(PL_incgv),
3916                         SvPVX_const(namesv), SvCUR(namesv),
3917                         G_DISCARD);
3918         retop = Perl_die(aTHX_ "%"SVf" did not return a true value",
3919                                SVfARG(namesv));
3920         /* die_unwind() did LEAVE, or we won't be here */
3921     }
3922     else {
3923         LEAVE_with_name("eval");
3924         if (!(save_flags & OPf_SPECIAL)) {
3925             CLEAR_ERRSV();
3926         }
3927     }
3928
3929     RETURNOP(retop);
3930 }
3931
3932 /* Common code for Perl_call_sv and Perl_fold_constants, put here to keep it
3933    close to the related Perl_create_eval_scope.  */
3934 void
3935 Perl_delete_eval_scope(pTHX)
3936 {
3937     SV **newsp;
3938     PMOP *newpm;
3939     I32 gimme;
3940     register PERL_CONTEXT *cx;
3941     I32 optype;
3942
3943     POPBLOCK(cx,newpm);
3944     POPEVAL(cx);
3945     PL_curpm = newpm;
3946     LEAVE_with_name("eval_scope");
3947     PERL_UNUSED_VAR(newsp);
3948     PERL_UNUSED_VAR(gimme);
3949     PERL_UNUSED_VAR(optype);
3950 }
3951
3952 /* Common-ish code salvaged from Perl_call_sv and pp_entertry, because it was
3953    also needed by Perl_fold_constants.  */
3954 PERL_CONTEXT *
3955 Perl_create_eval_scope(pTHX_ U32 flags)
3956 {
3957     PERL_CONTEXT *cx;
3958     const I32 gimme = GIMME_V;
3959
3960     ENTER_with_name("eval_scope");
3961     SAVETMPS;
3962
3963     PUSHBLOCK(cx, (CXt_EVAL|CXp_TRYBLOCK), PL_stack_sp);
3964     PUSHEVAL(cx, 0);
3965
3966     PL_in_eval = EVAL_INEVAL;
3967     if (flags & G_KEEPERR)
3968         PL_in_eval |= EVAL_KEEPERR;
3969     else
3970         CLEAR_ERRSV();
3971     if (flags & G_FAKINGEVAL) {
3972         PL_eval_root = PL_op; /* Only needed so that goto works right. */
3973     }
3974     return cx;
3975 }
3976
3977 PP(pp_entertry)
3978 {
3979     dVAR;
3980     PERL_CONTEXT * const cx = create_eval_scope(0);
3981     cx->blk_eval.retop = cLOGOP->op_other->op_next;
3982     return DOCATCH(PL_op->op_next);
3983 }
3984
3985 PP(pp_leavetry)
3986 {
3987     dVAR; dSP;
3988     SV **newsp;
3989     PMOP *newpm;
3990     I32 gimme;
3991     register PERL_CONTEXT *cx;
3992     I32 optype;
3993
3994     POPBLOCK(cx,newpm);
3995     POPEVAL(cx);
3996     PERL_UNUSED_VAR(optype);
3997
3998     TAINT_NOT;
3999     if (gimme == G_VOID)
4000         SP = newsp;
4001     else if (gimme == G_SCALAR) {
4002         register SV **mark;
4003         MARK = newsp + 1;
4004         if (MARK <= SP) {
4005             if (SvFLAGS(TOPs) & (SVs_PADTMP|SVs_TEMP))
4006                 *MARK = TOPs;
4007             else
4008                 *MARK = sv_mortalcopy(TOPs);
4009         }
4010         else {
4011             MEXTEND(mark,0);
4012             *MARK = &PL_sv_undef;
4013         }
4014         SP = MARK;
4015     }
4016     else {
4017         /* in case LEAVE wipes old return values */
4018         register SV **mark;
4019         for (mark = newsp + 1; mark <= SP; mark++) {
4020             if (!(SvFLAGS(*mark) & (SVs_PADTMP|SVs_TEMP))) {
4021                 *mark = sv_mortalcopy(*mark);
4022                 TAINT_NOT;      /* Each item is independent */
4023             }
4024         }
4025     }
4026     PL_curpm = newpm;   /* Don't pop $1 et al till now */
4027
4028     LEAVE_with_name("eval_scope");
4029     CLEAR_ERRSV();
4030     RETURN;
4031 }
4032
4033 PP(pp_entergiven)
4034 {
4035     dVAR; dSP;
4036     register PERL_CONTEXT *cx;
4037     const I32 gimme = GIMME_V;
4038
4039     ENTER_with_name("given");
4040     SAVETMPS;
4041
4042     sv_setsv(PAD_SV(PL_op->op_targ), POPs);
4043
4044     PUSHBLOCK(cx, CXt_GIVEN, SP);
4045     PUSHGIVEN(cx);
4046
4047     RETURN;
4048 }
4049
4050 PP(pp_leavegiven)
4051 {
4052     dVAR; dSP;
4053     register PERL_CONTEXT *cx;
4054     I32 gimme;
4055     SV **newsp;
4056     PMOP *newpm;
4057     PERL_UNUSED_CONTEXT;
4058
4059     POPBLOCK(cx,newpm);
4060     assert(CxTYPE(cx) == CXt_GIVEN);
4061
4062     SP = newsp;
4063     PUTBACK;
4064
4065     PL_curpm = newpm;   /* pop $1 et al */
4066
4067     LEAVE_with_name("given");
4068
4069     return NORMAL;
4070 }
4071
4072 /* Helper routines used by pp_smartmatch */
4073 STATIC PMOP *
4074 S_make_matcher(pTHX_ REGEXP *re)
4075 {
4076     dVAR;
4077     PMOP *matcher = (PMOP *) newPMOP(OP_MATCH, OPf_WANT_SCALAR | OPf_STACKED);
4078
4079     PERL_ARGS_ASSERT_MAKE_MATCHER;
4080
4081     PM_SETRE(matcher, ReREFCNT_inc(re));
4082
4083     SAVEFREEOP((OP *) matcher);
4084     ENTER_with_name("matcher"); SAVETMPS;
4085     SAVEOP();
4086     return matcher;
4087 }
4088
4089 STATIC bool
4090 S_matcher_matches_sv(pTHX_ PMOP *matcher, SV *sv)
4091 {
4092     dVAR;
4093     dSP;
4094
4095     PERL_ARGS_ASSERT_MATCHER_MATCHES_SV;
4096
4097     PL_op = (OP *) matcher;
4098     XPUSHs(sv);
4099     PUTBACK;
4100     (void) pp_match();
4101     SPAGAIN;
4102     return (SvTRUEx(POPs));
4103 }
4104
4105 STATIC void
4106 S_destroy_matcher(pTHX_ PMOP *matcher)
4107 {
4108     dVAR;
4109
4110     PERL_ARGS_ASSERT_DESTROY_MATCHER;
4111     PERL_UNUSED_ARG(matcher);
4112
4113     FREETMPS;
4114     LEAVE_with_name("matcher");
4115 }
4116
4117 /* Do a smart match */
4118 PP(pp_smartmatch)
4119 {
4120     DEBUG_M(Perl_deb(aTHX_ "Starting smart match resolution\n"));
4121     return do_smartmatch(NULL, NULL);
4122 }
4123
4124 /* This version of do_smartmatch() implements the
4125  * table of smart matches that is found in perlsyn.
4126  */
4127 STATIC OP *
4128 S_do_smartmatch(pTHX_ HV *seen_this, HV *seen_other)
4129 {
4130     dVAR;
4131     dSP;
4132
4133     bool object_on_left = FALSE;
4134     SV *e = TOPs;       /* e is for 'expression' */
4135     SV *d = TOPm1s;     /* d is for 'default', as in PL_defgv */
4136
4137     /* First of all, handle overload magic of the rightmost argument */
4138     if (SvAMAGIC(e)) {
4139         SV * tmpsv;
4140         DEBUG_M(Perl_deb(aTHX_ "    applying rule Any-Object\n"));
4141         DEBUG_M(Perl_deb(aTHX_ "        attempting overload\n"));
4142
4143         tmpsv = amagic_call(d, e, smart_amg, 0);
4144         if (tmpsv) {
4145             SPAGAIN;
4146             (void)POPs;
4147             SETs(tmpsv);
4148             RETURN;
4149         }
4150         DEBUG_M(Perl_deb(aTHX_ "        failed to run overload method; continuing...\n"));
4151     }
4152
4153     SP -= 2;    /* Pop the values */
4154
4155     /* Take care only to invoke mg_get() once for each argument.
4156      * Currently we do this by copying the SV if it's magical. */
4157     if (d) {
4158         if (SvGMAGICAL(d))
4159             d = sv_mortalcopy(d);
4160     }
4161     else
4162         d = &PL_sv_undef;
4163
4164     assert(e);
4165     if (SvGMAGICAL(e))
4166         e = sv_mortalcopy(e);
4167
4168     /* ~~ undef */
4169     if (!SvOK(e)) {
4170         DEBUG_M(Perl_deb(aTHX_ "    applying rule Any-undef\n"));
4171         if (SvOK(d))
4172             RETPUSHNO;
4173         else
4174             RETPUSHYES;
4175     }
4176
4177     if (sv_isobject(e) && (SvTYPE(SvRV(e)) != SVt_REGEXP)) {
4178         DEBUG_M(Perl_deb(aTHX_ "    applying rule Any-Object\n"));
4179         Perl_croak(aTHX_ "Smart matching a non-overloaded object breaks encapsulation");
4180     }
4181     if (sv_isobject(d) && (SvTYPE(SvRV(d)) != SVt_REGEXP))
4182         object_on_left = TRUE;
4183
4184     /* ~~ sub */
4185     if (SvROK(e) && SvTYPE(SvRV(e)) == SVt_PVCV) {
4186         I32 c;
4187         if (object_on_left) {
4188             goto sm_any_sub; /* Treat objects like scalars */
4189         }
4190         else if (SvROK(d) && SvTYPE(SvRV(d)) == SVt_PVHV) {
4191             /* Test sub truth for each key */
4192             HE *he;
4193             bool andedresults = TRUE;
4194             HV *hv = (HV*) SvRV(d);
4195             I32 numkeys = hv_iterinit(hv);
4196             DEBUG_M(Perl_deb(aTHX_ "    applying rule Hash-CodeRef\n"));
4197             if (numkeys == 0)
4198                 RETPUSHYES;
4199             while ( (he = hv_iternext(hv)) ) {
4200                 DEBUG_M(Perl_deb(aTHX_ "        testing hash key...\n"));
4201                 ENTER_with_name("smartmatch_hash_key_test");
4202                 SAVETMPS;
4203                 PUSHMARK(SP);
4204                 PUSHs(hv_iterkeysv(he));
4205                 PUTBACK;
4206                 c = call_sv(e, G_SCALAR);
4207                 SPAGAIN;
4208                 if (c == 0)
4209                     andedresults = FALSE;
4210                 else
4211                     andedresults = SvTRUEx(POPs) && andedresults;
4212                 FREETMPS;
4213                 LEAVE_with_name("smartmatch_hash_key_test");
4214             }
4215             if (andedresults)
4216                 RETPUSHYES;
4217             else
4218                 RETPUSHNO;
4219         }
4220         else if (SvROK(d) && SvTYPE(SvRV(d)) == SVt_PVAV) {
4221             /* Test sub truth for each element */
4222             I32 i;
4223             bool andedresults = TRUE;
4224             AV *av = (AV*) SvRV(d);
4225             const I32 len = av_len(av);
4226             DEBUG_M(Perl_deb(aTHX_ "    applying rule Array-CodeRef\n"));
4227             if (len == -1)
4228                 RETPUSHYES;
4229             for (i = 0; i <= len; ++i) {
4230                 SV * const * const svp = av_fetch(av, i, FALSE);
4231                 DEBUG_M(Perl_deb(aTHX_ "        testing array element...\n"));
4232                 ENTER_with_name("smartmatch_array_elem_test");
4233                 SAVETMPS;
4234                 PUSHMARK(SP);
4235                 if (svp)
4236                     PUSHs(*svp);
4237                 PUTBACK;
4238                 c = call_sv(e, G_SCALAR);
4239                 SPAGAIN;
4240                 if (c == 0)
4241                     andedresults = FALSE;
4242                 else
4243                     andedresults = SvTRUEx(POPs) && andedresults;
4244                 FREETMPS;
4245                 LEAVE_with_name("smartmatch_array_elem_test");
4246             }
4247             if (andedresults)
4248                 RETPUSHYES;
4249             else
4250                 RETPUSHNO;
4251         }
4252         else {
4253           sm_any_sub:
4254             DEBUG_M(Perl_deb(aTHX_ "    applying rule Any-CodeRef\n"));
4255             ENTER_with_name("smartmatch_coderef");
4256             SAVETMPS;
4257             PUSHMARK(SP);
4258             PUSHs(d);
4259             PUTBACK;
4260             c = call_sv(e, G_SCALAR);
4261             SPAGAIN;
4262             if (c == 0)
4263                 PUSHs(&PL_sv_no);
4264             else if (SvTEMP(TOPs))
4265                 SvREFCNT_inc_void(TOPs);
4266             FREETMPS;
4267             LEAVE_with_name("smartmatch_coderef");
4268             RETURN;
4269         }
4270     }
4271     /* ~~ %hash */
4272     else if (SvROK(e) && SvTYPE(SvRV(e)) == SVt_PVHV) {
4273         if (object_on_left) {
4274             goto sm_any_hash; /* Treat objects like scalars */
4275         }
4276         else if (!SvOK(d)) {
4277             DEBUG_M(Perl_deb(aTHX_ "    applying rule Any-Hash ($a undef)\n"));
4278             RETPUSHNO;
4279         }
4280         else if (SvROK(d) && SvTYPE(SvRV(d)) == SVt_PVHV) {
4281             /* Check that the key-sets are identical */
4282             HE *he;
4283             HV *other_hv = MUTABLE_HV(SvRV(d));
4284             bool tied = FALSE;
4285             bool other_tied = FALSE;
4286             U32 this_key_count  = 0,
4287                 other_key_count = 0;
4288             HV *hv = MUTABLE_HV(SvRV(e));
4289
4290             DEBUG_M(Perl_deb(aTHX_ "    applying rule Hash-Hash\n"));
4291             /* Tied hashes don't know how many keys they have. */
4292             if (SvTIED_mg((SV*)hv, PERL_MAGIC_tied)) {
4293                 tied = TRUE;
4294             }
4295             else if (SvTIED_mg((const SV *)other_hv, PERL_MAGIC_tied)) {
4296                 HV * const temp = other_hv;
4297                 other_hv = hv;
4298                 hv = temp;
4299                 tied = TRUE;
4300             }
4301             if (SvTIED_mg((const SV *)other_hv, PERL_MAGIC_tied))
4302                 other_tied = TRUE;
4303
4304             if (!tied && HvUSEDKEYS((const HV *) hv) != HvUSEDKEYS(other_hv))
4305                 RETPUSHNO;
4306
4307             /* The hashes have the same number of keys, so it suffices
4308                to check that one is a subset of the other. */
4309             (void) hv_iterinit(hv);
4310             while ( (he = hv_iternext(hv)) ) {
4311                 SV *key = hv_iterkeysv(he);
4312
4313                 DEBUG_M(Perl_deb(aTHX_ "        comparing hash key...\n"));
4314                 ++ this_key_count;
4315
4316                 if(!hv_exists_ent(other_hv, key, 0)) {
4317                     (void) hv_iterinit(hv);     /* reset iterator */
4318                     RETPUSHNO;
4319                 }
4320             }
4321
4322             if (other_tied) {
4323                 (void) hv_iterinit(other_hv);
4324                 while ( hv_iternext(other_hv) )
4325                     ++other_key_count;
4326             }
4327             else
4328                 other_key_count = HvUSEDKEYS(other_hv);
4329
4330             if (this_key_count != other_key_count)
4331                 RETPUSHNO;
4332             else
4333                 RETPUSHYES;
4334         }
4335         else if (SvROK(d) && SvTYPE(SvRV(d)) == SVt_PVAV) {
4336             AV * const other_av = MUTABLE_AV(SvRV(d));
4337             const I32 other_len = av_len(other_av) + 1;
4338             I32 i;
4339             HV *hv = MUTABLE_HV(SvRV(e));
4340
4341             DEBUG_M(Perl_deb(aTHX_ "    applying rule Array-Hash\n"));
4342             for (i = 0; i < other_len; ++i) {
4343                 SV ** const svp = av_fetch(other_av, i, FALSE);
4344                 DEBUG_M(Perl_deb(aTHX_ "        checking for key existence...\n"));
4345                 if (svp) {      /* ??? When can this not happen? */
4346                     if (hv_exists_ent(hv, *svp, 0))
4347                         RETPUSHYES;
4348                 }
4349             }
4350             RETPUSHNO;
4351         }
4352         else if (SvROK(d) && SvTYPE(SvRV(d)) == SVt_REGEXP) {
4353             DEBUG_M(Perl_deb(aTHX_ "    applying rule Regex-Hash\n"));
4354           sm_regex_hash:
4355             {
4356                 PMOP * const matcher = make_matcher((REGEXP*) SvRV(d));
4357                 HE *he;
4358                 HV *hv = MUTABLE_HV(SvRV(e));
4359
4360                 (void) hv_iterinit(hv);
4361                 while ( (he = hv_iternext(hv)) ) {
4362                     DEBUG_M(Perl_deb(aTHX_ "        testing key against pattern...\n"));
4363                     if (matcher_matches_sv(matcher, hv_iterkeysv(he))) {
4364                         (void) hv_iterinit(hv);
4365                         destroy_matcher(matcher);
4366                         RETPUSHYES;
4367                     }
4368                 }
4369                 destroy_matcher(matcher);
4370                 RETPUSHNO;
4371             }
4372         }
4373         else {
4374           sm_any_hash:
4375             DEBUG_M(Perl_deb(aTHX_ "    applying rule Any-Hash\n"));
4376             if (hv_exists_ent(MUTABLE_HV(SvRV(e)), d, 0))
4377                 RETPUSHYES;
4378             else
4379                 RETPUSHNO;
4380         }
4381     }
4382     /* ~~ @array */
4383     else if (SvROK(e) && SvTYPE(SvRV(e)) == SVt_PVAV) {
4384         if (object_on_left) {
4385             goto sm_any_array; /* Treat objects like scalars */
4386         }
4387         else if (SvROK(d) && SvTYPE(SvRV(d)) == SVt_PVHV) {
4388             AV * const other_av = MUTABLE_AV(SvRV(e));
4389             const I32 other_len = av_len(other_av) + 1;
4390             I32 i;
4391
4392             DEBUG_M(Perl_deb(aTHX_ "    applying rule Hash-Array\n"));
4393             for (i = 0; i < other_len; ++i) {
4394                 SV ** const svp = av_fetch(other_av, i, FALSE);
4395
4396                 DEBUG_M(Perl_deb(aTHX_ "        testing for key existence...\n"));
4397                 if (svp) {      /* ??? When can this not happen? */
4398                     if (hv_exists_ent(MUTABLE_HV(SvRV(d)), *svp, 0))
4399                         RETPUSHYES;
4400                 }
4401             }
4402             RETPUSHNO;
4403         }
4404         if (SvROK(d) && SvTYPE(SvRV(d)) == SVt_PVAV) {
4405             AV *other_av = MUTABLE_AV(SvRV(d));
4406             DEBUG_M(Perl_deb(aTHX_ "    applying rule Array-Array\n"));
4407             if (av_len(MUTABLE_AV(SvRV(e))) != av_len(other_av))
4408                 RETPUSHNO;
4409             else {
4410                 I32 i;
4411                 const I32 other_len = av_len(other_av);
4412
4413                 if (NULL == seen_this) {
4414                     seen_this = newHV();
4415                     (void) sv_2mortal(MUTABLE_SV(seen_this));
4416                 }
4417                 if (NULL == seen_other) {
4418                     seen_other = newHV();
4419                     (void) sv_2mortal(MUTABLE_SV(seen_other));
4420                 }
4421                 for(i = 0; i <= other_len; ++i) {
4422                     SV * const * const this_elem = av_fetch(MUTABLE_AV(SvRV(e)), i, FALSE);
4423                     SV * const * const other_elem = av_fetch(other_av, i, FALSE);
4424
4425                     if (!this_elem || !other_elem) {
4426                         if ((this_elem && SvOK(*this_elem))
4427                                 || (other_elem && SvOK(*other_elem)))
4428                             RETPUSHNO;
4429                     }
4430                     else if (hv_exists_ent(seen_this,
4431                                 sv_2mortal(newSViv(PTR2IV(*this_elem))), 0) ||
4432                             hv_exists_ent(seen_other,
4433                                 sv_2mortal(newSViv(PTR2IV(*other_elem))), 0))
4434                     {
4435                         if (*this_elem != *other_elem)
4436                             RETPUSHNO;
4437                     }
4438                     else {
4439                         (void)hv_store_ent(seen_this,
4440                                 sv_2mortal(newSViv(PTR2IV(*this_elem))),
4441                                 &PL_sv_undef, 0);
4442                         (void)hv_store_ent(seen_other,
4443                                 sv_2mortal(newSViv(PTR2IV(*other_elem))),
4444                                 &PL_sv_undef, 0);
4445                         PUSHs(*other_elem);
4446                         PUSHs(*this_elem);
4447
4448                         PUTBACK;
4449                         DEBUG_M(Perl_deb(aTHX_ "        recursively comparing array element...\n"));
4450                         (void) do_smartmatch(seen_this, seen_other);
4451                         SPAGAIN;
4452                         DEBUG_M(Perl_deb(aTHX_ "        recursion finished\n"));
4453
4454                         if (!SvTRUEx(POPs))
4455                             RETPUSHNO;
4456                     }
4457                 }
4458                 RETPUSHYES;
4459             }
4460         }
4461         else if (SvROK(d) && SvTYPE(SvRV(d)) == SVt_REGEXP) {
4462             DEBUG_M(Perl_deb(aTHX_ "    applying rule Regex-Array\n"));
4463           sm_regex_array:
4464             {
4465                 PMOP * const matcher = make_matcher((REGEXP*) SvRV(d));
4466                 const I32 this_len = av_len(MUTABLE_AV(SvRV(e)));
4467                 I32 i;
4468
4469                 for(i = 0; i <= this_len; ++i) {
4470                     SV * const * const svp = av_fetch(MUTABLE_AV(SvRV(e)), i, FALSE);
4471                     DEBUG_M(Perl_deb(aTHX_ "        testing element against pattern...\n"));
4472                     if (svp && matcher_matches_sv(matcher, *svp)) {
4473                         destroy_matcher(matcher);
4474                         RETPUSHYES;
4475                     }
4476                 }
4477                 destroy_matcher(matcher);
4478                 RETPUSHNO;
4479             }
4480         }
4481         else if (!SvOK(d)) {
4482             /* undef ~~ array */
4483             const I32 this_len = av_len(MUTABLE_AV(SvRV(e)));
4484             I32 i;
4485
4486             DEBUG_M(Perl_deb(aTHX_ "    applying rule Undef-Array\n"));
4487             for (i = 0; i <= this_len; ++i) {
4488                 SV * const * const svp = av_fetch(MUTABLE_AV(SvRV(e)), i, FALSE);
4489                 DEBUG_M(Perl_deb(aTHX_ "        testing for undef element...\n"));
4490                 if (!svp || !SvOK(*svp))
4491                     RETPUSHYES;
4492             }
4493             RETPUSHNO;
4494         }
4495         else {
4496           sm_any_array:
4497             {
4498                 I32 i;
4499                 const I32 this_len = av_len(MUTABLE_AV(SvRV(e)));
4500
4501                 DEBUG_M(Perl_deb(aTHX_ "    applying rule Any-Array\n"));
4502                 for (i = 0; i <= this_len; ++i) {
4503                     SV * const * const svp = av_fetch(MUTABLE_AV(SvRV(e)), i, FALSE);
4504                     if (!svp)
4505                         continue;
4506
4507                     PUSHs(d);
4508                     PUSHs(*svp);
4509                     PUTBACK;
4510                     /* infinite recursion isn't supposed to happen here */
4511                     DEBUG_M(Perl_deb(aTHX_ "        recursively testing array element...\n"));
4512                     (void) do_smartmatch(NULL, NULL);
4513                     SPAGAIN;
4514                     DEBUG_M(Perl_deb(aTHX_ "        recursion finished\n"));
4515                     if (SvTRUEx(POPs))
4516                         RETPUSHYES;
4517                 }
4518                 RETPUSHNO;
4519             }
4520         }
4521     }
4522     /* ~~ qr// */
4523     else if (SvROK(e) && SvTYPE(SvRV(e)) == SVt_REGEXP) {
4524         if (!object_on_left && SvROK(d) && SvTYPE(SvRV(d)) == SVt_PVHV) {
4525             SV *t = d; d = e; e = t;
4526             DEBUG_M(Perl_deb(aTHX_ "    applying rule Hash-Regex\n"));
4527             goto sm_regex_hash;
4528         }
4529         else if (!object_on_left && SvROK(d) && SvTYPE(SvRV(d)) == SVt_PVAV) {
4530             SV *t = d; d = e; e = t;
4531             DEBUG_M(Perl_deb(aTHX_ "    applying rule Array-Regex\n"));
4532             goto sm_regex_array;
4533         }
4534         else {
4535             PMOP * const matcher = make_matcher((REGEXP*) SvRV(e));
4536
4537             DEBUG_M(Perl_deb(aTHX_ "    applying rule Any-Regex\n"));
4538             PUTBACK;
4539             PUSHs(matcher_matches_sv(matcher, d)
4540                     ? &PL_sv_yes
4541                     : &PL_sv_no);
4542             destroy_matcher(matcher);
4543             RETURN;
4544         }
4545     }
4546     /* ~~ scalar */
4547     /* See if there is overload magic on left */
4548     else if (object_on_left && SvAMAGIC(d)) {
4549         SV *tmpsv;
4550         DEBUG_M(Perl_deb(aTHX_ "    applying rule Object-Any\n"));
4551         DEBUG_M(Perl_deb(aTHX_ "        attempting overload\n"));
4552         PUSHs(d); PUSHs(e);
4553         PUTBACK;
4554         tmpsv = amagic_call(d, e, smart_amg, AMGf_noright);
4555         if (tmpsv) {
4556             SPAGAIN;
4557             (void)POPs;
4558             SETs(tmpsv);
4559             RETURN;
4560         }
4561         SP -= 2;
4562         DEBUG_M(Perl_deb(aTHX_ "        failed to run overload method; falling back...\n"));
4563         goto sm_any_scalar;
4564     }
4565     else if (!SvOK(d)) {
4566         /* undef ~~ scalar ; we already know that the scalar is SvOK */
4567         DEBUG_M(Perl_deb(aTHX_ "    applying rule undef-Any\n"));
4568         RETPUSHNO;
4569     }
4570     else
4571   sm_any_scalar:
4572     if (SvNIOK(e) || (SvPOK(e) && looks_like_number(e) && SvNIOK(d))) {
4573         DEBUG_M(if (SvNIOK(e))
4574                     Perl_deb(aTHX_ "    applying rule Any-Num\n");
4575                 else
4576                     Perl_deb(aTHX_ "    applying rule Num-numish\n");
4577         );
4578         /* numeric comparison */
4579         PUSHs(d); PUSHs(e);
4580         PUTBACK;
4581         if (CopHINTS_get(PL_curcop) & HINT_INTEGER)
4582             (void) pp_i_eq();
4583         else
4584             (void) pp_eq();
4585         SPAGAIN;
4586         if (SvTRUEx(POPs))
4587             RETPUSHYES;
4588         else
4589             RETPUSHNO;
4590     }
4591
4592     /* As a last resort, use string comparison */
4593     DEBUG_M(Perl_deb(aTHX_ "    applying rule Any-Any\n"));
4594     PUSHs(d); PUSHs(e);
4595     PUTBACK;
4596     return pp_seq();
4597 }
4598
4599 PP(pp_enterwhen)
4600 {
4601     dVAR; dSP;
4602     register PERL_CONTEXT *cx;
4603     const I32 gimme = GIMME_V;
4604
4605     /* This is essentially an optimization: if the match
4606        fails, we don't want to push a context and then
4607        pop it again right away, so we skip straight
4608        to the op that follows the leavewhen.
4609     */
4610     if ((0 == (PL_op->op_flags & OPf_SPECIAL)) && !SvTRUEx(POPs))
4611         return cLOGOP->op_other->op_next;
4612
4613     ENTER_with_name("eval");
4614     SAVETMPS;
4615
4616     PUSHBLOCK(cx, CXt_WHEN, SP);
4617     PUSHWHEN(cx);
4618
4619     RETURN;
4620 }
4621
4622 PP(pp_leavewhen)
4623 {
4624     dVAR; dSP;
4625     register PERL_CONTEXT *cx;
4626     I32 gimme;
4627     SV **newsp;
4628     PMOP *newpm;
4629
4630     POPBLOCK(cx,newpm);
4631     assert(CxTYPE(cx) == CXt_WHEN);
4632
4633     SP = newsp;
4634     PUTBACK;
4635
4636     PL_curpm = newpm;   /* pop $1 et al */
4637
4638     LEAVE_with_name("eval");
4639     return NORMAL;
4640 }
4641
4642 PP(pp_continue)
4643 {
4644     dVAR;
4645     I32 cxix;
4646     register PERL_CONTEXT *cx;
4647     I32 inner;
4648
4649     cxix = dopoptowhen(cxstack_ix);
4650     if (cxix < 0)
4651         DIE(aTHX_ "Can't \"continue\" outside a when block");
4652     if (cxix < cxstack_ix)
4653         dounwind(cxix);
4654
4655     /* clear off anything above the scope we're re-entering */
4656     inner = PL_scopestack_ix;
4657     TOPBLOCK(cx);
4658     if (PL_scopestack_ix < inner)
4659         leave_scope(PL_scopestack[PL_scopestack_ix]);
4660     PL_curcop = cx->blk_oldcop;
4661     return cx->blk_givwhen.leave_op;
4662 }
4663
4664 PP(pp_break)
4665 {
4666     dVAR;
4667     I32 cxix;
4668     register PERL_CONTEXT *cx;
4669     I32 inner;
4670
4671     cxix = dopoptogiven(cxstack_ix);
4672     if (cxix < 0) {
4673         if (PL_op->op_flags & OPf_SPECIAL)
4674             DIE(aTHX_ "Can't use when() outside a topicalizer");
4675         else
4676             DIE(aTHX_ "Can't \"break\" outside a given block");
4677     }
4678     if (CxFOREACH(&cxstack[cxix]) && (0 == (PL_op->op_flags & OPf_SPECIAL)))
4679         DIE(aTHX_ "Can't \"break\" in a loop topicalizer");
4680
4681     if (cxix < cxstack_ix)
4682         dounwind(cxix);
4683
4684     /* clear off anything above the scope we're re-entering */
4685     inner = PL_scopestack_ix;
4686     TOPBLOCK(cx);
4687     if (PL_scopestack_ix < inner)
4688         leave_scope(PL_scopestack[PL_scopestack_ix]);
4689     PL_curcop = cx->blk_oldcop;
4690
4691     if (CxFOREACH(cx))
4692         return CX_LOOP_NEXTOP_GET(cx);
4693     else
4694         return cx->blk_givwhen.leave_op;
4695 }
4696
4697 STATIC OP *
4698 S_doparseform(pTHX_ SV *sv)
4699 {
4700     STRLEN len;
4701     register char *s = SvPV_force(sv, len);
4702     register char * const send = s + len;
4703     register char *base = NULL;
4704     register I32 skipspaces = 0;
4705     bool noblank   = FALSE;
4706     bool repeat    = FALSE;
4707     bool postspace = FALSE;
4708     U32 *fops;
4709     register U32 *fpc;
4710     U32 *linepc = NULL;
4711     register I32 arg;
4712     bool ischop;
4713     bool unchopnum = FALSE;
4714     int maxops = 12; /* FF_LINEMARK + FF_END + 10 (\0 without preceding \n) */
4715
4716     PERL_ARGS_ASSERT_DOPARSEFORM;
4717
4718     if (len == 0)
4719         Perl_croak(aTHX_ "Null picture in formline");
4720
4721     /* estimate the buffer size needed */
4722     for (base = s; s <= send; s++) {
4723         if (*s == '\n' || *s == '@' || *s == '^')
4724             maxops += 10;
4725     }
4726     s = base;
4727     base = NULL;
4728
4729     Newx(fops, maxops, U32);
4730     fpc = fops;
4731
4732     if (s < send) {
4733         linepc = fpc;
4734         *fpc++ = FF_LINEMARK;
4735         noblank = repeat = FALSE;
4736         base = s;
4737     }
4738
4739     while (s <= send) {
4740         switch (*s++) {
4741         default:
4742             skipspaces = 0;
4743             continue;
4744
4745         case '~':
4746             if (*s == '~') {
4747                 repeat = TRUE;
4748                 *s = ' ';
4749             }
4750             noblank = TRUE;
4751             s[-1] = ' ';
4752             /* FALL THROUGH */
4753         case ' ': case '\t':
4754             skipspaces++;
4755             continue;
4756         case 0:
4757             if (s < send) {
4758                 skipspaces = 0;
4759                 continue;
4760             } /* else FALL THROUGH */
4761         case '\n':
4762             arg = s - base;
4763             skipspaces++;
4764             arg -= skipspaces;
4765             if (arg) {
4766                 if (postspace)
4767                     *fpc++ = FF_SPACE;
4768                 *fpc++ = FF_LITERAL;
4769                 *fpc++ = (U16)arg;
4770             }
4771             postspace = FALSE;
4772             if (s <= send)
4773                 skipspaces--;
4774             if (skipspaces) {
4775                 *fpc++ = FF_SKIP;
4776                 *fpc++ = (U16)skipspaces;
4777             }
4778             skipspaces = 0;
4779             if (s <= send)
4780                 *fpc++ = FF_NEWLINE;
4781             if (noblank) {
4782                 *fpc++ = FF_BLANK;
4783                 if (repeat)
4784                     arg = fpc - linepc + 1;
4785                 else
4786                     arg = 0;
4787                 *fpc++ = (U16)arg;
4788             }
4789             if (s < send) {
4790                 linepc = fpc;
4791                 *fpc++ = FF_LINEMARK;
4792                 noblank = repeat = FALSE;
4793                 base = s;
4794             }
4795             else
4796                 s++;
4797             continue;
4798
4799         case '@':
4800         case '^':
4801             ischop = s[-1] == '^';
4802
4803             if (postspace) {
4804                 *fpc++ = FF_SPACE;
4805                 postspace = FALSE;
4806             }
4807             arg = (s - base) - 1;
4808             if (arg) {
4809                 *fpc++ = FF_LITERAL;
4810                 *fpc++ = (U16)arg;
4811             }
4812
4813             base = s - 1;
4814             *fpc++ = FF_FETCH;
4815             if (*s == '*') {
4816                 s++;
4817                 *fpc++ = 2;  /* skip the @* or ^* */
4818                 if (ischop) {
4819                     *fpc++ = FF_LINESNGL;
4820                     *fpc++ = FF_CHOP;
4821                 } else
4822                     *fpc++ = FF_LINEGLOB;
4823             }
4824             else if (*s == '#' || (*s == '.' && s[1] == '#')) {
4825                 arg = ischop ? 512 : 0;
4826                 base = s - 1;
4827                 while (*s == '#')
4828                     s++;
4829                 if (*s == '.') {
4830                     const char * const f = ++s;
4831                     while (*s == '#')
4832                         s++;
4833                     arg |= 256 + (s - f);
4834                 }
4835                 *fpc++ = s - base;              /* fieldsize for FETCH */
4836                 *fpc++ = FF_DECIMAL;
4837                 *fpc++ = (U16)arg;
4838                 unchopnum |= ! ischop;
4839             }
4840             else if (*s == '0' && s[1] == '#') {  /* Zero padded decimals */
4841                 arg = ischop ? 512 : 0;
4842                 base = s - 1;
4843                 s++;                                /* skip the '0' first */
4844                 while (*s == '#')
4845                     s++;
4846                 if (*s == '.') {
4847                     const char * const f = ++s;
4848                     while (*s == '#')
4849                         s++;
4850                     arg |= 256 + (s - f);
4851                 }
4852                 *fpc++ = s - base;                /* fieldsize for FETCH */
4853                 *fpc++ = FF_0DECIMAL;
4854                 *fpc++ = (U16)arg;
4855                 unchopnum |= ! ischop;
4856             }
4857             else {
4858                 I32 prespace = 0;
4859                 bool ismore = FALSE;
4860
4861                 if (*s == '>') {
4862                     while (*++s == '>') ;
4863                     prespace = FF_SPACE;
4864                 }
4865                 else if (*s == '|') {
4866                     while (*++s == '|') ;
4867                     prespace = FF_HALFSPACE;
4868                     postspace = TRUE;
4869                 }
4870                 else {
4871                     if (*s == '<')
4872                         while (*++s == '<') ;
4873                     postspace = TRUE;
4874                 }
4875                 if (*s == '.' && s[1] == '.' && s[2] == '.') {
4876                     s += 3;
4877                     ismore = TRUE;
4878                 }
4879                 *fpc++ = s - base;              /* fieldsize for FETCH */
4880
4881                 *fpc++ = ischop ? FF_CHECKCHOP : FF_CHECKNL;
4882
4883                 if (prespace)
4884                     *fpc++ = (U16)prespace;
4885                 *fpc++ = FF_ITEM;
4886                 if (ismore)
4887                     *fpc++ = FF_MORE;
4888                 if (ischop)
4889                     *fpc++ = FF_CHOP;
4890             }
4891             base = s;
4892             skipspaces = 0;
4893             continue;
4894         }
4895     }
4896     *fpc++ = FF_END;
4897
4898     assert (fpc <= fops + maxops); /* ensure our buffer estimate was valid */
4899     arg = fpc - fops;
4900     { /* need to jump to the next word */
4901         int z;
4902         z = WORD_ALIGN - SvCUR(sv) % WORD_ALIGN;
4903         SvGROW(sv, SvCUR(sv) + z + arg * sizeof(U32) + 4);
4904         s = SvPVX(sv) + SvCUR(sv) + z;
4905     }
4906     Copy(fops, s, arg, U32);
4907     Safefree(fops);
4908     sv_magic(sv, NULL, PERL_MAGIC_fm, NULL, 0);
4909     SvCOMPILED_on(sv);
4910
4911     if (unchopnum && repeat)
4912         DIE(aTHX_ "Repeated format line will never terminate (~~ and @#)");
4913     return 0;
4914 }
4915
4916
4917 STATIC bool
4918 S_num_overflow(NV value, I32 fldsize, I32 frcsize)
4919 {
4920     /* Can value be printed in fldsize chars, using %*.*f ? */
4921     NV pwr = 1;
4922     NV eps = 0.5;
4923     bool res = FALSE;
4924     int intsize = fldsize - (value < 0 ? 1 : 0);
4925
4926     if (frcsize & 256)
4927         intsize--;
4928     frcsize &= 255;
4929     intsize -= frcsize;
4930
4931     while (intsize--) pwr *= 10.0;
4932     while (frcsize--) eps /= 10.0;
4933
4934     if( value >= 0 ){
4935         if (value + eps >= pwr)
4936             res = TRUE;
4937     } else {
4938         if (value - eps <= -pwr)
4939             res = TRUE;
4940     }
4941     return res;
4942 }
4943
4944 static I32
4945 S_run_user_filter(pTHX_ int idx, SV *buf_sv, int maxlen)
4946 {
4947     dVAR;
4948     SV * const datasv = FILTER_DATA(idx);
4949     const int filter_has_file = IoLINES(datasv);
4950     SV * const filter_state = MUTABLE_SV(IoTOP_GV(datasv));
4951     SV * const filter_sub = MUTABLE_SV(IoBOTTOM_GV(datasv));
4952     int status = 0;
4953     SV *upstream;
4954     STRLEN got_len;
4955     char *got_p = NULL;
4956     char *prune_from = NULL;
4957     bool read_from_cache = FALSE;
4958     STRLEN umaxlen;
4959
4960     PERL_ARGS_ASSERT_RUN_USER_FILTER;
4961
4962     assert(maxlen >= 0);
4963     umaxlen = maxlen;
4964
4965     /* I was having segfault trouble under Linux 2.2.5 after a
4966        parse error occured.  (Had to hack around it with a test
4967        for PL_parser->error_count == 0.)  Solaris doesn't segfault --
4968        not sure where the trouble is yet.  XXX */
4969
4970     {
4971         SV *const cache = datasv;
4972         if (SvOK(cache)) {
4973             STRLEN cache_len;
4974             const char *cache_p = SvPV(cache, cache_len);
4975             STRLEN take = 0;
4976
4977             if (umaxlen) {
4978                 /* Running in block mode and we have some cached data already.
4979                  */
4980                 if (cache_len >= umaxlen) {
4981                     /* In fact, so much data we don't even need to call
4982                        filter_read.  */
4983                     take = umaxlen;
4984                 }
4985             } else {
4986                 const char *const first_nl =
4987                     (const char *)memchr(cache_p, '\n', cache_len);
4988                 if (first_nl) {
4989                     take = first_nl + 1 - cache_p;
4990                 }
4991             }
4992             if (take) {
4993                 sv_catpvn(buf_sv, cache_p, take);
4994                 sv_chop(cache, cache_p + take);
4995                 /* Definately not EOF  */
4996                 return 1;
4997             }
4998
4999             sv_catsv(buf_sv, cache);
5000             if (umaxlen) {
5001                 umaxlen -= cache_len;
5002             }
5003             SvOK_off(cache);
5004             read_from_cache = TRUE;
5005         }
5006     }
5007
5008     /* Filter API says that the filter appends to the contents of the buffer.
5009        Usually the buffer is "", so the details don't matter. But if it's not,
5010        then clearly what it contains is already filtered by this filter, so we
5011        don't want to pass it in a second time.
5012        I'm going to use a mortal in case the upstream filter croaks.  */
5013     upstream = ((SvOK(buf_sv) && sv_len(buf_sv)) || SvGMAGICAL(buf_sv))
5014         ? sv_newmortal() : buf_sv;
5015     SvUPGRADE(upstream, SVt_PV);
5016
5017     if (filter_has_file) {
5018         status = FILTER_READ(idx+1, upstream, 0);
5019     }
5020
5021     if (filter_sub && status >= 0) {
5022         dSP;
5023         int count;
5024
5025         ENTER_with_name("call_filter_sub");
5026         SAVE_DEFSV;
5027         SAVETMPS;
5028         EXTEND(SP, 2);
5029
5030         DEFSV_set(upstream);
5031         PUSHMARK(SP);
5032         mPUSHi(0);
5033         if (filter_state) {
5034             PUSHs(filter_state);
5035         }
5036         PUTBACK;
5037         count = call_sv(filter_sub, G_SCALAR);
5038         SPAGAIN;
5039
5040         if (count > 0) {
5041             SV *out = POPs;
5042             if (SvOK(out)) {
5043                 status = SvIV(out);
5044             }
5045         }
5046
5047         PUTBACK;
5048         FREETMPS;
5049         LEAVE_with_name("call_filter_sub");
5050     }
5051
5052     if(SvOK(upstream)) {
5053         got_p = SvPV(upstream, got_len);
5054         if (umaxlen) {
5055             if (got_len > umaxlen) {
5056                 prune_from = got_p + umaxlen;
5057             }
5058         } else {
5059             char *const first_nl = (char *)memchr(got_p, '\n', got_len);
5060             if (first_nl && first_nl + 1 < got_p + got_len) {
5061                 /* There's a second line here... */
5062                 prune_from = first_nl + 1;
5063             }
5064         }
5065     }
5066     if (prune_from) {
5067         /* Oh. Too long. Stuff some in our cache.  */
5068         STRLEN cached_len = got_p + got_len - prune_from;
5069         SV *const cache = datasv;
5070
5071         if (SvOK(cache)) {
5072             /* Cache should be empty.  */
5073             assert(!SvCUR(cache));
5074         }
5075
5076         sv_setpvn(cache, prune_from, cached_len);
5077         /* If you ask for block mode, you may well split UTF-8 characters.
5078            "If it breaks, you get to keep both parts"
5079            (Your code is broken if you  don't put them back together again
5080            before something notices.) */
5081         if (SvUTF8(upstream)) {
5082             SvUTF8_on(cache);
5083         }
5084         SvCUR_set(upstream, got_len - cached_len);
5085         *prune_from = 0;
5086         /* Can't yet be EOF  */
5087         if (status == 0)
5088             status = 1;
5089     }
5090
5091     /* If they are at EOF but buf_sv has something in it, then they may never
5092        have touched the SV upstream, so it may be undefined.  If we naively
5093        concatenate it then we get a warning about use of uninitialised value.
5094     */
5095     if (upstream != buf_sv && (SvOK(upstream) || SvGMAGICAL(upstream))) {
5096         sv_catsv(buf_sv, upstream);
5097     }
5098
5099     if (status <= 0) {
5100         IoLINES(datasv) = 0;
5101         if (filter_state) {
5102             SvREFCNT_dec(filter_state);
5103             IoTOP_GV(datasv) = NULL;
5104         }
5105         if (filter_sub) {
5106             SvREFCNT_dec(filter_sub);
5107             IoBOTTOM_GV(datasv) = NULL;
5108         }
5109         filter_del(S_run_user_filter);
5110     }
5111     if (status == 0 && read_from_cache) {
5112         /* If we read some data from the cache (and by getting here it implies
5113            that we emptied the cache) then we aren't yet at EOF, and mustn't
5114            report that to our caller.  */
5115         return 1;
5116     }
5117     return status;
5118 }
5119
5120 /* perhaps someone can come up with a better name for
5121    this?  it is not really "absolute", per se ... */
5122 static bool
5123 S_path_is_absolute(const char *name)
5124 {
5125     PERL_ARGS_ASSERT_PATH_IS_ABSOLUTE;
5126
5127     if (PERL_FILE_IS_ABSOLUTE(name)
5128 #ifdef WIN32
5129         || (*name == '.' && ((name[1] == '/' ||
5130                              (name[1] == '.' && name[2] == '/'))
5131                          || (name[1] == '\\' ||
5132                              ( name[1] == '.' && name[2] == '\\')))
5133             )
5134 #else
5135         || (*name == '.' && (name[1] == '/' ||
5136                              (name[1] == '.' && name[2] == '/')))
5137 #endif
5138          )
5139     {
5140         return TRUE;
5141     }
5142     else
5143         return FALSE;
5144 }
5145
5146 /*
5147  * Local variables:
5148  * c-indentation-style: bsd
5149  * c-basic-offset: 4
5150  * indent-tabs-mode: t
5151  * End:
5152  *
5153  * ex: set ts=8 sts=4 sw=4 noet:
5154  */