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