pp_ctl.c

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