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