pp_ctl.c

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