pp_ctl.c

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