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     bool need_catch;
2918
2919     PERL_ARGS_ASSERT_SV_COMPILE_2OP;
2920
2921     ENTER_with_name("eval");
2922     lex_start(sv, NULL, FALSE);
2923     SAVETMPS;
2924     /* switch to eval mode */
2925
2926     if (IN_PERL_COMPILETIME) {
2927         SAVECOPSTASH_FREE(&PL_compiling);
2928         CopSTASH_set(&PL_compiling, PL_curstash);
2929     }
2930     if (PERLDB_NAMEEVAL && CopLINE(PL_curcop)) {
2931         SV * const sv = sv_newmortal();
2932         Perl_sv_setpvf(aTHX_ sv, "_<(%.10seval %lu)[%s:%"IVdf"]",
2933                        code, (unsigned long)++PL_evalseq,
2934                        CopFILE(PL_curcop), (IV)CopLINE(PL_curcop));
2935         tmpbuf = SvPVX(sv);
2936         len = SvCUR(sv);
2937     }
2938     else
2939         len = my_snprintf(tmpbuf, sizeof(tbuf), "_<(%.10s_eval %lu)", code,
2940                           (unsigned long)++PL_evalseq);
2941     SAVECOPFILE_FREE(&PL_compiling);
2942     CopFILE_set(&PL_compiling, tmpbuf+2);
2943     SAVECOPLINE(&PL_compiling);
2944     CopLINE_set(&PL_compiling, 1);
2945     /* XXX For C<eval "...">s within BEGIN {} blocks, this ends up
2946        deleting the eval's FILEGV from the stash before gv_check() runs
2947        (i.e. before run-time proper). To work around the coredump that
2948        ensues, we always turn GvMULTI_on for any globals that were
2949        introduced within evals. See force_ident(). GSAR 96-10-12 */
2950     safestr = savepvn(tmpbuf, len);
2951     SAVEDELETE(PL_defstash, safestr, len);
2952     SAVEHINTS();
2953 #ifdef OP_IN_REGISTER
2954     PL_opsave = op;
2955 #else
2956     SAVEVPTR(PL_op);
2957 #endif
2958
2959     /* we get here either during compilation, or via pp_regcomp at runtime */
2960     runtime = IN_PERL_RUNTIME;
2961     if (runtime)
2962         runcv = find_runcv(NULL);
2963
2964     PL_op = &dummy;
2965     PL_op->op_type = OP_ENTEREVAL;
2966     PL_op->op_flags = 0;                        /* Avoid uninit warning. */
2967     PUSHBLOCK(cx, CXt_EVAL|(IN_PERL_COMPILETIME ? 0 : CXp_REAL), SP);
2968     PUSHEVAL(cx, 0);
2969     need_catch = CATCH_GET;
2970     CATCH_SET(TRUE);
2971
2972     if (runtime)
2973         (void) doeval(G_SCALAR, startop, runcv, PL_curcop->cop_seq);
2974     else
2975         (void) doeval(G_SCALAR, startop, PL_compcv, PL_cop_seqmax);
2976     CATCH_SET(need_catch);
2977     POPBLOCK(cx,PL_curpm);
2978     POPEVAL(cx);
2979
2980     (*startop)->op_type = OP_NULL;
2981     (*startop)->op_ppaddr = PL_ppaddr[OP_NULL];
2982     lex_end();
2983     /* XXX DAPM do this properly one year */
2984     *padp = MUTABLE_AV(SvREFCNT_inc_simple(PL_comppad));
2985     LEAVE_with_name("eval");
2986     if (IN_PERL_COMPILETIME)
2987         CopHINTS_set(&PL_compiling, PL_hints);
2988 #ifdef OP_IN_REGISTER
2989     op = PL_opsave;
2990 #endif
2991     PERL_UNUSED_VAR(newsp);
2992     PERL_UNUSED_VAR(optype);
2993
2994     return PL_eval_start;
2995 }
2996
2997
2998 /*
2999 =for apidoc find_runcv
3000
3001 Locate the CV corresponding to the currently executing sub or eval.
3002 If db_seqp is non_null, skip CVs that are in the DB package and populate
3003 *db_seqp with the cop sequence number at the point that the DB:: code was
3004 entered. (allows debuggers to eval in the scope of the breakpoint rather
3005 than in the scope of the debugger itself).
3006
3007 =cut
3008 */
3009
3010 CV*
3011 Perl_find_runcv(pTHX_ U32 *db_seqp)
3012 {
3013     dVAR;
3014     PERL_SI      *si;
3015
3016     if (db_seqp)
3017         *db_seqp = PL_curcop->cop_seq;
3018     for (si = PL_curstackinfo; si; si = si->si_prev) {
3019         I32 ix;
3020         for (ix = si->si_cxix; ix >= 0; ix--) {
3021             const PERL_CONTEXT *cx = &(si->si_cxstack[ix]);
3022             if (CxTYPE(cx) == CXt_SUB || CxTYPE(cx) == CXt_FORMAT) {
3023                 CV * const cv = cx->blk_sub.cv;
3024                 /* skip DB:: code */
3025                 if (db_seqp && PL_debstash && CvSTASH(cv) == PL_debstash) {
3026                     *db_seqp = cx->blk_oldcop->cop_seq;
3027                     continue;
3028                 }
3029                 return cv;
3030             }
3031             else if (CxTYPE(cx) == CXt_EVAL && !CxTRYBLOCK(cx))
3032                 return PL_compcv;
3033         }
3034     }
3035     return PL_main_cv;
3036 }
3037
3038
3039 /* Run yyparse() in a setjmp wrapper. Returns:
3040  *   0: yyparse() successful
3041  *   1: yyparse() failed
3042  *   3: yyparse() died
3043  */
3044 STATIC int
3045 S_try_yyparse(pTHX)
3046 {
3047     int ret;
3048     dJMPENV;
3049
3050     assert(CxTYPE(&cxstack[cxstack_ix]) == CXt_EVAL);
3051     JMPENV_PUSH(ret);
3052     switch (ret) {
3053     case 0:
3054         ret = yyparse() ? 1 : 0;
3055         break;
3056     case 3:
3057         break;
3058     default:
3059         JMPENV_POP;
3060         JMPENV_JUMP(ret);
3061         /* NOTREACHED */
3062     }
3063     JMPENV_POP;
3064     return ret;
3065 }
3066
3067
3068 /* Compile a require/do, an eval '', or a /(?{...})/.
3069  * In the last case, startop is non-null, and contains the address of
3070  * a pointer that should be set to the just-compiled code.
3071  * outside is the lexically enclosing CV (if any) that invoked us.
3072  * Returns a bool indicating whether the compile was successful; if so,
3073  * PL_eval_start contains the first op of the compiled ocde; otherwise,
3074  * pushes undef (also croaks if startop != NULL).
3075  */
3076
3077 STATIC bool
3078 S_doeval(pTHX_ int gimme, OP** startop, CV* outside, U32 seq)
3079 {
3080     dVAR; dSP;
3081     OP * const saveop = PL_op;
3082     bool in_require = (saveop && saveop->op_type == OP_REQUIRE);
3083     int yystatus;
3084
3085     PL_in_eval = (in_require
3086                   ? (EVAL_INREQUIRE | (PL_in_eval & EVAL_INEVAL))
3087                   : EVAL_INEVAL);
3088
3089     PUSHMARK(SP);
3090
3091     SAVESPTR(PL_compcv);
3092     PL_compcv = MUTABLE_CV(newSV_type(SVt_PVCV));
3093     CvEVAL_on(PL_compcv);
3094     assert(CxTYPE(&cxstack[cxstack_ix]) == CXt_EVAL);
3095     cxstack[cxstack_ix].blk_eval.cv = PL_compcv;
3096
3097     CvOUTSIDE_SEQ(PL_compcv) = seq;
3098     CvOUTSIDE(PL_compcv) = MUTABLE_CV(SvREFCNT_inc_simple(outside));
3099
3100     /* set up a scratch pad */
3101
3102     CvPADLIST(PL_compcv) = pad_new(padnew_SAVE);
3103     PL_op = NULL; /* avoid PL_op and PL_curpad referring to different CVs */
3104
3105
3106     if (!PL_madskills)
3107         SAVEMORTALIZESV(PL_compcv);     /* must remain until end of current statement */
3108
3109     /* make sure we compile in the right package */
3110
3111     if (CopSTASH_ne(PL_curcop, PL_curstash)) {
3112         SAVESPTR(PL_curstash);
3113         PL_curstash = CopSTASH(PL_curcop);
3114     }
3115     /* XXX:ajgo do we really need to alloc an AV for begin/checkunit */
3116     SAVESPTR(PL_beginav);
3117     PL_beginav = newAV();
3118     SAVEFREESV(PL_beginav);
3119     SAVESPTR(PL_unitcheckav);
3120     PL_unitcheckav = newAV();
3121     SAVEFREESV(PL_unitcheckav);
3122
3123 #ifdef PERL_MAD
3124     SAVEBOOL(PL_madskills);
3125     PL_madskills = 0;
3126 #endif
3127
3128     /* try to compile it */
3129
3130     PL_eval_root = NULL;
3131     PL_curcop = &PL_compiling;
3132     CopARYBASE_set(PL_curcop, 0);
3133     if (saveop && (saveop->op_type != OP_REQUIRE) && (saveop->op_flags & OPf_SPECIAL))
3134         PL_in_eval |= EVAL_KEEPERR;
3135     else
3136         CLEAR_ERRSV();
3137
3138     CALL_BLOCK_HOOKS(eval, saveop);
3139
3140     /* note that yyparse() may raise an exception, e.g. C<BEGIN{die}>,
3141      * so honour CATCH_GET and trap it here if necessary */
3142
3143     yystatus = (!in_require && CATCH_GET) ? S_try_yyparse(aTHX) : yyparse();
3144
3145     if (yystatus || PL_parser->error_count || !PL_eval_root) {
3146         SV **newsp;                     /* Used by POPBLOCK. */
3147         PERL_CONTEXT *cx = NULL;
3148         I32 optype;                     /* Used by POPEVAL. */
3149         SV *namesv = NULL;
3150         const char *msg;
3151
3152         PERL_UNUSED_VAR(newsp);
3153         PERL_UNUSED_VAR(optype);
3154
3155         /* note that if yystatus == 3, then the EVAL CX block has already
3156          * been popped, and various vars restored */
3157         PL_op = saveop;
3158         if (yystatus != 3) {
3159             if (PL_eval_root) {
3160                 op_free(PL_eval_root);
3161                 PL_eval_root = NULL;
3162             }
3163             SP = PL_stack_base + POPMARK;       /* pop original mark */
3164             if (!startop) {
3165                 POPBLOCK(cx,PL_curpm);
3166                 POPEVAL(cx);
3167                 namesv = cx->blk_eval.old_namesv;
3168             }
3169         }
3170         lex_end();
3171         if (yystatus != 3)
3172             LEAVE_with_name("eval"); /* pp_entereval knows about this LEAVE.  */
3173
3174         msg = SvPVx_nolen_const(ERRSV);
3175         if (in_require) {
3176             if (!cx) {
3177                 /* If cx is still NULL, it means that we didn't go in the
3178                  * POPEVAL branch. */
3179                 cx = &cxstack[cxstack_ix];
3180                 assert(CxTYPE(cx) == CXt_EVAL);
3181                 namesv = cx->blk_eval.old_namesv;
3182             }
3183             (void)hv_store(GvHVn(PL_incgv),
3184                            SvPVX_const(namesv), SvCUR(namesv),
3185                            &PL_sv_undef, 0);
3186             Perl_croak(aTHX_ "%sCompilation failed in require",
3187                        *msg ? msg : "Unknown error\n");
3188         }
3189         else if (startop) {
3190             if (yystatus != 3) {
3191                 POPBLOCK(cx,PL_curpm);
3192                 POPEVAL(cx);
3193             }
3194             Perl_croak(aTHX_ "%sCompilation failed in regexp",
3195                        (*msg ? msg : "Unknown error\n"));
3196         }
3197         else {
3198             if (!*msg) {
3199                 sv_setpvs(ERRSV, "Compilation error");
3200             }
3201         }
3202         PUSHs(&PL_sv_undef);
3203         PUTBACK;
3204         return FALSE;
3205     }
3206     CopLINE_set(&PL_compiling, 0);
3207     if (startop) {
3208         *startop = PL_eval_root;
3209     } else
3210         SAVEFREEOP(PL_eval_root);
3211
3212     /* Set the context for this new optree.
3213      * Propagate the context from the eval(). */
3214     if ((gimme & G_WANT) == G_VOID)
3215         scalarvoid(PL_eval_root);
3216     else if ((gimme & G_WANT) == G_ARRAY)
3217         list(PL_eval_root);
3218     else
3219         scalar(PL_eval_root);
3220
3221     DEBUG_x(dump_eval());
3222
3223     /* Register with debugger: */
3224     if (PERLDB_INTER && saveop && saveop->op_type == OP_REQUIRE) {
3225         CV * const cv = get_cvs("DB::postponed", 0);
3226         if (cv) {
3227             dSP;
3228             PUSHMARK(SP);
3229             XPUSHs(MUTABLE_SV(CopFILEGV(&PL_compiling)));
3230             PUTBACK;
3231             call_sv(MUTABLE_SV(cv), G_DISCARD);
3232         }
3233     }
3234
3235     if (PL_unitcheckav)
3236         call_list(PL_scopestack_ix, PL_unitcheckav);
3237
3238     /* compiled okay, so do it */
3239
3240     CvDEPTH(PL_compcv) = 1;
3241     SP = PL_stack_base + POPMARK;               /* pop original mark */
3242     PL_op = saveop;                     /* The caller may need it. */
3243     PL_parser->lex_state = LEX_NOTPARSING;      /* $^S needs this. */
3244
3245     PUTBACK;
3246     return TRUE;
3247 }
3248
3249 STATIC PerlIO *
3250 S_check_type_and_open(pTHX_ const char *name)
3251 {
3252     Stat_t st;
3253     const int st_rc = PerlLIO_stat(name, &st);
3254
3255     PERL_ARGS_ASSERT_CHECK_TYPE_AND_OPEN;
3256
3257     if (st_rc < 0 || S_ISDIR(st.st_mode) || S_ISBLK(st.st_mode)) {
3258         return NULL;
3259     }
3260
3261     return PerlIO_open(name, PERL_SCRIPT_MODE);
3262 }
3263
3264 #ifndef PERL_DISABLE_PMC
3265 STATIC PerlIO *
3266 S_doopen_pm(pTHX_ const char *name, const STRLEN namelen)
3267 {
3268     PerlIO *fp;
3269
3270     PERL_ARGS_ASSERT_DOOPEN_PM;
3271
3272     if (namelen > 3 && memEQs(name + namelen - 3, 3, ".pm")) {
3273         SV *const pmcsv = newSV(namelen + 2);
3274         char *const pmc = SvPVX(pmcsv);
3275         Stat_t pmcstat;
3276
3277         memcpy(pmc, name, namelen);
3278         pmc[namelen] = 'c';
3279         pmc[namelen + 1] = '\0';
3280
3281         if (PerlLIO_stat(pmc, &pmcstat) < 0) {
3282             fp = check_type_and_open(name);
3283         }
3284         else {
3285             fp = check_type_and_open(pmc);
3286         }
3287         SvREFCNT_dec(pmcsv);
3288     }
3289     else {
3290         fp = check_type_and_open(name);
3291     }
3292     return fp;
3293 }
3294 #else
3295 #  define doopen_pm(name, namelen) check_type_and_open(name)
3296 #endif /* !PERL_DISABLE_PMC */
3297
3298 PP(pp_require)
3299 {
3300     dVAR; dSP;
3301     register PERL_CONTEXT *cx;
3302     SV *sv;
3303     const char *name;
3304     STRLEN len;
3305     char * unixname;
3306     STRLEN unixlen;
3307 #ifdef VMS
3308     int vms_unixname = 0;
3309 #endif
3310     const char *tryname = NULL;
3311     SV *namesv = NULL;
3312     const I32 gimme = GIMME_V;
3313     int filter_has_file = 0;
3314     PerlIO *tryrsfp = NULL;
3315     SV *filter_cache = NULL;
3316     SV *filter_state = NULL;
3317     SV *filter_sub = NULL;
3318     SV *hook_sv = NULL;
3319     SV *encoding;
3320     OP *op;
3321
3322     sv = POPs;
3323     if ( (SvNIOKp(sv) || SvVOK(sv)) && PL_op->op_type != OP_DOFILE) {
3324         sv = new_version(sv);
3325         if (!sv_derived_from(PL_patchlevel, "version"))
3326             upg_version(PL_patchlevel, TRUE);
3327         if (cUNOP->op_first->op_type == OP_CONST && cUNOP->op_first->op_private & OPpCONST_NOVER) {
3328             if ( vcmp(sv,PL_patchlevel) <= 0 )
3329                 DIE(aTHX_ "Perls since %"SVf" too modern--this is %"SVf", stopped",
3330                     SVfARG(vnormal(sv)), SVfARG(vnormal(PL_patchlevel)));
3331         }
3332         else {
3333             if ( vcmp(sv,PL_patchlevel) > 0 ) {
3334                 I32 first = 0;
3335                 AV *lav;
3336                 SV * const req = SvRV(sv);
3337                 SV * const pv = *hv_fetchs(MUTABLE_HV(req), "original", FALSE);
3338
3339                 /* get the left hand term */
3340                 lav = MUTABLE_AV(SvRV(*hv_fetchs(MUTABLE_HV(req), "version", FALSE)));
3341
3342                 first  = SvIV(*av_fetch(lav,0,0));
3343                 if (   first > (int)PERL_REVISION    /* probably 'use 6.0' */
3344                     || hv_exists(MUTABLE_HV(req), "qv", 2 ) /* qv style */
3345                     || av_len(lav) > 1               /* FP with > 3 digits */
3346                     || strstr(SvPVX(pv),".0")        /* FP with leading 0 */
3347                    ) {
3348                     DIE(aTHX_ "Perl %"SVf" required--this is only "
3349                         "%"SVf", stopped", SVfARG(vnormal(req)),
3350                         SVfARG(vnormal(PL_patchlevel)));
3351                 }
3352                 else { /* probably 'use 5.10' or 'use 5.8' */
3353                     SV *hintsv;
3354                     I32 second = 0;
3355
3356                     if (av_len(lav)>=1)
3357                         second = SvIV(*av_fetch(lav,1,0));
3358
3359                     second /= second >= 600  ? 100 : 10;
3360                     hintsv = Perl_newSVpvf(aTHX_ "v%d.%d.0",
3361                                            (int)first, (int)second);
3362                     upg_version(hintsv, TRUE);
3363
3364                     DIE(aTHX_ "Perl %"SVf" required (did you mean %"SVf"?)"
3365                         "--this is only %"SVf", stopped",
3366                         SVfARG(vnormal(req)),
3367                         SVfARG(vnormal(sv_2mortal(hintsv))),
3368                         SVfARG(vnormal(PL_patchlevel)));
3369                 }
3370             }
3371         }
3372
3373         /* We do this only with "use", not "require" or "no". */
3374         if (PL_compcv && !(cUNOP->op_first->op_private & OPpCONST_NOVER)) {
3375             /* If we request a version >= 5.9.5, load feature.pm with the
3376              * feature bundle that corresponds to the required version. */
3377             if (vcmp(sv, sv_2mortal(upg_version(newSVnv(5.009005), FALSE))) >= 0) {
3378                 SV *const importsv = vnormal(sv);
3379                 *SvPVX_mutable(importsv) = ':';
3380                 ENTER_with_name("load_feature");
3381                 Perl_load_module(aTHX_ 0, newSVpvs("feature"), NULL, importsv, NULL);
3382                 LEAVE_with_name("load_feature");
3383             }
3384             /* If a version >= 5.11.0 is requested, strictures are on by default! */
3385             if (vcmp(sv, sv_2mortal(upg_version(newSVnv(5.011000), FALSE))) >= 0) {
3386                 PL_hints |= (HINT_STRICT_REFS | HINT_STRICT_SUBS | HINT_STRICT_VARS);
3387             }
3388         }
3389
3390         RETPUSHYES;
3391     }
3392     name = SvPV_const(sv, len);
3393     if (!(name && len > 0 && *name))
3394         DIE(aTHX_ "Null filename used");
3395     TAINT_PROPER("require");
3396
3397
3398 #ifdef VMS
3399     /* The key in the %ENV hash is in the syntax of file passed as the argument
3400      * usually this is in UNIX format, but sometimes in VMS format, which
3401      * can result in a module being pulled in more than once.
3402      * To prevent this, the key must be stored in UNIX format if the VMS
3403      * name can be translated to UNIX.
3404      */
3405     if ((unixname = tounixspec(name, NULL)) != NULL) {
3406         unixlen = strlen(unixname);
3407         vms_unixname = 1;
3408     }
3409     else
3410 #endif
3411     {
3412         /* if not VMS or VMS name can not be translated to UNIX, pass it
3413          * through.
3414          */
3415         unixname = (char *) name;
3416         unixlen = len;
3417     }
3418     if (PL_op->op_type == OP_REQUIRE) {
3419         SV * const * const svp = hv_fetch(GvHVn(PL_incgv),
3420                                           unixname, unixlen, 0);
3421         if ( svp ) {
3422             if (*svp != &PL_sv_undef)
3423                 RETPUSHYES;
3424             else
3425                 DIE(aTHX_ "Attempt to reload %s aborted.\n"
3426                             "Compilation failed in require", unixname);
3427         }
3428     }
3429
3430     /* prepare to compile file */
3431
3432     if (path_is_absolute(name)) {
3433         tryname = name;
3434         tryrsfp = doopen_pm(name, len);
3435     }
3436     if (!tryrsfp) {
3437         AV * const ar = GvAVn(PL_incgv);
3438         I32 i;
3439 #ifdef VMS
3440         if (vms_unixname)
3441 #endif
3442         {
3443             namesv = newSV_type(SVt_PV);
3444             for (i = 0; i <= AvFILL(ar); i++) {
3445                 SV * const dirsv = *av_fetch(ar, i, TRUE);
3446
3447                 if (SvTIED_mg((const SV *)ar, PERL_MAGIC_tied))
3448                     mg_get(dirsv);
3449                 if (SvROK(dirsv)) {
3450                     int count;
3451                     SV **svp;
3452                     SV *loader = dirsv;
3453
3454                     if (SvTYPE(SvRV(loader)) == SVt_PVAV
3455                         && !sv_isobject(loader))
3456                     {
3457                         loader = *av_fetch(MUTABLE_AV(SvRV(loader)), 0, TRUE);
3458                     }
3459
3460                     Perl_sv_setpvf(aTHX_ namesv, "/loader/0x%"UVxf"/%s",
3461                                    PTR2UV(SvRV(dirsv)), name);
3462                     tryname = SvPVX_const(namesv);
3463                     tryrsfp = NULL;
3464
3465                     ENTER_with_name("call_INC");
3466                     SAVETMPS;
3467                     EXTEND(SP, 2);
3468
3469                     PUSHMARK(SP);
3470                     PUSHs(dirsv);
3471                     PUSHs(sv);
3472                     PUTBACK;
3473                     if (sv_isobject(loader))
3474                         count = call_method("INC", G_ARRAY);
3475                     else
3476                         count = call_sv(loader, G_ARRAY);
3477                     SPAGAIN;
3478
3479                     if (count > 0) {
3480                         int i = 0;
3481                         SV *arg;
3482
3483                         SP -= count - 1;
3484                         arg = SP[i++];
3485
3486                         if (SvROK(arg) && (SvTYPE(SvRV(arg)) <= SVt_PVLV)
3487                             && !isGV_with_GP(SvRV(arg))) {
3488                             filter_cache = SvRV(arg);
3489                             SvREFCNT_inc_simple_void_NN(filter_cache);
3490
3491                             if (i < count) {
3492                                 arg = SP[i++];
3493                             }
3494                         }
3495
3496                         if (SvROK(arg) && isGV_with_GP(SvRV(arg))) {
3497                             arg = SvRV(arg);
3498                         }
3499
3500                         if (isGV_with_GP(arg)) {
3501                             IO * const io = GvIO((const GV *)arg);
3502
3503                             ++filter_has_file;
3504
3505                             if (io) {
3506                                 tryrsfp = IoIFP(io);
3507                                 if (IoOFP(io) && IoOFP(io) != IoIFP(io)) {
3508                                     PerlIO_close(IoOFP(io));
3509                                 }
3510                                 IoIFP(io) = NULL;
3511                                 IoOFP(io) = NULL;
3512                             }
3513
3514                             if (i < count) {
3515                                 arg = SP[i++];
3516                             }
3517                         }
3518
3519                         if (SvROK(arg) && SvTYPE(SvRV(arg)) == SVt_PVCV) {
3520                             filter_sub = arg;
3521                             SvREFCNT_inc_simple_void_NN(filter_sub);
3522
3523                             if (i < count) {
3524                                 filter_state = SP[i];
3525                                 SvREFCNT_inc_simple_void(filter_state);
3526                             }
3527                         }
3528
3529                         if (!tryrsfp && (filter_cache || filter_sub)) {
3530                             tryrsfp = PerlIO_open(BIT_BUCKET,
3531                                                   PERL_SCRIPT_MODE);
3532                         }
3533                         SP--;
3534                     }
3535
3536                     PUTBACK;
3537                     FREETMPS;
3538                     LEAVE_with_name("call_INC");
3539
3540                     /* Adjust file name if the hook has set an %INC entry.
3541                        This needs to happen after the FREETMPS above.  */
3542                     svp = hv_fetch(GvHVn(PL_incgv), name, len, 0);
3543                     if (svp)
3544                         tryname = SvPV_nolen_const(*svp);
3545
3546                     if (tryrsfp) {
3547                         hook_sv = dirsv;
3548                         break;
3549                     }
3550
3551                     filter_has_file = 0;
3552                     if (filter_cache) {
3553                         SvREFCNT_dec(filter_cache);
3554                         filter_cache = NULL;
3555                     }
3556                     if (filter_state) {
3557                         SvREFCNT_dec(filter_state);
3558                         filter_state = NULL;
3559                     }
3560                     if (filter_sub) {
3561                         SvREFCNT_dec(filter_sub);
3562                         filter_sub = NULL;
3563                     }
3564                 }
3565                 else {
3566                   if (!path_is_absolute(name)
3567                   ) {
3568                     const char *dir;
3569                     STRLEN dirlen;
3570
3571                     if (SvOK(dirsv)) {
3572                         dir = SvPV_const(dirsv, dirlen);
3573                     } else {
3574                         dir = "";
3575                         dirlen = 0;
3576                     }
3577
3578 #ifdef VMS
3579                     char *unixdir;
3580                     if ((unixdir = tounixpath(dir, NULL)) == NULL)
3581                         continue;
3582                     sv_setpv(namesv, unixdir);
3583                     sv_catpv(namesv, unixname);
3584 #else
3585 #  ifdef __SYMBIAN32__
3586                     if (PL_origfilename[0] &&
3587                         PL_origfilename[1] == ':' &&
3588                         !(dir[0] && dir[1] == ':'))
3589                         Perl_sv_setpvf(aTHX_ namesv,
3590                                        "%c:%s\\%s",
3591                                        PL_origfilename[0],
3592                                        dir, name);
3593                     else
3594                         Perl_sv_setpvf(aTHX_ namesv,
3595                                        "%s\\%s",
3596                                        dir, name);
3597 #  else
3598                     /* The equivalent of
3599                        Perl_sv_setpvf(aTHX_ namesv, "%s/%s", dir, name);
3600                        but without the need to parse the format string, or
3601                        call strlen on either pointer, and with the correct
3602                        allocation up front.  */
3603                     {
3604                         char *tmp = SvGROW(namesv, dirlen + len + 2);
3605
3606                         memcpy(tmp, dir, dirlen);
3607                         tmp +=dirlen;
3608                         *tmp++ = '/';
3609                         /* name came from an SV, so it will have a '\0' at the
3610                            end that we can copy as part of this memcpy().  */
3611                         memcpy(tmp, name, len + 1);
3612
3613                         SvCUR_set(namesv, dirlen + len + 1);
3614
3615                         /* Don't even actually have to turn SvPOK_on() as we
3616                            access it directly with SvPVX() below.  */
3617                     }
3618 #  endif
3619 #endif
3620                     TAINT_PROPER("require");
3621                     tryname = SvPVX_const(namesv);
3622                     tryrsfp = doopen_pm(tryname, SvCUR(namesv));
3623                     if (tryrsfp) {
3624                         if (tryname[0] == '.' && tryname[1] == '/') {
3625                             ++tryname;
3626                             while (*++tryname == '/');
3627                         }
3628                         break;
3629                     }
3630                     else if (errno == EMFILE)
3631                         /* no point in trying other paths if out of handles */
3632                         break;
3633                   }
3634                 }
3635             }
3636         }
3637     }
3638     if (tryrsfp) {
3639         SAVECOPFILE_FREE(&PL_compiling);
3640         CopFILE_set(&PL_compiling, tryname);
3641     }
3642     SvREFCNT_dec(namesv);
3643     if (!tryrsfp) {
3644         if (PL_op->op_type == OP_REQUIRE) {
3645             if(errno == EMFILE) {
3646                 /* diag_listed_as: Can't locate %s */
3647                 DIE(aTHX_ "Can't locate %s:   %s", name, Strerror(errno));
3648             } else {
3649                 if (namesv) {                   /* did we lookup @INC? */
3650                     AV * const ar = GvAVn(PL_incgv);
3651                     I32 i;
3652                     SV *const inc = newSVpvs_flags("", SVs_TEMP);
3653                     for (i = 0; i <= AvFILL(ar); i++) {
3654                         sv_catpvs(inc, " ");
3655                         sv_catsv(inc, *av_fetch(ar, i, TRUE));
3656                     }
3657
3658                     /* diag_listed_as: Can't locate %s */
3659                     DIE(aTHX_
3660                         "Can't locate %s in @INC%s%s (@INC contains:%" SVf ")",
3661                         name,
3662                         (memEQ(name + len - 2, ".h", 3)
3663                          ? " (change .h to .ph maybe?) (did you run h2ph?)" : ""),
3664                         (memEQ(name + len - 3, ".ph", 4)
3665                          ? " (did you run h2ph?)" : ""),
3666                         inc
3667                         );
3668                 }
3669             }
3670             DIE(aTHX_ "Can't locate %s", name);
3671         }
3672
3673         RETPUSHUNDEF;
3674     }
3675     else
3676         SETERRNO(0, SS_NORMAL);
3677
3678     /* Assume success here to prevent recursive requirement. */
3679     /* name is never assigned to again, so len is still strlen(name)  */
3680     /* Check whether a hook in @INC has already filled %INC */
3681     if (!hook_sv) {
3682         (void)hv_store(GvHVn(PL_incgv),
3683                        unixname, unixlen, newSVpv(CopFILE(&PL_compiling),0),0);
3684     } else {
3685         SV** const svp = hv_fetch(GvHVn(PL_incgv), unixname, unixlen, 0);
3686         if (!svp)
3687             (void)hv_store(GvHVn(PL_incgv),
3688                            unixname, unixlen, SvREFCNT_inc_simple(hook_sv), 0 );
3689     }
3690
3691     ENTER_with_name("eval");
3692     SAVETMPS;
3693     lex_start(NULL, tryrsfp, TRUE);
3694
3695     SAVEHINTS();
3696     PL_hints = 0;
3697     hv_clear(GvHV(PL_hintgv));
3698
3699     SAVECOMPILEWARNINGS();
3700     if (PL_dowarn & G_WARN_ALL_ON)
3701         PL_compiling.cop_warnings = pWARN_ALL ;
3702     else if (PL_dowarn & G_WARN_ALL_OFF)
3703         PL_compiling.cop_warnings = pWARN_NONE ;
3704     else
3705         PL_compiling.cop_warnings = pWARN_STD ;
3706
3707     if (filter_sub || filter_cache) {
3708         /* We can use the SvPV of the filter PVIO itself as our cache, rather
3709            than hanging another SV from it. In turn, filter_add() optionally
3710            takes the SV to use as the filter (or creates a new SV if passed
3711            NULL), so simply pass in whatever value filter_cache has.  */
3712         SV * const datasv = filter_add(S_run_user_filter, filter_cache);
3713         IoLINES(datasv) = filter_has_file;
3714         IoTOP_GV(datasv) = MUTABLE_GV(filter_state);
3715         IoBOTTOM_GV(datasv) = MUTABLE_GV(filter_sub);
3716     }
3717
3718     /* switch to eval mode */
3719     PUSHBLOCK(cx, CXt_EVAL, SP);
3720     PUSHEVAL(cx, name);
3721     cx->blk_eval.retop = PL_op->op_next;
3722
3723     SAVECOPLINE(&PL_compiling);
3724     CopLINE_set(&PL_compiling, 0);
3725
3726     PUTBACK;
3727
3728     /* Store and reset encoding. */
3729     encoding = PL_encoding;
3730     PL_encoding = NULL;
3731
3732     if (doeval(gimme, NULL, NULL, PL_curcop->cop_seq))
3733         op = DOCATCH(PL_eval_start);
3734     else
3735         op = PL_op->op_next;
3736
3737     /* Restore encoding. */
3738     PL_encoding = encoding;
3739
3740     return op;
3741 }
3742
3743 /* This is a op added to hold the hints hash for
3744    pp_entereval. The hash can be modified by the code
3745    being eval'ed, so we return a copy instead. */
3746
3747 PP(pp_hintseval)
3748 {
3749     dVAR;
3750     dSP;
3751     mXPUSHs(MUTABLE_SV(Perl_hv_copy_hints_hv(aTHX_ MUTABLE_HV(cSVOP_sv))));
3752     RETURN;
3753 }
3754
3755
3756 PP(pp_entereval)
3757 {
3758     dVAR; dSP;
3759     register PERL_CONTEXT *cx;
3760     SV *sv;
3761     const I32 gimme = GIMME_V;
3762     const U32 was = PL_breakable_sub_gen;
3763     char tbuf[TYPE_DIGITS(long) + 12];
3764     char *tmpbuf = tbuf;
3765     STRLEN len;
3766     CV* runcv;
3767     U32 seq;
3768     HV *saved_hh = NULL;
3769
3770     if (PL_op->op_private & OPpEVAL_HAS_HH) {
3771         saved_hh = MUTABLE_HV(SvREFCNT_inc(POPs));
3772     }
3773     sv = POPs;
3774     if (!SvPOK(sv)) {
3775         /* make sure we've got a plain PV (no overload etc) before testing
3776          * for taint. Making a copy here is probably overkill, but better
3777          * safe than sorry */
3778         STRLEN len;
3779         const char * const p = SvPV_const(sv, len);
3780
3781         sv = newSVpvn_flags(p, len, SVs_TEMP | SvUTF8(sv));
3782     }
3783
3784     TAINT_IF(SvTAINTED(sv));
3785     TAINT_PROPER("eval");
3786
3787     ENTER_with_name("eval");
3788     lex_start(sv, NULL, FALSE);
3789     SAVETMPS;
3790
3791     /* switch to eval mode */
3792
3793     if (PERLDB_NAMEEVAL && CopLINE(PL_curcop)) {
3794         SV * const temp_sv = sv_newmortal();
3795         Perl_sv_setpvf(aTHX_ temp_sv, "_<(eval %lu)[%s:%"IVdf"]",
3796                        (unsigned long)++PL_evalseq,
3797                        CopFILE(PL_curcop), (IV)CopLINE(PL_curcop));
3798         tmpbuf = SvPVX(temp_sv);
3799         len = SvCUR(temp_sv);
3800     }
3801     else
3802         len = my_snprintf(tmpbuf, sizeof(tbuf), "_<(eval %lu)", (unsigned long)++PL_evalseq);
3803     SAVECOPFILE_FREE(&PL_compiling);
3804     CopFILE_set(&PL_compiling, tmpbuf+2);
3805     SAVECOPLINE(&PL_compiling);
3806     CopLINE_set(&PL_compiling, 1);
3807     /* XXX For C<eval "...">s within BEGIN {} blocks, this ends up
3808        deleting the eval's FILEGV from the stash before gv_check() runs
3809        (i.e. before run-time proper). To work around the coredump that
3810        ensues, we always turn GvMULTI_on for any globals that were
3811        introduced within evals. See force_ident(). GSAR 96-10-12 */
3812     SAVEHINTS();
3813     PL_hints = PL_op->op_targ;
3814     if (saved_hh) {
3815         /* SAVEHINTS created a new HV in PL_hintgv, which we need to GC */
3816         SvREFCNT_dec(GvHV(PL_hintgv));
3817         GvHV(PL_hintgv) = saved_hh;
3818     }
3819     SAVECOMPILEWARNINGS();
3820     PL_compiling.cop_warnings = DUP_WARNINGS(PL_curcop->cop_warnings);
3821     if (PL_compiling.cop_hints_hash) {
3822         Perl_refcounted_he_free(aTHX_ PL_compiling.cop_hints_hash);
3823     }
3824     if (Perl_fetch_cop_label(aTHX_ PL_curcop->cop_hints_hash, NULL, NULL)) {
3825         /* The label, if present, is the first entry on the chain. So rather
3826            than writing a blank label in front of it (which involves an
3827            allocation), just use the next entry in the chain.  */
3828         PL_compiling.cop_hints_hash
3829             = PL_curcop->cop_hints_hash->refcounted_he_next;
3830         /* Check the assumption that this removed the label.  */
3831         assert(Perl_fetch_cop_label(aTHX_ PL_compiling.cop_hints_hash, NULL,
3832                                     NULL) == NULL);
3833     }
3834     else
3835         PL_compiling.cop_hints_hash = PL_curcop->cop_hints_hash;
3836     if (PL_compiling.cop_hints_hash) {
3837         HINTS_REFCNT_LOCK;
3838         PL_compiling.cop_hints_hash->refcounted_he_refcnt++;
3839         HINTS_REFCNT_UNLOCK;
3840     }
3841     /* special case: an eval '' executed within the DB package gets lexically
3842      * placed in the first non-DB CV rather than the current CV - this
3843      * allows the debugger to execute code, find lexicals etc, in the
3844      * scope of the code being debugged. Passing &seq gets find_runcv
3845      * to do the dirty work for us */
3846     runcv = find_runcv(&seq);
3847
3848     PUSHBLOCK(cx, (CXt_EVAL|CXp_REAL), SP);
3849     PUSHEVAL(cx, 0);
3850     cx->blk_eval.retop = PL_op->op_next;
3851
3852     /* prepare to compile string */
3853
3854     if ((PERLDB_LINE || PERLDB_SAVESRC) && PL_curstash != PL_debstash)
3855         save_lines(CopFILEAV(&PL_compiling), PL_parser->linestr);
3856     PUTBACK;
3857
3858     if (doeval(gimme, NULL, runcv, seq)) {
3859         if (was != PL_breakable_sub_gen /* Some subs defined here. */
3860             ? (PERLDB_LINE || PERLDB_SAVESRC)
3861             :  PERLDB_SAVESRC_NOSUBS) {
3862             /* Retain the filegv we created.  */
3863         } else {
3864             char *const safestr = savepvn(tmpbuf, len);
3865             SAVEDELETE(PL_defstash, safestr, len);
3866         }
3867         return DOCATCH(PL_eval_start);
3868     } else {
3869         /* We have already left the scope set up earler thanks to the LEAVE
3870            in doeval().  */
3871         if (was != PL_breakable_sub_gen /* Some subs defined here. */
3872             ? (PERLDB_LINE || PERLDB_SAVESRC)
3873             :  PERLDB_SAVESRC_INVALID) {
3874             /* Retain the filegv we created.  */
3875         } else {
3876             (void)hv_delete(PL_defstash, tmpbuf, len, G_DISCARD);
3877         }
3878         return PL_op->op_next;
3879     }
3880 }
3881
3882 PP(pp_leaveeval)
3883 {
3884     dVAR; dSP;
3885     register SV **mark;
3886     SV **newsp;
3887     PMOP *newpm;
3888     I32 gimme;
3889     register PERL_CONTEXT *cx;
3890     OP *retop;
3891     const U8 save_flags = PL_op -> op_flags;
3892     I32 optype;
3893     SV *namesv;
3894
3895     POPBLOCK(cx,newpm);
3896     POPEVAL(cx);
3897     namesv = cx->blk_eval.old_namesv;
3898     retop = cx->blk_eval.retop;
3899
3900     TAINT_NOT;
3901     if (gimme == G_VOID)
3902         MARK = newsp;
3903     else if (gimme == G_SCALAR) {
3904         MARK = newsp + 1;
3905         if (MARK <= SP) {
3906             if (SvFLAGS(TOPs) & SVs_TEMP)
3907                 *MARK = TOPs;
3908             else
3909                 *MARK = sv_mortalcopy(TOPs);
3910         }
3911         else {
3912             MEXTEND(mark,0);
3913             *MARK = &PL_sv_undef;
3914         }
3915         SP = MARK;
3916     }
3917     else {
3918         /* in case LEAVE wipes old return values */
3919         for (mark = newsp + 1; mark <= SP; mark++) {
3920             if (!(SvFLAGS(*mark) & SVs_TEMP)) {
3921                 *mark = sv_mortalcopy(*mark);
3922                 TAINT_NOT;      /* Each item is independent */
3923             }
3924         }
3925     }
3926     PL_curpm = newpm;   /* Don't pop $1 et al till now */
3927
3928 #ifdef DEBUGGING
3929     assert(CvDEPTH(PL_compcv) == 1);
3930 #endif
3931     CvDEPTH(PL_compcv) = 0;
3932     lex_end();
3933
3934     if (optype == OP_REQUIRE &&
3935         !(gimme == G_SCALAR ? SvTRUE(*SP) : SP > newsp))
3936     {
3937         /* Unassume the success we assumed earlier. */
3938         (void)hv_delete(GvHVn(PL_incgv),
3939                         SvPVX_const(namesv), SvCUR(namesv),
3940                         G_DISCARD);
3941         retop = Perl_die(aTHX_ "%"SVf" did not return a true value",
3942                                SVfARG(namesv));
3943         /* die_unwind() did LEAVE, or we won't be here */
3944     }
3945     else {
3946         LEAVE_with_name("eval");
3947         if (!(save_flags & OPf_SPECIAL)) {
3948             CLEAR_ERRSV();
3949         }
3950     }
3951
3952     RETURNOP(retop);
3953 }
3954
3955 /* Common code for Perl_call_sv and Perl_fold_constants, put here to keep it
3956    close to the related Perl_create_eval_scope.  */
3957 void
3958 Perl_delete_eval_scope(pTHX)
3959 {
3960     SV **newsp;
3961     PMOP *newpm;
3962     I32 gimme;
3963     register PERL_CONTEXT *cx;
3964     I32 optype;
3965
3966     POPBLOCK(cx,newpm);
3967     POPEVAL(cx);
3968     PL_curpm = newpm;
3969     LEAVE_with_name("eval_scope");
3970     PERL_UNUSED_VAR(newsp);
3971     PERL_UNUSED_VAR(gimme);
3972     PERL_UNUSED_VAR(optype);
3973 }
3974
3975 /* Common-ish code salvaged from Perl_call_sv and pp_entertry, because it was
3976    also needed by Perl_fold_constants.  */
3977 PERL_CONTEXT *
3978 Perl_create_eval_scope(pTHX_ U32 flags)
3979 {
3980     PERL_CONTEXT *cx;
3981     const I32 gimme = GIMME_V;
3982
3983     ENTER_with_name("eval_scope");
3984     SAVETMPS;
3985
3986     PUSHBLOCK(cx, (CXt_EVAL|CXp_TRYBLOCK), PL_stack_sp);
3987     PUSHEVAL(cx, 0);
3988
3989     PL_in_eval = EVAL_INEVAL;
3990     if (flags & G_KEEPERR)
3991         PL_in_eval |= EVAL_KEEPERR;
3992     else
3993         CLEAR_ERRSV();
3994     if (flags & G_FAKINGEVAL) {
3995         PL_eval_root = PL_op; /* Only needed so that goto works right. */
3996     }
3997     return cx;
3998 }
3999
4000 PP(pp_entertry)
4001 {
4002     dVAR;
4003     PERL_CONTEXT * const cx = create_eval_scope(0);
4004     cx->blk_eval.retop = cLOGOP->op_other->op_next;
4005     return DOCATCH(PL_op->op_next);
4006 }
4007
4008 PP(pp_leavetry)
4009 {
4010     dVAR; dSP;
4011     SV **newsp;
4012     PMOP *newpm;
4013     I32 gimme;
4014     register PERL_CONTEXT *cx;
4015     I32 optype;
4016
4017     POPBLOCK(cx,newpm);
4018     POPEVAL(cx);
4019     PERL_UNUSED_VAR(optype);
4020
4021     TAINT_NOT;
4022     if (gimme == G_VOID)
4023         SP = newsp;
4024     else if (gimme == G_SCALAR) {
4025         register SV **mark;
4026         MARK = newsp + 1;
4027         if (MARK <= SP) {
4028             if (SvFLAGS(TOPs) & (SVs_PADTMP|SVs_TEMP))
4029                 *MARK = TOPs;
4030             else
4031                 *MARK = sv_mortalcopy(TOPs);
4032         }
4033         else {
4034             MEXTEND(mark,0);
4035             *MARK = &PL_sv_undef;
4036         }
4037         SP = MARK;
4038     }
4039     else {
4040         /* in case LEAVE wipes old return values */
4041         register SV **mark;
4042         for (mark = newsp + 1; mark <= SP; mark++) {
4043             if (!(SvFLAGS(*mark) & (SVs_PADTMP|SVs_TEMP))) {
4044                 *mark = sv_mortalcopy(*mark);
4045                 TAINT_NOT;      /* Each item is independent */
4046             }
4047         }
4048     }
4049     PL_curpm = newpm;   /* Don't pop $1 et al till now */
4050
4051     LEAVE_with_name("eval_scope");
4052     CLEAR_ERRSV();
4053     RETURN;
4054 }
4055
4056 PP(pp_entergiven)
4057 {
4058     dVAR; dSP;
4059     register PERL_CONTEXT *cx;
4060     const I32 gimme = GIMME_V;
4061
4062     ENTER_with_name("given");
4063     SAVETMPS;
4064
4065     sv_setsv(PAD_SV(PL_op->op_targ), POPs);
4066
4067     PUSHBLOCK(cx, CXt_GIVEN, SP);
4068     PUSHGIVEN(cx);
4069
4070     RETURN;
4071 }
4072
4073 PP(pp_leavegiven)
4074 {
4075     dVAR; dSP;
4076     register PERL_CONTEXT *cx;
4077     I32 gimme;
4078     SV **newsp;
4079     PMOP *newpm;
4080     PERL_UNUSED_CONTEXT;
4081
4082     POPBLOCK(cx,newpm);
4083     assert(CxTYPE(cx) == CXt_GIVEN);
4084
4085     TAINT_NOT;
4086     if (gimme == G_VOID)
4087         SP = newsp;
4088     else if (gimme == G_SCALAR) {
4089         register SV **mark;
4090         MARK = newsp + 1;
4091         if (MARK <= SP) {
4092             if (SvFLAGS(TOPs) & (SVs_PADTMP|SVs_TEMP))
4093                 *MARK = TOPs;
4094             else
4095                 *MARK = sv_mortalcopy(TOPs);
4096         }
4097         else {
4098             MEXTEND(mark,0);
4099             *MARK = &PL_sv_undef;
4100         }
4101         SP = MARK;
4102     }
4103     else {
4104         /* in case LEAVE wipes old return values */
4105         register SV **mark;
4106         for (mark = newsp + 1; mark <= SP; mark++) {
4107             if (!(SvFLAGS(*mark) & (SVs_PADTMP|SVs_TEMP))) {
4108                 *mark = sv_mortalcopy(*mark);
4109                 TAINT_NOT;      /* Each item is independent */
4110             }
4111         }
4112     }
4113     PL_curpm = newpm;   /* Don't pop $1 et al till now */
4114
4115     LEAVE_with_name("given");
4116     RETURN;
4117 }
4118
4119 /* Helper routines used by pp_smartmatch */
4120 STATIC PMOP *
4121 S_make_matcher(pTHX_ REGEXP *re)
4122 {
4123     dVAR;
4124     PMOP *matcher = (PMOP *) newPMOP(OP_MATCH, OPf_WANT_SCALAR | OPf_STACKED);
4125
4126     PERL_ARGS_ASSERT_MAKE_MATCHER;
4127
4128     PM_SETRE(matcher, ReREFCNT_inc(re));
4129
4130     SAVEFREEOP((OP *) matcher);
4131     ENTER_with_name("matcher"); SAVETMPS;
4132     SAVEOP();
4133     return matcher;
4134 }
4135
4136 STATIC bool
4137 S_matcher_matches_sv(pTHX_ PMOP *matcher, SV *sv)
4138 {
4139     dVAR;
4140     dSP;
4141
4142     PERL_ARGS_ASSERT_MATCHER_MATCHES_SV;
4143
4144     PL_op = (OP *) matcher;
4145     XPUSHs(sv);
4146     PUTBACK;
4147     (void) pp_match();
4148     SPAGAIN;
4149     return (SvTRUEx(POPs));
4150 }
4151
4152 STATIC void
4153 S_destroy_matcher(pTHX_ PMOP *matcher)
4154 {
4155     dVAR;
4156
4157     PERL_ARGS_ASSERT_DESTROY_MATCHER;
4158     PERL_UNUSED_ARG(matcher);
4159
4160     FREETMPS;
4161     LEAVE_with_name("matcher");
4162 }
4163
4164 /* Do a smart match */
4165 PP(pp_smartmatch)
4166 {
4167     DEBUG_M(Perl_deb(aTHX_ "Starting smart match resolution\n"));
4168     return do_smartmatch(NULL, NULL);
4169 }
4170
4171 /* This version of do_smartmatch() implements the
4172  * table of smart matches that is found in perlsyn.
4173  */
4174 STATIC OP *
4175 S_do_smartmatch(pTHX_ HV *seen_this, HV *seen_other)
4176 {
4177     dVAR;
4178     dSP;
4179
4180     bool object_on_left = FALSE;
4181     SV *e = TOPs;       /* e is for 'expression' */
4182     SV *d = TOPm1s;     /* d is for 'default', as in PL_defgv */
4183
4184     /* Take care only to invoke mg_get() once for each argument.
4185      * Currently we do this by copying the SV if it's magical. */
4186     if (d) {
4187         if (SvGMAGICAL(d))
4188             d = sv_mortalcopy(d);
4189     }
4190     else
4191         d = &PL_sv_undef;
4192
4193     assert(e);
4194     if (SvGMAGICAL(e))
4195         e = sv_mortalcopy(e);
4196
4197     /* First of all, handle overload magic of the rightmost argument */
4198     if (SvAMAGIC(e)) {
4199         SV * tmpsv;
4200         DEBUG_M(Perl_deb(aTHX_ "    applying rule Any-Object\n"));
4201         DEBUG_M(Perl_deb(aTHX_ "        attempting overload\n"));
4202
4203         tmpsv = amagic_call(d, e, smart_amg, 0);
4204         if (tmpsv) {
4205             SPAGAIN;
4206             (void)POPs;
4207             SETs(tmpsv);
4208             RETURN;
4209         }
4210         DEBUG_M(Perl_deb(aTHX_ "        failed to run overload method; continuing...\n"));
4211     }
4212
4213     SP -= 2;    /* Pop the values */
4214
4215
4216     /* ~~ undef */
4217     if (!SvOK(e)) {
4218         DEBUG_M(Perl_deb(aTHX_ "    applying rule Any-undef\n"));
4219         if (SvOK(d))
4220             RETPUSHNO;
4221         else
4222             RETPUSHYES;
4223     }
4224
4225     if (sv_isobject(e) && (SvTYPE(SvRV(e)) != SVt_REGEXP)) {
4226         DEBUG_M(Perl_deb(aTHX_ "    applying rule Any-Object\n"));
4227         Perl_croak(aTHX_ "Smart matching a non-overloaded object breaks encapsulation");
4228     }
4229     if (sv_isobject(d) && (SvTYPE(SvRV(d)) != SVt_REGEXP))
4230         object_on_left = TRUE;
4231
4232     /* ~~ sub */
4233     if (SvROK(e) && SvTYPE(SvRV(e)) == SVt_PVCV) {
4234         I32 c;
4235         if (object_on_left) {
4236             goto sm_any_sub; /* Treat objects like scalars */
4237         }
4238         else if (SvROK(d) && SvTYPE(SvRV(d)) == SVt_PVHV) {
4239             /* Test sub truth for each key */
4240             HE *he;
4241             bool andedresults = TRUE;
4242             HV *hv = (HV*) SvRV(d);
4243             I32 numkeys = hv_iterinit(hv);
4244             DEBUG_M(Perl_deb(aTHX_ "    applying rule Hash-CodeRef\n"));
4245             if (numkeys == 0)
4246                 RETPUSHYES;
4247             while ( (he = hv_iternext(hv)) ) {
4248                 DEBUG_M(Perl_deb(aTHX_ "        testing hash key...\n"));
4249                 ENTER_with_name("smartmatch_hash_key_test");
4250                 SAVETMPS;
4251                 PUSHMARK(SP);
4252                 PUSHs(hv_iterkeysv(he));
4253                 PUTBACK;
4254                 c = call_sv(e, G_SCALAR);
4255                 SPAGAIN;
4256                 if (c == 0)
4257                     andedresults = FALSE;
4258                 else
4259                     andedresults = SvTRUEx(POPs) && andedresults;
4260                 FREETMPS;
4261                 LEAVE_with_name("smartmatch_hash_key_test");
4262             }
4263             if (andedresults)
4264                 RETPUSHYES;
4265             else
4266                 RETPUSHNO;
4267         }
4268         else if (SvROK(d) && SvTYPE(SvRV(d)) == SVt_PVAV) {
4269             /* Test sub truth for each element */
4270             I32 i;
4271             bool andedresults = TRUE;
4272             AV *av = (AV*) SvRV(d);
4273             const I32 len = av_len(av);
4274             DEBUG_M(Perl_deb(aTHX_ "    applying rule Array-CodeRef\n"));
4275             if (len == -1)
4276                 RETPUSHYES;
4277             for (i = 0; i <= len; ++i) {
4278                 SV * const * const svp = av_fetch(av, i, FALSE);
4279                 DEBUG_M(Perl_deb(aTHX_ "        testing array element...\n"));
4280                 ENTER_with_name("smartmatch_array_elem_test");
4281                 SAVETMPS;
4282                 PUSHMARK(SP);
4283                 if (svp)
4284                     PUSHs(*svp);
4285                 PUTBACK;
4286                 c = call_sv(e, G_SCALAR);
4287                 SPAGAIN;
4288                 if (c == 0)
4289                     andedresults = FALSE;
4290                 else
4291                     andedresults = SvTRUEx(POPs) && andedresults;
4292                 FREETMPS;
4293                 LEAVE_with_name("smartmatch_array_elem_test");
4294             }
4295             if (andedresults)
4296                 RETPUSHYES;
4297             else
4298                 RETPUSHNO;
4299         }
4300         else {
4301           sm_any_sub:
4302             DEBUG_M(Perl_deb(aTHX_ "    applying rule Any-CodeRef\n"));
4303             ENTER_with_name("smartmatch_coderef");
4304             SAVETMPS;
4305             PUSHMARK(SP);
4306             PUSHs(d);
4307             PUTBACK;
4308             c = call_sv(e, G_SCALAR);
4309             SPAGAIN;
4310             if (c == 0)
4311                 PUSHs(&PL_sv_no);
4312             else if (SvTEMP(TOPs))
4313                 SvREFCNT_inc_void(TOPs);
4314             FREETMPS;
4315             LEAVE_with_name("smartmatch_coderef");
4316             RETURN;
4317         }
4318     }
4319     /* ~~ %hash */
4320     else if (SvROK(e) && SvTYPE(SvRV(e)) == SVt_PVHV) {
4321         if (object_on_left) {
4322             goto sm_any_hash; /* Treat objects like scalars */
4323         }
4324         else if (!SvOK(d)) {
4325             DEBUG_M(Perl_deb(aTHX_ "    applying rule Any-Hash ($a undef)\n"));
4326             RETPUSHNO;
4327         }
4328         else if (SvROK(d) && SvTYPE(SvRV(d)) == SVt_PVHV) {
4329             /* Check that the key-sets are identical */
4330             HE *he;
4331             HV *other_hv = MUTABLE_HV(SvRV(d));
4332             bool tied = FALSE;
4333             bool other_tied = FALSE;
4334             U32 this_key_count  = 0,
4335                 other_key_count = 0;
4336             HV *hv = MUTABLE_HV(SvRV(e));
4337
4338             DEBUG_M(Perl_deb(aTHX_ "    applying rule Hash-Hash\n"));
4339             /* Tied hashes don't know how many keys they have. */
4340             if (SvTIED_mg((SV*)hv, PERL_MAGIC_tied)) {
4341                 tied = TRUE;
4342             }
4343             else if (SvTIED_mg((const SV *)other_hv, PERL_MAGIC_tied)) {
4344                 HV * const temp = other_hv;
4345                 other_hv = hv;
4346                 hv = temp;
4347                 tied = TRUE;
4348             }
4349             if (SvTIED_mg((const SV *)other_hv, PERL_MAGIC_tied))
4350                 other_tied = TRUE;
4351
4352             if (!tied && HvUSEDKEYS((const HV *) hv) != HvUSEDKEYS(other_hv))
4353                 RETPUSHNO;
4354
4355             /* The hashes have the same number of keys, so it suffices
4356                to check that one is a subset of the other. */
4357             (void) hv_iterinit(hv);
4358             while ( (he = hv_iternext(hv)) ) {
4359                 SV *key = hv_iterkeysv(he);
4360
4361                 DEBUG_M(Perl_deb(aTHX_ "        comparing hash key...\n"));
4362                 ++ this_key_count;
4363
4364                 if(!hv_exists_ent(other_hv, key, 0)) {
4365                     (void) hv_iterinit(hv);     /* reset iterator */
4366                     RETPUSHNO;
4367                 }
4368             }
4369
4370             if (other_tied) {
4371                 (void) hv_iterinit(other_hv);
4372                 while ( hv_iternext(other_hv) )
4373                     ++other_key_count;
4374             }
4375             else
4376                 other_key_count = HvUSEDKEYS(other_hv);
4377
4378             if (this_key_count != other_key_count)
4379                 RETPUSHNO;
4380             else
4381                 RETPUSHYES;
4382         }
4383         else if (SvROK(d) && SvTYPE(SvRV(d)) == SVt_PVAV) {
4384             AV * const other_av = MUTABLE_AV(SvRV(d));
4385             const I32 other_len = av_len(other_av) + 1;
4386             I32 i;
4387             HV *hv = MUTABLE_HV(SvRV(e));
4388
4389             DEBUG_M(Perl_deb(aTHX_ "    applying rule Array-Hash\n"));
4390             for (i = 0; i < other_len; ++i) {
4391                 SV ** const svp = av_fetch(other_av, i, FALSE);
4392                 DEBUG_M(Perl_deb(aTHX_ "        checking for key existence...\n"));
4393                 if (svp) {      /* ??? When can this not happen? */
4394                     if (hv_exists_ent(hv, *svp, 0))
4395                         RETPUSHYES;
4396                 }
4397             }
4398             RETPUSHNO;
4399         }
4400         else if (SvROK(d) && SvTYPE(SvRV(d)) == SVt_REGEXP) {
4401             DEBUG_M(Perl_deb(aTHX_ "    applying rule Regex-Hash\n"));
4402           sm_regex_hash:
4403             {
4404                 PMOP * const matcher = make_matcher((REGEXP*) SvRV(d));
4405                 HE *he;
4406                 HV *hv = MUTABLE_HV(SvRV(e));
4407
4408                 (void) hv_iterinit(hv);
4409                 while ( (he = hv_iternext(hv)) ) {
4410                     DEBUG_M(Perl_deb(aTHX_ "        testing key against pattern...\n"));
4411                     if (matcher_matches_sv(matcher, hv_iterkeysv(he))) {
4412                         (void) hv_iterinit(hv);
4413                         destroy_matcher(matcher);
4414                         RETPUSHYES;
4415                     }
4416                 }
4417                 destroy_matcher(matcher);
4418                 RETPUSHNO;
4419             }
4420         }
4421         else {
4422           sm_any_hash:
4423             DEBUG_M(Perl_deb(aTHX_ "    applying rule Any-Hash\n"));
4424             if (hv_exists_ent(MUTABLE_HV(SvRV(e)), d, 0))
4425                 RETPUSHYES;
4426             else
4427                 RETPUSHNO;
4428         }
4429     }
4430     /* ~~ @array */
4431     else if (SvROK(e) && SvTYPE(SvRV(e)) == SVt_PVAV) {
4432         if (object_on_left) {
4433             goto sm_any_array; /* Treat objects like scalars */
4434         }
4435         else if (SvROK(d) && SvTYPE(SvRV(d)) == SVt_PVHV) {
4436             AV * const other_av = MUTABLE_AV(SvRV(e));
4437             const I32 other_len = av_len(other_av) + 1;
4438             I32 i;
4439
4440             DEBUG_M(Perl_deb(aTHX_ "    applying rule Hash-Array\n"));
4441             for (i = 0; i < other_len; ++i) {
4442                 SV ** const svp = av_fetch(other_av, i, FALSE);
4443
4444                 DEBUG_M(Perl_deb(aTHX_ "        testing for key existence...\n"));
4445                 if (svp) {      /* ??? When can this not happen? */
4446                     if (hv_exists_ent(MUTABLE_HV(SvRV(d)), *svp, 0))
4447                         RETPUSHYES;
4448                 }
4449             }
4450             RETPUSHNO;
4451         }
4452         if (SvROK(d) && SvTYPE(SvRV(d)) == SVt_PVAV) {
4453             AV *other_av = MUTABLE_AV(SvRV(d));
4454             DEBUG_M(Perl_deb(aTHX_ "    applying rule Array-Array\n"));
4455             if (av_len(MUTABLE_AV(SvRV(e))) != av_len(other_av))
4456                 RETPUSHNO;
4457             else {
4458                 I32 i;
4459                 const I32 other_len = av_len(other_av);
4460
4461                 if (NULL == seen_this) {
4462                     seen_this = newHV();
4463                     (void) sv_2mortal(MUTABLE_SV(seen_this));
4464                 }
4465                 if (NULL == seen_other) {
4466                     seen_other = newHV();
4467                     (void) sv_2mortal(MUTABLE_SV(seen_other));
4468                 }
4469                 for(i = 0; i <= other_len; ++i) {
4470                     SV * const * const this_elem = av_fetch(MUTABLE_AV(SvRV(e)), i, FALSE);
4471                     SV * const * const other_elem = av_fetch(other_av, i, FALSE);
4472
4473                     if (!this_elem || !other_elem) {
4474                         if ((this_elem && SvOK(*this_elem))
4475                                 || (other_elem && SvOK(*other_elem)))
4476                             RETPUSHNO;
4477                     }
4478                     else if (hv_exists_ent(seen_this,
4479                                 sv_2mortal(newSViv(PTR2IV(*this_elem))), 0) ||
4480                             hv_exists_ent(seen_other,
4481                                 sv_2mortal(newSViv(PTR2IV(*other_elem))), 0))
4482                     {
4483                         if (*this_elem != *other_elem)
4484                             RETPUSHNO;
4485                     }
4486                     else {
4487                         (void)hv_store_ent(seen_this,
4488                                 sv_2mortal(newSViv(PTR2IV(*this_elem))),
4489                                 &PL_sv_undef, 0);
4490                         (void)hv_store_ent(seen_other,
4491                                 sv_2mortal(newSViv(PTR2IV(*other_elem))),
4492                                 &PL_sv_undef, 0);
4493                         PUSHs(*other_elem);
4494                         PUSHs(*this_elem);
4495
4496                         PUTBACK;
4497                         DEBUG_M(Perl_deb(aTHX_ "        recursively comparing array element...\n"));
4498                         (void) do_smartmatch(seen_this, seen_other);
4499                         SPAGAIN;
4500                         DEBUG_M(Perl_deb(aTHX_ "        recursion finished\n"));
4501
4502                         if (!SvTRUEx(POPs))
4503                             RETPUSHNO;
4504                     }
4505                 }
4506                 RETPUSHYES;
4507             }
4508         }
4509         else if (SvROK(d) && SvTYPE(SvRV(d)) == SVt_REGEXP) {
4510             DEBUG_M(Perl_deb(aTHX_ "    applying rule Regex-Array\n"));
4511           sm_regex_array:
4512             {
4513                 PMOP * const matcher = make_matcher((REGEXP*) SvRV(d));
4514                 const I32 this_len = av_len(MUTABLE_AV(SvRV(e)));
4515                 I32 i;
4516
4517                 for(i = 0; i <= this_len; ++i) {
4518                     SV * const * const svp = av_fetch(MUTABLE_AV(SvRV(e)), i, FALSE);
4519                     DEBUG_M(Perl_deb(aTHX_ "        testing element against pattern...\n"));
4520                     if (svp && matcher_matches_sv(matcher, *svp)) {
4521                         destroy_matcher(matcher);
4522                         RETPUSHYES;
4523                     }
4524                 }
4525                 destroy_matcher(matcher);
4526                 RETPUSHNO;
4527             }
4528         }
4529         else if (!SvOK(d)) {
4530             /* undef ~~ array */
4531             const I32 this_len = av_len(MUTABLE_AV(SvRV(e)));
4532             I32 i;
4533
4534             DEBUG_M(Perl_deb(aTHX_ "    applying rule Undef-Array\n"));
4535             for (i = 0; i <= this_len; ++i) {
4536                 SV * const * const svp = av_fetch(MUTABLE_AV(SvRV(e)), i, FALSE);
4537                 DEBUG_M(Perl_deb(aTHX_ "        testing for undef element...\n"));
4538                 if (!svp || !SvOK(*svp))
4539                     RETPUSHYES;
4540             }
4541             RETPUSHNO;
4542         }
4543         else {
4544           sm_any_array:
4545             {
4546                 I32 i;
4547                 const I32 this_len = av_len(MUTABLE_AV(SvRV(e)));
4548
4549                 DEBUG_M(Perl_deb(aTHX_ "    applying rule Any-Array\n"));
4550                 for (i = 0; i <= this_len; ++i) {
4551                     SV * const * const svp = av_fetch(MUTABLE_AV(SvRV(e)), i, FALSE);
4552                     if (!svp)
4553                         continue;
4554
4555                     PUSHs(d);
4556                     PUSHs(*svp);
4557                     PUTBACK;
4558                     /* infinite recursion isn't supposed to happen here */
4559                     DEBUG_M(Perl_deb(aTHX_ "        recursively testing array element...\n"));
4560                     (void) do_smartmatch(NULL, NULL);
4561                     SPAGAIN;
4562                     DEBUG_M(Perl_deb(aTHX_ "        recursion finished\n"));
4563                     if (SvTRUEx(POPs))
4564                         RETPUSHYES;
4565                 }
4566                 RETPUSHNO;
4567             }
4568         }
4569     }
4570     /* ~~ qr// */
4571     else if (SvROK(e) && SvTYPE(SvRV(e)) == SVt_REGEXP) {
4572         if (!object_on_left && SvROK(d) && SvTYPE(SvRV(d)) == SVt_PVHV) {
4573             SV *t = d; d = e; e = t;
4574             DEBUG_M(Perl_deb(aTHX_ "    applying rule Hash-Regex\n"));
4575             goto sm_regex_hash;
4576         }
4577         else if (!object_on_left && SvROK(d) && SvTYPE(SvRV(d)) == SVt_PVAV) {
4578             SV *t = d; d = e; e = t;
4579             DEBUG_M(Perl_deb(aTHX_ "    applying rule Array-Regex\n"));
4580             goto sm_regex_array;
4581         }
4582         else {
4583             PMOP * const matcher = make_matcher((REGEXP*) SvRV(e));
4584
4585             DEBUG_M(Perl_deb(aTHX_ "    applying rule Any-Regex\n"));
4586             PUTBACK;
4587             PUSHs(matcher_matches_sv(matcher, d)
4588                     ? &PL_sv_yes
4589                     : &PL_sv_no);
4590             destroy_matcher(matcher);
4591             RETURN;
4592         }
4593     }
4594     /* ~~ scalar */
4595     /* See if there is overload magic on left */
4596     else if (object_on_left && SvAMAGIC(d)) {
4597         SV *tmpsv;
4598         DEBUG_M(Perl_deb(aTHX_ "    applying rule Object-Any\n"));
4599         DEBUG_M(Perl_deb(aTHX_ "        attempting overload\n"));
4600         PUSHs(d); PUSHs(e);
4601         PUTBACK;
4602         tmpsv = amagic_call(d, e, smart_amg, AMGf_noright);
4603         if (tmpsv) {
4604             SPAGAIN;
4605             (void)POPs;
4606             SETs(tmpsv);
4607             RETURN;
4608         }
4609         SP -= 2;
4610         DEBUG_M(Perl_deb(aTHX_ "        failed to run overload method; falling back...\n"));
4611         goto sm_any_scalar;
4612     }
4613     else if (!SvOK(d)) {
4614         /* undef ~~ scalar ; we already know that the scalar is SvOK */
4615         DEBUG_M(Perl_deb(aTHX_ "    applying rule undef-Any\n"));
4616         RETPUSHNO;
4617     }
4618     else
4619   sm_any_scalar:
4620     if (SvNIOK(e) || (SvPOK(e) && looks_like_number(e) && SvNIOK(d))) {
4621         DEBUG_M(if (SvNIOK(e))
4622                     Perl_deb(aTHX_ "    applying rule Any-Num\n");
4623                 else
4624                     Perl_deb(aTHX_ "    applying rule Num-numish\n");
4625         );
4626         /* numeric comparison */
4627         PUSHs(d); PUSHs(e);
4628         PUTBACK;
4629         if (CopHINTS_get(PL_curcop) & HINT_INTEGER)
4630             (void) pp_i_eq();
4631         else
4632             (void) pp_eq();
4633         SPAGAIN;
4634         if (SvTRUEx(POPs))
4635             RETPUSHYES;
4636         else
4637             RETPUSHNO;
4638     }
4639
4640     /* As a last resort, use string comparison */
4641     DEBUG_M(Perl_deb(aTHX_ "    applying rule Any-Any\n"));
4642     PUSHs(d); PUSHs(e);
4643     PUTBACK;
4644     return pp_seq();
4645 }
4646
4647 PP(pp_enterwhen)
4648 {
4649     dVAR; dSP;
4650     register PERL_CONTEXT *cx;
4651     const I32 gimme = GIMME_V;
4652
4653     /* This is essentially an optimization: if the match
4654        fails, we don't want to push a context and then
4655        pop it again right away, so we skip straight
4656        to the op that follows the leavewhen.
4657        RETURNOP calls PUTBACK which restores the stack pointer after the POPs.
4658     */
4659     if ((0 == (PL_op->op_flags & OPf_SPECIAL)) && !SvTRUEx(POPs))
4660         RETURNOP(cLOGOP->op_other->op_next);
4661
4662     ENTER_with_name("eval");
4663     SAVETMPS;
4664
4665     PUSHBLOCK(cx, CXt_WHEN, SP);
4666     PUSHWHEN(cx);
4667
4668     RETURN;
4669 }
4670
4671 PP(pp_leavewhen)
4672 {
4673     dVAR; dSP;
4674     register PERL_CONTEXT *cx;
4675     I32 gimme;
4676     SV **newsp;
4677     PMOP *newpm;
4678
4679     POPBLOCK(cx,newpm);
4680     assert(CxTYPE(cx) == CXt_WHEN);
4681
4682     SP = newsp;
4683     PUTBACK;
4684
4685     PL_curpm = newpm;   /* pop $1 et al */
4686
4687     LEAVE_with_name("eval");
4688     return NORMAL;
4689 }
4690
4691 PP(pp_continue)
4692 {
4693     dVAR;
4694     I32 cxix;
4695     register PERL_CONTEXT *cx;
4696     I32 inner;
4697
4698     cxix = dopoptowhen(cxstack_ix);
4699     if (cxix < 0)
4700         DIE(aTHX_ "Can't \"continue\" outside a when block");
4701     if (cxix < cxstack_ix)
4702         dounwind(cxix);
4703
4704     /* clear off anything above the scope we're re-entering */
4705     inner = PL_scopestack_ix;
4706     TOPBLOCK(cx);
4707     if (PL_scopestack_ix < inner)
4708         leave_scope(PL_scopestack[PL_scopestack_ix]);
4709     PL_curcop = cx->blk_oldcop;
4710     return cx->blk_givwhen.leave_op;
4711 }
4712
4713 PP(pp_break)
4714 {
4715     dVAR;
4716     I32 cxix;
4717     register PERL_CONTEXT *cx;
4718     I32 inner;
4719     dSP;
4720
4721     cxix = dopoptogiven(cxstack_ix);
4722     if (cxix < 0) {
4723         if (PL_op->op_flags & OPf_SPECIAL)
4724             DIE(aTHX_ "Can't use when() outside a topicalizer");
4725         else
4726             DIE(aTHX_ "Can't \"break\" outside a given block");
4727     }
4728     if (CxFOREACH(&cxstack[cxix]) && (0 == (PL_op->op_flags & OPf_SPECIAL)))
4729         DIE(aTHX_ "Can't \"break\" in a loop topicalizer");
4730
4731     if (cxix < cxstack_ix)
4732         dounwind(cxix);
4733
4734     /* clear off anything above the scope we're re-entering */
4735     inner = PL_scopestack_ix;
4736     TOPBLOCK(cx);
4737     if (PL_scopestack_ix < inner)
4738         leave_scope(PL_scopestack[PL_scopestack_ix]);
4739     PL_curcop = cx->blk_oldcop;
4740
4741     if (CxFOREACH(cx))
4742         return CX_LOOP_NEXTOP_GET(cx);
4743     else
4744         /* RETURNOP calls PUTBACK which restores the old old sp */
4745         RETURNOP(cx->blk_givwhen.leave_op);
4746 }
4747
4748 STATIC OP *
4749 S_doparseform(pTHX_ SV *sv)
4750 {
4751     STRLEN len;
4752     register char *s = SvPV_force(sv, len);
4753     register char * const send = s + len;
4754     register char *base = NULL;
4755     register I32 skipspaces = 0;
4756     bool noblank   = FALSE;
4757     bool repeat    = FALSE;
4758     bool postspace = FALSE;
4759     U32 *fops;
4760     register U32 *fpc;
4761     U32 *linepc = NULL;
4762     register I32 arg;
4763     bool ischop;
4764     bool unchopnum = FALSE;
4765     int maxops = 12; /* FF_LINEMARK + FF_END + 10 (\0 without preceding \n) */
4766
4767     PERL_ARGS_ASSERT_DOPARSEFORM;
4768
4769     if (len == 0)
4770         Perl_croak(aTHX_ "Null picture in formline");
4771
4772     /* estimate the buffer size needed */
4773     for (base = s; s <= send; s++) {
4774         if (*s == '\n' || *s == '@' || *s == '^')
4775             maxops += 10;
4776     }
4777     s = base;
4778     base = NULL;
4779
4780     Newx(fops, maxops, U32);
4781     fpc = fops;
4782
4783     if (s < send) {
4784         linepc = fpc;
4785         *fpc++ = FF_LINEMARK;
4786         noblank = repeat = FALSE;
4787         base = s;
4788     }
4789
4790     while (s <= send) {
4791         switch (*s++) {
4792         default:
4793             skipspaces = 0;
4794             continue;
4795
4796         case '~':
4797             if (*s == '~') {
4798                 repeat = TRUE;
4799                 *s = ' ';
4800             }
4801             noblank = TRUE;
4802             s[-1] = ' ';
4803             /* FALL THROUGH */
4804         case ' ': case '\t':
4805             skipspaces++;
4806             continue;
4807         case 0:
4808             if (s < send) {
4809                 skipspaces = 0;
4810                 continue;
4811             } /* else FALL THROUGH */
4812         case '\n':
4813             arg = s - base;
4814             skipspaces++;
4815             arg -= skipspaces;
4816             if (arg) {
4817                 if (postspace)
4818                     *fpc++ = FF_SPACE;
4819                 *fpc++ = FF_LITERAL;
4820                 *fpc++ = (U16)arg;
4821             }
4822             postspace = FALSE;
4823             if (s <= send)
4824                 skipspaces--;
4825             if (skipspaces) {
4826                 *fpc++ = FF_SKIP;
4827                 *fpc++ = (U16)skipspaces;
4828             }
4829             skipspaces = 0;
4830             if (s <= send)
4831                 *fpc++ = FF_NEWLINE;
4832             if (noblank) {
4833                 *fpc++ = FF_BLANK;
4834                 if (repeat)
4835                     arg = fpc - linepc + 1;
4836                 else
4837                     arg = 0;
4838                 *fpc++ = (U16)arg;
4839             }
4840             if (s < send) {
4841                 linepc = fpc;
4842                 *fpc++ = FF_LINEMARK;
4843                 noblank = repeat = FALSE;
4844                 base = s;
4845             }
4846             else
4847                 s++;
4848             continue;
4849
4850         case '@':
4851         case '^':
4852             ischop = s[-1] == '^';
4853
4854             if (postspace) {
4855                 *fpc++ = FF_SPACE;
4856                 postspace = FALSE;
4857             }
4858             arg = (s - base) - 1;
4859             if (arg) {
4860                 *fpc++ = FF_LITERAL;
4861                 *fpc++ = (U16)arg;
4862             }
4863
4864             base = s - 1;
4865             *fpc++ = FF_FETCH;
4866             if (*s == '*') {
4867                 s++;
4868                 *fpc++ = 2;  /* skip the @* or ^* */
4869                 if (ischop) {
4870                     *fpc++ = FF_LINESNGL;
4871                     *fpc++ = FF_CHOP;
4872                 } else
4873                     *fpc++ = FF_LINEGLOB;
4874             }
4875             else if (*s == '#' || (*s == '.' && s[1] == '#')) {
4876                 arg = ischop ? 512 : 0;
4877                 base = s - 1;
4878                 while (*s == '#')
4879                     s++;
4880                 if (*s == '.') {
4881                     const char * const f = ++s;
4882                     while (*s == '#')
4883                         s++;
4884                     arg |= 256 + (s - f);
4885                 }
4886                 *fpc++ = s - base;              /* fieldsize for FETCH */
4887                 *fpc++ = FF_DECIMAL;
4888                 *fpc++ = (U16)arg;
4889                 unchopnum |= ! ischop;
4890             }
4891             else if (*s == '0' && s[1] == '#') {  /* Zero padded decimals */
4892                 arg = ischop ? 512 : 0;
4893                 base = s - 1;
4894                 s++;                                /* skip the '0' first */
4895                 while (*s == '#')
4896                     s++;
4897                 if (*s == '.') {
4898                     const char * const f = ++s;
4899                     while (*s == '#')
4900                         s++;
4901                     arg |= 256 + (s - f);
4902                 }
4903                 *fpc++ = s - base;                /* fieldsize for FETCH */
4904                 *fpc++ = FF_0DECIMAL;
4905                 *fpc++ = (U16)arg;
4906                 unchopnum |= ! ischop;
4907             }
4908             else {
4909                 I32 prespace = 0;
4910                 bool ismore = FALSE;
4911
4912                 if (*s == '>') {
4913                     while (*++s == '>') ;
4914                     prespace = FF_SPACE;
4915                 }
4916                 else if (*s == '|') {
4917                     while (*++s == '|') ;
4918                     prespace = FF_HALFSPACE;
4919                     postspace = TRUE;
4920                 }
4921                 else {
4922                     if (*s == '<')
4923                         while (*++s == '<') ;
4924                     postspace = TRUE;
4925                 }
4926                 if (*s == '.' && s[1] == '.' && s[2] == '.') {
4927                     s += 3;
4928                     ismore = TRUE;
4929                 }
4930                 *fpc++ = s - base;              /* fieldsize for FETCH */
4931
4932                 *fpc++ = ischop ? FF_CHECKCHOP : FF_CHECKNL;
4933
4934                 if (prespace)
4935                     *fpc++ = (U16)prespace;
4936                 *fpc++ = FF_ITEM;
4937                 if (ismore)
4938                     *fpc++ = FF_MORE;
4939                 if (ischop)
4940                     *fpc++ = FF_CHOP;
4941             }
4942             base = s;
4943             skipspaces = 0;
4944             continue;
4945         }
4946     }
4947     *fpc++ = FF_END;
4948
4949     assert (fpc <= fops + maxops); /* ensure our buffer estimate was valid */
4950     arg = fpc - fops;
4951     { /* need to jump to the next word */
4952         int z;
4953         z = WORD_ALIGN - SvCUR(sv) % WORD_ALIGN;
4954         SvGROW(sv, SvCUR(sv) + z + arg * sizeof(U32) + 4);
4955         s = SvPVX(sv) + SvCUR(sv) + z;
4956     }
4957     Copy(fops, s, arg, U32);
4958     Safefree(fops);
4959     sv_magic(sv, NULL, PERL_MAGIC_fm, NULL, 0);
4960     SvCOMPILED_on(sv);
4961
4962     if (unchopnum && repeat)
4963         DIE(aTHX_ "Repeated format line will never terminate (~~ and @#)");
4964     return 0;
4965 }
4966
4967
4968 STATIC bool
4969 S_num_overflow(NV value, I32 fldsize, I32 frcsize)
4970 {
4971     /* Can value be printed in fldsize chars, using %*.*f ? */
4972     NV pwr = 1;
4973     NV eps = 0.5;
4974     bool res = FALSE;
4975     int intsize = fldsize - (value < 0 ? 1 : 0);
4976
4977     if (frcsize & 256)
4978         intsize--;
4979     frcsize &= 255;
4980     intsize -= frcsize;
4981
4982     while (intsize--) pwr *= 10.0;
4983     while (frcsize--) eps /= 10.0;
4984
4985     if( value >= 0 ){
4986         if (value + eps >= pwr)
4987             res = TRUE;
4988     } else {
4989         if (value - eps <= -pwr)
4990             res = TRUE;
4991     }
4992     return res;
4993 }
4994
4995 static I32
4996 S_run_user_filter(pTHX_ int idx, SV *buf_sv, int maxlen)
4997 {
4998     dVAR;
4999     SV * const datasv = FILTER_DATA(idx);
5000     const int filter_has_file = IoLINES(datasv);
5001     SV * const filter_state = MUTABLE_SV(IoTOP_GV(datasv));
5002     SV * const filter_sub = MUTABLE_SV(IoBOTTOM_GV(datasv));
5003     int status = 0;
5004     SV *upstream;
5005     STRLEN got_len;
5006     char *got_p = NULL;
5007     char *prune_from = NULL;
5008     bool read_from_cache = FALSE;
5009     STRLEN umaxlen;
5010
5011     PERL_ARGS_ASSERT_RUN_USER_FILTER;
5012
5013     assert(maxlen >= 0);
5014     umaxlen = maxlen;
5015
5016     /* I was having segfault trouble under Linux 2.2.5 after a
5017        parse error occured.  (Had to hack around it with a test
5018        for PL_parser->error_count == 0.)  Solaris doesn't segfault --
5019        not sure where the trouble is yet.  XXX */
5020
5021     {
5022         SV *const cache = datasv;
5023         if (SvOK(cache)) {
5024             STRLEN cache_len;
5025             const char *cache_p = SvPV(cache, cache_len);
5026             STRLEN take = 0;
5027
5028             if (umaxlen) {
5029                 /* Running in block mode and we have some cached data already.
5030                  */
5031                 if (cache_len >= umaxlen) {
5032                     /* In fact, so much data we don't even need to call
5033                        filter_read.  */
5034                     take = umaxlen;
5035                 }
5036             } else {
5037                 const char *const first_nl =
5038                     (const char *)memchr(cache_p, '\n', cache_len);
5039                 if (first_nl) {
5040                     take = first_nl + 1 - cache_p;
5041                 }
5042             }
5043             if (take) {
5044                 sv_catpvn(buf_sv, cache_p, take);
5045                 sv_chop(cache, cache_p + take);
5046                 /* Definately not EOF  */
5047                 return 1;
5048             }
5049
5050             sv_catsv(buf_sv, cache);
5051             if (umaxlen) {
5052                 umaxlen -= cache_len;
5053             }
5054             SvOK_off(cache);
5055             read_from_cache = TRUE;
5056         }
5057     }
5058
5059     /* Filter API says that the filter appends to the contents of the buffer.
5060        Usually the buffer is "", so the details don't matter. But if it's not,
5061        then clearly what it contains is already filtered by this filter, so we
5062        don't want to pass it in a second time.
5063        I'm going to use a mortal in case the upstream filter croaks.  */
5064     upstream = ((SvOK(buf_sv) && sv_len(buf_sv)) || SvGMAGICAL(buf_sv))
5065         ? sv_newmortal() : buf_sv;
5066     SvUPGRADE(upstream, SVt_PV);
5067
5068     if (filter_has_file) {
5069         status = FILTER_READ(idx+1, upstream, 0);
5070     }
5071
5072     if (filter_sub && status >= 0) {
5073         dSP;
5074         int count;
5075
5076         ENTER_with_name("call_filter_sub");
5077         SAVE_DEFSV;
5078         SAVETMPS;
5079         EXTEND(SP, 2);
5080
5081         DEFSV_set(upstream);
5082         PUSHMARK(SP);
5083         mPUSHi(0);
5084         if (filter_state) {
5085             PUSHs(filter_state);
5086         }
5087         PUTBACK;
5088         count = call_sv(filter_sub, G_SCALAR);
5089         SPAGAIN;
5090
5091         if (count > 0) {
5092             SV *out = POPs;
5093             if (SvOK(out)) {
5094                 status = SvIV(out);
5095             }
5096         }
5097
5098         PUTBACK;
5099         FREETMPS;
5100         LEAVE_with_name("call_filter_sub");
5101     }
5102
5103     if(SvOK(upstream)) {
5104         got_p = SvPV(upstream, got_len);
5105         if (umaxlen) {
5106             if (got_len > umaxlen) {
5107                 prune_from = got_p + umaxlen;
5108             }
5109         } else {
5110             char *const first_nl = (char *)memchr(got_p, '\n', got_len);
5111             if (first_nl && first_nl + 1 < got_p + got_len) {
5112                 /* There's a second line here... */
5113                 prune_from = first_nl + 1;
5114             }
5115         }
5116     }
5117     if (prune_from) {
5118         /* Oh. Too long. Stuff some in our cache.  */
5119         STRLEN cached_len = got_p + got_len - prune_from;
5120         SV *const cache = datasv;
5121
5122         if (SvOK(cache)) {
5123             /* Cache should be empty.  */
5124             assert(!SvCUR(cache));
5125         }
5126
5127         sv_setpvn(cache, prune_from, cached_len);
5128         /* If you ask for block mode, you may well split UTF-8 characters.
5129            "If it breaks, you get to keep both parts"
5130            (Your code is broken if you  don't put them back together again
5131            before something notices.) */
5132         if (SvUTF8(upstream)) {
5133             SvUTF8_on(cache);
5134         }
5135         SvCUR_set(upstream, got_len - cached_len);
5136         *prune_from = 0;
5137         /* Can't yet be EOF  */
5138         if (status == 0)
5139             status = 1;
5140     }
5141
5142     /* If they are at EOF but buf_sv has something in it, then they may never
5143        have touched the SV upstream, so it may be undefined.  If we naively
5144        concatenate it then we get a warning about use of uninitialised value.
5145     */
5146     if (upstream != buf_sv && (SvOK(upstream) || SvGMAGICAL(upstream))) {
5147         sv_catsv(buf_sv, upstream);
5148     }
5149
5150     if (status <= 0) {
5151         IoLINES(datasv) = 0;
5152         if (filter_state) {
5153             SvREFCNT_dec(filter_state);
5154             IoTOP_GV(datasv) = NULL;
5155         }
5156         if (filter_sub) {
5157             SvREFCNT_dec(filter_sub);
5158             IoBOTTOM_GV(datasv) = NULL;
5159         }
5160         filter_del(S_run_user_filter);
5161     }
5162     if (status == 0 && read_from_cache) {
5163         /* If we read some data from the cache (and by getting here it implies
5164            that we emptied the cache) then we aren't yet at EOF, and mustn't
5165            report that to our caller.  */
5166         return 1;
5167     }
5168     return status;
5169 }
5170
5171 /* perhaps someone can come up with a better name for
5172    this?  it is not really "absolute", per se ... */
5173 static bool
5174 S_path_is_absolute(const char *name)
5175 {
5176     PERL_ARGS_ASSERT_PATH_IS_ABSOLUTE;
5177
5178     if (PERL_FILE_IS_ABSOLUTE(name)
5179 #ifdef WIN32
5180         || (*name == '.' && ((name[1] == '/' ||
5181                              (name[1] == '.' && name[2] == '/'))
5182                          || (name[1] == '\\' ||
5183                              ( name[1] == '.' && name[2] == '\\')))
5184             )
5185 #else
5186         || (*name == '.' && (name[1] == '/' ||
5187                              (name[1] == '.' && name[2] == '/')))
5188 #endif
5189          )
5190     {
5191         return TRUE;
5192     }
5193     else
5194         return FALSE;
5195 }
5196
5197 /*
5198  * Local variables:
5199  * c-indentation-style: bsd
5200  * c-basic-offset: 4
5201  * indent-tabs-mode: t
5202  * End:
5203  *
5204  * ex: set ts=8 sts=4 sw=4 noet:
5205  */