pp_ctl.c

   1 /*    pp_ctl.c
   2  *
   3  *    Copyright (C) 1991, 1992, 1993, 1994, 1995, 1996, 1997, 1998, 1999, 2000,
   4  *    2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008 by Larry Wall and others
   5  *
   6  *    You may distribute under the terms of either the GNU General Public
   7  *    License or the Artistic License, as specified in the README file.
   8  *
   9  */
  10
  11 /*
  12  *      Now far ahead the Road has gone,
  13  *          And I must follow, if I can,
  14  *      Pursuing it with eager feet,
  15  *          Until it joins some larger way
  16  *      Where many paths and errands meet.
  17  *          And whither then?  I cannot say.
  18  *
  19  *     [Bilbo on p.35 of _The Lord of the Rings_, I/i: "A Long-Expected Party"]
  20  */
  21
  22 /* This file contains control-oriented pp ("push/pop") functions that
  23  * execute the opcodes that make up a perl program. A typical pp function
  24  * expects to find its arguments on the stack, and usually pushes its
  25  * results onto the stack, hence the 'pp' terminology. Each OP structure
  26  * contains a pointer to the relevant pp_foo() function.
  27  *
  28  * Control-oriented means things like pp_enteriter() and pp_next(), which
  29  * alter the flow of control of the program.
  30  */
  31
  32
  33 #include "EXTERN.h"
  34 #define PERL_IN_PP_CTL_C
  35 #include "perl.h"
  36
  37 #ifndef WORD_ALIGN
  38 #define WORD_ALIGN sizeof(U32)
  39 #endif
  40
  41 #define DOCATCH(o) ((CATCH_GET == TRUE) ? docatch(o) : (o))
  42
  43 #define dopoptosub(plop)        dopoptosub_at(cxstack, (plop))
  44
  45 PP(pp_wantarray)
  46 {
  47     dVAR;
  48     dSP;
  49     I32 cxix;
  50     EXTEND(SP, 1);
  51
  52     cxix = dopoptosub(cxstack_ix);
  53     if (cxix < 0)
  54         RETPUSHUNDEF;
  55
  56     switch (cxstack[cxix].blk_gimme) {
  57     case G_ARRAY:
  58         RETPUSHYES;
  59     case G_SCALAR:
  60         RETPUSHNO;
  61     default:
  62         RETPUSHUNDEF;
  63     }
  64 }
  65
  66 PP(pp_regcreset)
  67 {
  68     dVAR;
  69     /* XXXX Should store the old value to allow for tie/overload - and
  70        restore in regcomp, where marked with XXXX. */
  71     PL_reginterp_cnt = 0;
  72     TAINT_NOT;
  73     return NORMAL;
  74 }
  75
  76 PP(pp_regcomp)
  77 {
  78     dVAR;
  79     dSP;
  80     register PMOP *pm = (PMOP*)cLOGOP->op_other;
  81     SV *tmpstr;
  82     REGEXP *re = NULL;
  83
  84     /* prevent recompiling under /o and ithreads. */
  85 #if defined(USE_ITHREADS)
  86     if (pm->op_pmflags & PMf_KEEP && PM_GETRE(pm)) {
  87         if (PL_op->op_flags & OPf_STACKED) {
  88             dMARK;
  89             SP = MARK;
  90         }
  91         else
  92             (void)POPs;
  93         RETURN;
  94     }
  95 #endif
  96
  97 #define tryAMAGICregexp(rx)                     \
  98     STMT_START {                                \
  99         SvGETMAGIC(rx);                         \
 100         if (SvROK(rx) && SvAMAGIC(rx)) {        \
 101             SV *sv = AMG_CALLun(rx, regexp);    \
 102             if (sv) {                           \
 103                 if (SvROK(sv))                  \
 104                     sv = SvRV(sv);              \
 105                 if (SvTYPE(sv) != SVt_REGEXP)   \
 106                     Perl_croak(aTHX_ "Overloaded qr did not return a REGEXP"); \
 107                 rx = sv;                        \
 108             }                                   \
 109         }                                       \
 110     } STMT_END
 111
 112
 113     if (PL_op->op_flags & OPf_STACKED) {
 114         /* multiple args; concatentate them */
 115         dMARK; dORIGMARK;
 116         tmpstr = PAD_SV(ARGTARG);
 117         sv_setpvs(tmpstr, "");
 118         while (++MARK <= SP) {
 119             SV *msv = *MARK;
 120             SV *sv;
 121
 122             tryAMAGICregexp(msv);
 123
 124             if ((SvAMAGIC(tmpstr) || SvAMAGIC(msv)) &&
 125                 (sv = amagic_call(tmpstr, msv, concat_amg, AMGf_assign)))
 126             {
 127                sv_setsv(tmpstr, sv);
 128                continue;
 129             }
 130             sv_catsv_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 & 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     pp_pushmark();                              /* push dst */
1043     pp_pushmark();                              /* 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         pp_pushmark();                  /* 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         while ((cxix = dopoptoeval(cxstack_ix)) < 0
1649                && PL_curstackinfo->si_prev)
1650         {
1651             dounwind(-1);
1652             POPSTACK;
1653         }
1654
1655         if (cxix >= 0) {
1656             I32 optype;
1657             SV *namesv;
1658             register PERL_CONTEXT *cx;
1659             SV **newsp;
1660             COP *oldcop;
1661             JMPENV *restartjmpenv;
1662             OP *restartop;
1663
1664             if (cxix < cxstack_ix)
1665                 dounwind(cxix);
1666
1667             POPBLOCK(cx,PL_curpm);
1668             if (CxTYPE(cx) != CXt_EVAL) {
1669                 STRLEN msglen;
1670                 const char* message = SvPVx_const(exceptsv, msglen);
1671                 PerlIO_write(Perl_error_log, (const char *)"panic: die ", 11);
1672                 PerlIO_write(Perl_error_log, message, msglen);
1673                 my_exit(1);
1674             }
1675             POPEVAL(cx);
1676             namesv = cx->blk_eval.old_namesv;
1677             oldcop = cx->blk_oldcop;
1678             restartjmpenv = cx->blk_eval.cur_top_env;
1679             restartop = cx->blk_eval.retop;
1680
1681             if (gimme == G_SCALAR)
1682                 *++newsp = &PL_sv_undef;
1683             PL_stack_sp = newsp;
1684
1685             LEAVE;
1686
1687             /* LEAVE could clobber PL_curcop (see save_re_context())
1688              * XXX it might be better to find a way to avoid messing with
1689              * PL_curcop in save_re_context() instead, but this is a more
1690              * minimal fix --GSAR */
1691             PL_curcop = oldcop;
1692
1693             if (optype == OP_REQUIRE) {
1694                 const char* const msg = SvPVx_nolen_const(exceptsv);
1695                 (void)hv_store(GvHVn(PL_incgv),
1696                                SvPVX_const(namesv), SvCUR(namesv),
1697                                &PL_sv_undef, 0);
1698                 /* note that unlike pp_entereval, pp_require isn't
1699                  * supposed to trap errors. So now that we've popped the
1700                  * EVAL that pp_require pushed, and processed the error
1701                  * message, rethrow the error */
1702                 Perl_croak(aTHX_ "%sCompilation failed in require",
1703                            *msg ? msg : "Unknown error\n");
1704             }
1705             if (in_eval & EVAL_KEEPERR) {
1706                 Perl_ck_warner(aTHX_ packWARN(WARN_MISC), "\t(in cleanup) %s",
1707                                SvPV_nolen_const(exceptsv));
1708             }
1709             else {
1710                 sv_setsv(ERRSV, exceptsv);
1711             }
1712             PL_restartjmpenv = restartjmpenv;
1713             PL_restartop = restartop;
1714             JMPENV_JUMP(3);
1715             /* NOTREACHED */
1716         }
1717     }
1718
1719     write_to_stderr(exceptsv);
1720     my_failure_exit();
1721     /* NOTREACHED */
1722 }
1723
1724 PP(pp_xor)
1725 {
1726     dVAR; dSP; dPOPTOPssrl;
1727     if (SvTRUE(left) != SvTRUE(right))
1728         RETSETYES;
1729     else
1730         RETSETNO;
1731 }
1732
1733 /*
1734 =for apidoc caller_cx
1735
1736 The XSUB-writer's equivalent of L<caller()|perlfunc/caller>. The
1737 returned C<PERL_CONTEXT> structure can be interrogated to find all the
1738 information returned to Perl by C<caller>. Note that XSUBs don't get a
1739 stack frame, so C<caller_cx(0, NULL)> will return information for the
1740 immediately-surrounding Perl code.
1741
1742 This function skips over the automatic calls to C<&DB::sub> made on the
1743 behalf of the debugger. If the stack frame requested was a sub called by
1744 C<DB::sub>, the return value will be the frame for the call to
1745 C<DB::sub>, since that has the correct line number/etc. for the call
1746 site. If I<dbcxp> is non-C<NULL>, it will be set to a pointer to the
1747 frame for the sub call itself.
1748
1749 =cut
1750 */
1751
1752 const PERL_CONTEXT *
1753 Perl_caller_cx(pTHX_ I32 count, const PERL_CONTEXT **dbcxp)
1754 {
1755     register I32 cxix = dopoptosub(cxstack_ix);
1756     register const PERL_CONTEXT *cx;
1757     register const PERL_CONTEXT *ccstack = cxstack;
1758     const PERL_SI *top_si = PL_curstackinfo;
1759
1760     for (;;) {
1761         /* we may be in a higher stacklevel, so dig down deeper */
1762         while (cxix < 0 && top_si->si_type != PERLSI_MAIN) {
1763             top_si = top_si->si_prev;
1764             ccstack = top_si->si_cxstack;
1765             cxix = dopoptosub_at(ccstack, top_si->si_cxix);
1766         }
1767         if (cxix < 0)
1768             return NULL;
1769         /* caller() should not report the automatic calls to &DB::sub */
1770         if (PL_DBsub && GvCV(PL_DBsub) && cxix >= 0 &&
1771                 ccstack[cxix].blk_sub.cv == GvCV(PL_DBsub))
1772             count++;
1773         if (!count--)
1774             break;
1775         cxix = dopoptosub_at(ccstack, cxix - 1);
1776     }
1777
1778     cx = &ccstack[cxix];
1779     if (dbcxp) *dbcxp = cx;
1780
1781     if (CxTYPE(cx) == CXt_SUB || CxTYPE(cx) == CXt_FORMAT) {
1782         const I32 dbcxix = dopoptosub_at(ccstack, cxix - 1);
1783         /* We expect that ccstack[dbcxix] is CXt_SUB, anyway, the
1784            field below is defined for any cx. */
1785         /* caller() should not report the automatic calls to &DB::sub */
1786         if (PL_DBsub && GvCV(PL_DBsub) && dbcxix >= 0 && ccstack[dbcxix].blk_sub.cv == GvCV(PL_DBsub))
1787             cx = &ccstack[dbcxix];
1788     }
1789
1790     return cx;
1791 }
1792
1793 PP(pp_caller)
1794 {
1795     dVAR;
1796     dSP;
1797     register const PERL_CONTEXT *cx;
1798     const PERL_CONTEXT *dbcx;
1799     I32 gimme;
1800     const char *stashname;
1801     I32 count = 0;
1802
1803     if (MAXARG)
1804         count = POPi;
1805
1806     cx = caller_cx(count, &dbcx);
1807     if (!cx) {
1808         if (GIMME != G_ARRAY) {
1809             EXTEND(SP, 1);
1810             RETPUSHUNDEF;
1811         }
1812         RETURN;
1813     }
1814
1815     stashname = CopSTASHPV(cx->blk_oldcop);
1816     if (GIMME != G_ARRAY) {
1817         EXTEND(SP, 1);
1818         if (!stashname)
1819             PUSHs(&PL_sv_undef);
1820         else {
1821             dTARGET;
1822             sv_setpv(TARG, stashname);
1823             PUSHs(TARG);
1824         }
1825         RETURN;
1826     }
1827
1828     EXTEND(SP, 11);
1829
1830     if (!stashname)
1831         PUSHs(&PL_sv_undef);
1832     else
1833         mPUSHs(newSVpv(stashname, 0));
1834     mPUSHs(newSVpv(OutCopFILE(cx->blk_oldcop), 0));
1835     mPUSHi((I32)CopLINE(cx->blk_oldcop));
1836     if (!MAXARG)
1837         RETURN;
1838     if (CxTYPE(cx) == CXt_SUB || CxTYPE(cx) == CXt_FORMAT) {
1839         GV * const cvgv = CvGV(dbcx->blk_sub.cv);
1840         /* So is ccstack[dbcxix]. */
1841         if (isGV(cvgv)) {
1842             SV * const sv = newSV(0);
1843             gv_efullname3(sv, cvgv, NULL);
1844             mPUSHs(sv);
1845             PUSHs(boolSV(CxHASARGS(cx)));
1846         }
1847         else {
1848             PUSHs(newSVpvs_flags("(unknown)", SVs_TEMP));
1849             PUSHs(boolSV(CxHASARGS(cx)));
1850         }
1851     }
1852     else {
1853         PUSHs(newSVpvs_flags("(eval)", SVs_TEMP));
1854         mPUSHi(0);
1855     }
1856     gimme = (I32)cx->blk_gimme;
1857     if (gimme == G_VOID)
1858         PUSHs(&PL_sv_undef);
1859     else
1860         PUSHs(boolSV((gimme & G_WANT) == G_ARRAY));
1861     if (CxTYPE(cx) == CXt_EVAL) {
1862         /* eval STRING */
1863         if (CxOLD_OP_TYPE(cx) == OP_ENTEREVAL) {
1864             PUSHs(cx->blk_eval.cur_text);
1865             PUSHs(&PL_sv_no);
1866         }
1867         /* require */
1868         else if (cx->blk_eval.old_namesv) {
1869             mPUSHs(newSVsv(cx->blk_eval.old_namesv));
1870             PUSHs(&PL_sv_yes);
1871         }
1872         /* eval BLOCK (try blocks have old_namesv == 0) */
1873         else {
1874             PUSHs(&PL_sv_undef);
1875             PUSHs(&PL_sv_undef);
1876         }
1877     }
1878     else {
1879         PUSHs(&PL_sv_undef);
1880         PUSHs(&PL_sv_undef);
1881     }
1882     if (CxTYPE(cx) == CXt_SUB && CxHASARGS(cx)
1883         && CopSTASH_eq(PL_curcop, PL_debstash))
1884     {
1885         AV * const ary = cx->blk_sub.argarray;
1886         const int off = AvARRAY(ary) - AvALLOC(ary);
1887
1888         if (!PL_dbargs)
1889             Perl_init_dbargs(aTHX);
1890
1891         if (AvMAX(PL_dbargs) < AvFILLp(ary) + off)
1892             av_extend(PL_dbargs, AvFILLp(ary) + off);
1893         Copy(AvALLOC(ary), AvARRAY(PL_dbargs), AvFILLp(ary) + 1 + off, SV*);
1894         AvFILLp(PL_dbargs) = AvFILLp(ary) + off;
1895     }
1896     /* XXX only hints propagated via op_private are currently
1897      * visible (others are not easily accessible, since they
1898      * use the global PL_hints) */
1899     mPUSHi(CopHINTS_get(cx->blk_oldcop));
1900     {
1901         SV * mask ;
1902         STRLEN * const old_warnings = cx->blk_oldcop->cop_warnings ;
1903
1904         if  (old_warnings == pWARN_NONE ||
1905                 (old_warnings == pWARN_STD && (PL_dowarn & G_WARN_ON) == 0))
1906             mask = newSVpvn(WARN_NONEstring, WARNsize) ;
1907         else if (old_warnings == pWARN_ALL ||
1908                   (old_warnings == pWARN_STD && PL_dowarn & G_WARN_ON)) {
1909             /* Get the bit mask for $warnings::Bits{all}, because
1910              * it could have been extended by warnings::register */
1911             SV **bits_all;
1912             HV * const bits = get_hv("warnings::Bits", 0);
1913             if (bits && (bits_all=hv_fetchs(bits, "all", FALSE))) {
1914                 mask = newSVsv(*bits_all);
1915             }
1916             else {
1917                 mask = newSVpvn(WARN_ALLstring, WARNsize) ;
1918             }
1919         }
1920         else
1921             mask = newSVpvn((char *) (old_warnings + 1), old_warnings[0]);
1922         mPUSHs(mask);
1923     }
1924
1925     PUSHs(cx->blk_oldcop->cop_hints_hash ?
1926           sv_2mortal(newRV_noinc(MUTABLE_SV(cop_hints_2hv(cx->blk_oldcop, 0))))
1927           : &PL_sv_undef);
1928     RETURN;
1929 }
1930
1931 PP(pp_reset)
1932 {
1933     dVAR;
1934     dSP;
1935     const char * const tmps = (MAXARG < 1) ? (const char *)"" : POPpconstx;
1936     sv_reset(tmps, CopSTASH(PL_curcop));
1937     PUSHs(&PL_sv_yes);
1938     RETURN;
1939 }
1940
1941 /* like pp_nextstate, but used instead when the debugger is active */
1942
1943 PP(pp_dbstate)
1944 {
1945     dVAR;
1946     PL_curcop = (COP*)PL_op;
1947     TAINT_NOT;          /* Each statement is presumed innocent */
1948     PL_stack_sp = PL_stack_base + cxstack[cxstack_ix].blk_oldsp;
1949     FREETMPS;
1950
1951     PERL_ASYNC_CHECK();
1952
1953     if (PL_op->op_flags & OPf_SPECIAL /* breakpoint */
1954             || SvIV(PL_DBsingle) || SvIV(PL_DBsignal) || SvIV(PL_DBtrace))
1955     {
1956         dSP;
1957         register PERL_CONTEXT *cx;
1958         const I32 gimme = G_ARRAY;
1959         U8 hasargs;
1960         GV * const gv = PL_DBgv;
1961         register CV * const cv = GvCV(gv);
1962
1963         if (!cv)
1964             DIE(aTHX_ "No DB::DB routine defined");
1965
1966         if (CvDEPTH(cv) >= 1 && !(PL_debug & DEBUG_DB_RECURSE_FLAG))
1967             /* don't do recursive DB::DB call */
1968             return NORMAL;
1969
1970         ENTER;
1971         SAVETMPS;
1972
1973         SAVEI32(PL_debug);
1974         SAVESTACK_POS();
1975         PL_debug = 0;
1976         hasargs = 0;
1977         SPAGAIN;
1978
1979         if (CvISXSUB(cv)) {
1980             CvDEPTH(cv)++;
1981             PUSHMARK(SP);
1982             (void)(*CvXSUB(cv))(aTHX_ cv);
1983             CvDEPTH(cv)--;
1984             FREETMPS;
1985             LEAVE;
1986             return NORMAL;
1987         }
1988         else {
1989             PUSHBLOCK(cx, CXt_SUB, SP);
1990             PUSHSUB_DB(cx);
1991             cx->blk_sub.retop = PL_op->op_next;
1992             CvDEPTH(cv)++;
1993             SAVECOMPPAD();
1994             PAD_SET_CUR_NOSAVE(CvPADLIST(cv), 1);
1995             RETURNOP(CvSTART(cv));
1996         }
1997     }
1998     else
1999         return NORMAL;
2000 }
2001
2002 PP(pp_enteriter)
2003 {
2004     dVAR; dSP; dMARK;
2005     register PERL_CONTEXT *cx;
2006     const I32 gimme = GIMME_V;
2007     void *itervar; /* location of the iteration variable */
2008     U8 cxtype = CXt_LOOP_FOR;
2009
2010     ENTER_with_name("loop1");
2011     SAVETMPS;
2012
2013     if (PL_op->op_targ) {                        /* "my" variable */
2014         if (PL_op->op_private & OPpLVAL_INTRO) {        /* for my $x (...) */
2015             SvPADSTALE_off(PAD_SVl(PL_op->op_targ));
2016             SAVESETSVFLAGS(PAD_SVl(PL_op->op_targ),
2017                     SVs_PADSTALE, SVs_PADSTALE);
2018         }
2019         SAVEPADSVANDMORTALIZE(PL_op->op_targ);
2020 #ifdef USE_ITHREADS
2021         itervar = PL_comppad;
2022 #else
2023         itervar = &PAD_SVl(PL_op->op_targ);
2024 #endif
2025     }
2026     else {                                      /* symbol table variable */
2027         GV * const gv = MUTABLE_GV(POPs);
2028         SV** svp = &GvSV(gv);
2029         save_pushptrptr(gv, SvREFCNT_inc(*svp), SAVEt_GVSV);
2030         *svp = newSV(0);
2031         itervar = (void *)gv;
2032     }
2033
2034     if (PL_op->op_private & OPpITER_DEF)
2035         cxtype |= CXp_FOR_DEF;
2036
2037     ENTER_with_name("loop2");
2038
2039     PUSHBLOCK(cx, cxtype, SP);
2040     PUSHLOOP_FOR(cx, itervar, MARK);
2041     if (PL_op->op_flags & OPf_STACKED) {
2042         SV *maybe_ary = POPs;
2043         if (SvTYPE(maybe_ary) != SVt_PVAV) {
2044             dPOPss;
2045             SV * const right = maybe_ary;
2046             SvGETMAGIC(sv);
2047             SvGETMAGIC(right);
2048             if (RANGE_IS_NUMERIC(sv,right)) {
2049                 cx->cx_type &= ~CXTYPEMASK;
2050                 cx->cx_type |= CXt_LOOP_LAZYIV;
2051                 /* Make sure that no-one re-orders cop.h and breaks our
2052                    assumptions */
2053                 assert(CxTYPE(cx) == CXt_LOOP_LAZYIV);
2054 #ifdef NV_PRESERVES_UV
2055                 if ((SvOK(sv) && ((SvNV(sv) < (NV)IV_MIN) ||
2056                                   (SvNV(sv) > (NV)IV_MAX)))
2057                         ||
2058                     (SvOK(right) && ((SvNV(right) > (NV)IV_MAX) ||
2059                                      (SvNV(right) < (NV)IV_MIN))))
2060 #else
2061                 if ((SvOK(sv) && ((SvNV(sv) <= (NV)IV_MIN)
2062                                   ||
2063                                   ((SvNV(sv) > 0) &&
2064                                         ((SvUV(sv) > (UV)IV_MAX) ||
2065                                          (SvNV(sv) > (NV)UV_MAX)))))
2066                         ||
2067                     (SvOK(right) && ((SvNV(right) <= (NV)IV_MIN)
2068                                      ||
2069                                      ((SvNV(right) > 0) &&
2070                                         ((SvUV(right) > (UV)IV_MAX) ||
2071                                          (SvNV(right) > (NV)UV_MAX))))))
2072 #endif
2073                     DIE(aTHX_ "Range iterator outside integer range");
2074                 cx->blk_loop.state_u.lazyiv.cur = SvIV(sv);
2075                 cx->blk_loop.state_u.lazyiv.end = SvIV(right);
2076 #ifdef DEBUGGING
2077                 /* for correct -Dstv display */
2078                 cx->blk_oldsp = sp - PL_stack_base;
2079 #endif
2080             }
2081             else {
2082                 cx->cx_type &= ~CXTYPEMASK;
2083                 cx->cx_type |= CXt_LOOP_LAZYSV;
2084                 /* Make sure that no-one re-orders cop.h and breaks our
2085                    assumptions */
2086                 assert(CxTYPE(cx) == CXt_LOOP_LAZYSV);
2087                 cx->blk_loop.state_u.lazysv.cur = newSVsv(sv);
2088                 cx->blk_loop.state_u.lazysv.end = right;
2089                 SvREFCNT_inc(right);
2090                 (void) SvPV_force_nolen(cx->blk_loop.state_u.lazysv.cur);
2091                 /* This will do the upgrade to SVt_PV, and warn if the value
2092                    is uninitialised.  */
2093                 (void) SvPV_nolen_const(right);
2094                 /* Doing this avoids a check every time in pp_iter in pp_hot.c
2095                    to replace !SvOK() with a pointer to "".  */
2096                 if (!SvOK(right)) {
2097                     SvREFCNT_dec(right);
2098                     cx->blk_loop.state_u.lazysv.end = &PL_sv_no;
2099                 }
2100             }
2101         }
2102         else /* SvTYPE(maybe_ary) == SVt_PVAV */ {
2103             cx->blk_loop.state_u.ary.ary = MUTABLE_AV(maybe_ary);
2104             SvREFCNT_inc(maybe_ary);
2105             cx->blk_loop.state_u.ary.ix =
2106                 (PL_op->op_private & OPpITER_REVERSED) ?
2107                 AvFILL(cx->blk_loop.state_u.ary.ary) + 1 :
2108                 -1;
2109         }
2110     }
2111     else { /* iterating over items on the stack */
2112         cx->blk_loop.state_u.ary.ary = NULL; /* means to use the stack */
2113         if (PL_op->op_private & OPpITER_REVERSED) {
2114             cx->blk_loop.state_u.ary.ix = cx->blk_oldsp + 1;
2115         }
2116         else {
2117             cx->blk_loop.state_u.ary.ix = MARK - PL_stack_base;
2118         }
2119     }
2120
2121     RETURN;
2122 }
2123
2124 PP(pp_enterloop)
2125 {
2126     dVAR; dSP;
2127     register PERL_CONTEXT *cx;
2128     const I32 gimme = GIMME_V;
2129
2130     ENTER_with_name("loop1");
2131     SAVETMPS;
2132     ENTER_with_name("loop2");
2133
2134     PUSHBLOCK(cx, CXt_LOOP_PLAIN, SP);
2135     PUSHLOOP_PLAIN(cx, SP);
2136
2137     RETURN;
2138 }
2139
2140 PP(pp_leaveloop)
2141 {
2142     dVAR; dSP;
2143     register PERL_CONTEXT *cx;
2144     I32 gimme;
2145     SV **newsp;
2146     PMOP *newpm;
2147     SV **mark;
2148
2149     POPBLOCK(cx,newpm);
2150     assert(CxTYPE_is_LOOP(cx));
2151     mark = newsp;
2152     newsp = PL_stack_base + cx->blk_loop.resetsp;
2153
2154     TAINT_NOT;
2155     if (gimme == G_VOID)
2156         NOOP;
2157     else if (gimme == G_SCALAR) {
2158         if (mark < SP)
2159             *++newsp = sv_mortalcopy(*SP);
2160         else
2161             *++newsp = &PL_sv_undef;
2162     }
2163     else {
2164         while (mark < SP) {
2165             *++newsp = sv_mortalcopy(*++mark);
2166             TAINT_NOT;          /* Each item is independent */
2167         }
2168     }
2169     SP = newsp;
2170     PUTBACK;
2171
2172     POPLOOP(cx);        /* Stack values are safe: release loop vars ... */
2173     PL_curpm = newpm;   /* ... and pop $1 et al */
2174
2175     LEAVE_with_name("loop2");
2176     LEAVE_with_name("loop1");
2177
2178     return NORMAL;
2179 }
2180
2181 PP(pp_return)
2182 {
2183     dVAR; dSP; dMARK;
2184     register PERL_CONTEXT *cx;
2185     bool popsub2 = FALSE;
2186     bool clear_errsv = FALSE;
2187     I32 gimme;
2188     SV **newsp;
2189     PMOP *newpm;
2190     I32 optype = 0;
2191     SV *namesv;
2192     SV *sv;
2193     OP *retop = NULL;
2194
2195     const I32 cxix = dopoptosub(cxstack_ix);
2196
2197     if (cxix < 0) {
2198         if (CxMULTICALL(cxstack)) { /* In this case we must be in a
2199                                      * sort block, which is a CXt_NULL
2200                                      * not a CXt_SUB */
2201             dounwind(0);
2202             PL_stack_base[1] = *PL_stack_sp;
2203             PL_stack_sp = PL_stack_base + 1;
2204             return 0;
2205         }
2206         else
2207             DIE(aTHX_ "Can't return outside a subroutine");
2208     }
2209     if (cxix < cxstack_ix)
2210         dounwind(cxix);
2211
2212     if (CxMULTICALL(&cxstack[cxix])) {
2213         gimme = cxstack[cxix].blk_gimme;
2214         if (gimme == G_VOID)
2215             PL_stack_sp = PL_stack_base;
2216         else if (gimme == G_SCALAR) {
2217             PL_stack_base[1] = *PL_stack_sp;
2218             PL_stack_sp = PL_stack_base + 1;
2219         }
2220         return 0;
2221     }
2222
2223     POPBLOCK(cx,newpm);
2224     switch (CxTYPE(cx)) {
2225     case CXt_SUB:
2226         popsub2 = TRUE;
2227         retop = cx->blk_sub.retop;
2228         cxstack_ix++; /* preserve cx entry on stack for use by POPSUB */
2229         break;
2230     case CXt_EVAL:
2231         if (!(PL_in_eval & EVAL_KEEPERR))
2232             clear_errsv = TRUE;
2233         POPEVAL(cx);
2234         namesv = cx->blk_eval.old_namesv;
2235         retop = cx->blk_eval.retop;
2236         if (CxTRYBLOCK(cx))
2237             break;
2238         if (optype == OP_REQUIRE &&
2239             (MARK == SP || (gimme == G_SCALAR && !SvTRUE(*SP))) )
2240         {
2241             /* Unassume the success we assumed earlier. */
2242             (void)hv_delete(GvHVn(PL_incgv),
2243                             SvPVX_const(namesv), SvCUR(namesv),
2244                             G_DISCARD);
2245             DIE(aTHX_ "%"SVf" did not return a true value", SVfARG(namesv));
2246         }
2247         break;
2248     case CXt_FORMAT:
2249         POPFORMAT(cx);
2250         retop = cx->blk_sub.retop;
2251         break;
2252     default:
2253         DIE(aTHX_ "panic: return");
2254     }
2255
2256     TAINT_NOT;
2257     if (gimme == G_SCALAR) {
2258         if (MARK < SP) {
2259             if (popsub2) {
2260                 if (cx->blk_sub.cv && CvDEPTH(cx->blk_sub.cv) > 1) {
2261                     if (SvTEMP(TOPs)) {
2262                         *++newsp = SvREFCNT_inc(*SP);
2263                         FREETMPS;
2264                         sv_2mortal(*newsp);
2265                     }
2266                     else {
2267                         sv = SvREFCNT_inc(*SP); /* FREETMPS could clobber it */
2268                         FREETMPS;
2269                         *++newsp = sv_mortalcopy(sv);
2270                         SvREFCNT_dec(sv);
2271                     }
2272                 }
2273                 else
2274                     *++newsp = (SvTEMP(*SP)) ? *SP : sv_mortalcopy(*SP);
2275             }
2276             else
2277                 *++newsp = sv_mortalcopy(*SP);
2278         }
2279         else
2280             *++newsp = &PL_sv_undef;
2281     }
2282     else if (gimme == G_ARRAY) {
2283         while (++MARK <= SP) {
2284             *++newsp = (popsub2 && SvTEMP(*MARK))
2285                         ? *MARK : sv_mortalcopy(*MARK);
2286             TAINT_NOT;          /* Each item is independent */
2287         }
2288     }
2289     PL_stack_sp = newsp;
2290
2291     LEAVE;
2292     /* Stack values are safe: */
2293     if (popsub2) {
2294         cxstack_ix--;
2295         POPSUB(cx,sv);  /* release CV and @_ ... */
2296     }
2297     else
2298         sv = NULL;
2299     PL_curpm = newpm;   /* ... and pop $1 et al */
2300
2301     LEAVESUB(sv);
2302     if (clear_errsv) {
2303         CLEAR_ERRSV();
2304     }
2305     return retop;
2306 }
2307
2308 PP(pp_last)
2309 {
2310     dVAR; dSP;
2311     I32 cxix;
2312     register PERL_CONTEXT *cx;
2313     I32 pop2 = 0;
2314     I32 gimme;
2315     I32 optype;
2316     OP *nextop = NULL;
2317     SV **newsp;
2318     PMOP *newpm;
2319     SV **mark;
2320     SV *sv = NULL;
2321
2322
2323     if (PL_op->op_flags & OPf_SPECIAL) {
2324         cxix = dopoptoloop(cxstack_ix);
2325         if (cxix < 0)
2326             DIE(aTHX_ "Can't \"last\" outside a loop block");
2327     }
2328     else {
2329         cxix = dopoptolabel(cPVOP->op_pv);
2330         if (cxix < 0)
2331             DIE(aTHX_ "Label not found for \"last %s\"", cPVOP->op_pv);
2332     }
2333     if (cxix < cxstack_ix)
2334         dounwind(cxix);
2335
2336     POPBLOCK(cx,newpm);
2337     cxstack_ix++; /* temporarily protect top context */
2338     mark = newsp;
2339     switch (CxTYPE(cx)) {
2340     case CXt_LOOP_LAZYIV:
2341     case CXt_LOOP_LAZYSV:
2342     case CXt_LOOP_FOR:
2343     case CXt_LOOP_PLAIN:
2344         pop2 = CxTYPE(cx);
2345         newsp = PL_stack_base + cx->blk_loop.resetsp;
2346         nextop = cx->blk_loop.my_op->op_lastop->op_next;
2347         break;
2348     case CXt_SUB:
2349         pop2 = CXt_SUB;
2350         nextop = cx->blk_sub.retop;
2351         break;
2352     case CXt_EVAL:
2353         POPEVAL(cx);
2354         nextop = cx->blk_eval.retop;
2355         break;
2356     case CXt_FORMAT:
2357         POPFORMAT(cx);
2358         nextop = cx->blk_sub.retop;
2359         break;
2360     default:
2361         DIE(aTHX_ "panic: last");
2362     }
2363
2364     TAINT_NOT;
2365     if (gimme == G_SCALAR) {
2366         if (MARK < SP)
2367             *++newsp = ((pop2 == CXt_SUB) && SvTEMP(*SP))
2368                         ? *SP : sv_mortalcopy(*SP);
2369         else
2370             *++newsp = &PL_sv_undef;
2371     }
2372     else if (gimme == G_ARRAY) {
2373         while (++MARK <= SP) {
2374             *++newsp = ((pop2 == CXt_SUB) && SvTEMP(*MARK))
2375                         ? *MARK : sv_mortalcopy(*MARK);
2376             TAINT_NOT;          /* Each item is independent */
2377         }
2378     }
2379     SP = newsp;
2380     PUTBACK;
2381
2382     LEAVE;
2383     cxstack_ix--;
2384     /* Stack values are safe: */
2385     switch (pop2) {
2386     case CXt_LOOP_LAZYIV:
2387     case CXt_LOOP_PLAIN:
2388     case CXt_LOOP_LAZYSV:
2389     case CXt_LOOP_FOR:
2390         POPLOOP(cx);    /* release loop vars ... */
2391         LEAVE;
2392         break;
2393     case CXt_SUB:
2394         POPSUB(cx,sv);  /* release CV and @_ ... */
2395         break;
2396     }
2397     PL_curpm = newpm;   /* ... and pop $1 et al */
2398
2399     LEAVESUB(sv);
2400     PERL_UNUSED_VAR(optype);
2401     PERL_UNUSED_VAR(gimme);
2402     return nextop;
2403 }
2404
2405 PP(pp_next)
2406 {
2407     dVAR;
2408     I32 cxix;
2409     register PERL_CONTEXT *cx;
2410     I32 inner;
2411
2412     if (PL_op->op_flags & OPf_SPECIAL) {
2413         cxix = dopoptoloop(cxstack_ix);
2414         if (cxix < 0)
2415             DIE(aTHX_ "Can't \"next\" outside a loop block");
2416     }
2417     else {
2418         cxix = dopoptolabel(cPVOP->op_pv);
2419         if (cxix < 0)
2420             DIE(aTHX_ "Label not found for \"next %s\"", cPVOP->op_pv);
2421     }
2422     if (cxix < cxstack_ix)
2423         dounwind(cxix);
2424
2425     /* clear off anything above the scope we're re-entering, but
2426      * save the rest until after a possible continue block */
2427     inner = PL_scopestack_ix;
2428     TOPBLOCK(cx);
2429     if (PL_scopestack_ix < inner)
2430         leave_scope(PL_scopestack[PL_scopestack_ix]);
2431     PL_curcop = cx->blk_oldcop;
2432     return (cx)->blk_loop.my_op->op_nextop;
2433 }
2434
2435 PP(pp_redo)
2436 {
2437     dVAR;
2438     I32 cxix;
2439     register PERL_CONTEXT *cx;
2440     I32 oldsave;
2441     OP* redo_op;
2442
2443     if (PL_op->op_flags & OPf_SPECIAL) {
2444         cxix = dopoptoloop(cxstack_ix);
2445         if (cxix < 0)
2446             DIE(aTHX_ "Can't \"redo\" outside a loop block");
2447     }
2448     else {
2449         cxix = dopoptolabel(cPVOP->op_pv);
2450         if (cxix < 0)
2451             DIE(aTHX_ "Label not found for \"redo %s\"", cPVOP->op_pv);
2452     }
2453     if (cxix < cxstack_ix)
2454         dounwind(cxix);
2455
2456     redo_op = cxstack[cxix].blk_loop.my_op->op_redoop;
2457     if (redo_op->op_type == OP_ENTER) {
2458         /* pop one less context to avoid $x being freed in while (my $x..) */
2459         cxstack_ix++;
2460         assert(CxTYPE(&cxstack[cxstack_ix]) == CXt_BLOCK);
2461         redo_op = redo_op->op_next;
2462     }
2463
2464     TOPBLOCK(cx);
2465     oldsave = PL_scopestack[PL_scopestack_ix - 1];
2466     LEAVE_SCOPE(oldsave);
2467     FREETMPS;
2468     PL_curcop = cx->blk_oldcop;
2469     return redo_op;
2470 }
2471
2472 STATIC OP *
2473 S_dofindlabel(pTHX_ OP *o, const char *label, OP **opstack, OP **oplimit)
2474 {
2475     dVAR;
2476     OP **ops = opstack;
2477     static const char too_deep[] = "Target of goto is too deeply nested";
2478
2479     PERL_ARGS_ASSERT_DOFINDLABEL;
2480
2481     if (ops >= oplimit)
2482         Perl_croak(aTHX_ too_deep);
2483     if (o->op_type == OP_LEAVE ||
2484         o->op_type == OP_SCOPE ||
2485         o->op_type == OP_LEAVELOOP ||
2486         o->op_type == OP_LEAVESUB ||
2487         o->op_type == OP_LEAVETRY)
2488     {
2489         *ops++ = cUNOPo->op_first;
2490         if (ops >= oplimit)
2491             Perl_croak(aTHX_ too_deep);
2492     }
2493     *ops = 0;
2494     if (o->op_flags & OPf_KIDS) {
2495         OP *kid;
2496         /* First try all the kids at this level, since that's likeliest. */
2497         for (kid = cUNOPo->op_first; kid; kid = kid->op_sibling) {
2498             if (kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE) {
2499                 const char *kid_label = CopLABEL(kCOP);
2500                 if (kid_label && strEQ(kid_label, label))
2501                     return kid;
2502             }
2503         }
2504         for (kid = cUNOPo->op_first; kid; kid = kid->op_sibling) {
2505             if (kid == PL_lastgotoprobe)
2506                 continue;
2507             if (kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE) {
2508                 if (ops == opstack)
2509                     *ops++ = kid;
2510                 else if (ops[-1]->op_type == OP_NEXTSTATE ||
2511                          ops[-1]->op_type == OP_DBSTATE)
2512                     ops[-1] = kid;
2513                 else
2514                     *ops++ = kid;
2515             }
2516             if ((o = dofindlabel(kid, label, ops, oplimit)))
2517                 return o;
2518         }
2519     }
2520     *ops = 0;
2521     return 0;
2522 }
2523
2524 PP(pp_goto)
2525 {
2526     dVAR; dSP;
2527     OP *retop = NULL;
2528     I32 ix;
2529     register PERL_CONTEXT *cx;
2530 #define GOTO_DEPTH 64
2531     OP *enterops[GOTO_DEPTH];
2532     const char *label = NULL;
2533     const bool do_dump = (PL_op->op_type == OP_DUMP);
2534     static const char must_have_label[] = "goto must have label";
2535
2536     if (PL_op->op_flags & OPf_STACKED) {
2537         SV * const sv = POPs;
2538
2539         /* This egregious kludge implements goto &subroutine */
2540         if (SvROK(sv) && SvTYPE(SvRV(sv)) == SVt_PVCV) {
2541             I32 cxix;
2542             register PERL_CONTEXT *cx;
2543             CV *cv = MUTABLE_CV(SvRV(sv));
2544             SV** mark;
2545             I32 items = 0;
2546             I32 oldsave;
2547             bool reified = 0;
2548
2549         retry:
2550             if (!CvROOT(cv) && !CvXSUB(cv)) {
2551                 const GV * const gv = CvGV(cv);
2552                 if (gv) {
2553                     GV *autogv;
2554                     SV *tmpstr;
2555                     /* autoloaded stub? */
2556                     if (cv != GvCV(gv) && (cv = GvCV(gv)))
2557                         goto retry;
2558                     autogv = gv_autoload4(GvSTASH(gv), GvNAME(gv),
2559                                           GvNAMELEN(gv), FALSE);
2560                     if (autogv && (cv = GvCV(autogv)))
2561                         goto retry;
2562                     tmpstr = sv_newmortal();
2563                     gv_efullname3(tmpstr, gv, NULL);
2564                     DIE(aTHX_ "Goto undefined subroutine &%"SVf"", SVfARG(tmpstr));
2565                 }
2566                 DIE(aTHX_ "Goto undefined subroutine");
2567             }
2568
2569             /* First do some returnish stuff. */
2570             SvREFCNT_inc_simple_void(cv); /* avoid premature free during unwind */
2571             FREETMPS;
2572             cxix = dopoptosub(cxstack_ix);
2573             if (cxix < 0)
2574                 DIE(aTHX_ "Can't goto subroutine outside a subroutine");
2575             if (cxix < cxstack_ix)
2576                 dounwind(cxix);
2577             TOPBLOCK(cx);
2578             SPAGAIN;
2579             /* ban goto in eval: see <20050521150056.GC20213@iabyn.com> */
2580             if (CxTYPE(cx) == CXt_EVAL) {
2581                 if (CxREALEVAL(cx))
2582                     DIE(aTHX_ "Can't goto subroutine from an eval-string");
2583                 else
2584                     DIE(aTHX_ "Can't goto subroutine from an eval-block");
2585             }
2586             else if (CxMULTICALL(cx))
2587                 DIE(aTHX_ "Can't goto subroutine from a sort sub (or similar callback)");
2588             if (CxTYPE(cx) == CXt_SUB && CxHASARGS(cx)) {
2589                 /* put @_ back onto stack */
2590                 AV* av = cx->blk_sub.argarray;
2591
2592                 items = AvFILLp(av) + 1;
2593                 EXTEND(SP, items+1); /* @_ could have been extended. */
2594                 Copy(AvARRAY(av), SP + 1, items, SV*);
2595                 SvREFCNT_dec(GvAV(PL_defgv));
2596                 GvAV(PL_defgv) = cx->blk_sub.savearray;
2597                 CLEAR_ARGARRAY(av);
2598                 /* abandon @_ if it got reified */
2599                 if (AvREAL(av)) {
2600                     reified = 1;
2601                     SvREFCNT_dec(av);
2602                     av = newAV();
2603                     av_extend(av, items-1);
2604                     AvREIFY_only(av);
2605                     PAD_SVl(0) = MUTABLE_SV(cx->blk_sub.argarray = av);
2606                 }
2607             }
2608             else if (CvISXSUB(cv)) {    /* put GvAV(defgv) back onto stack */
2609                 AV* const av = GvAV(PL_defgv);
2610                 items = AvFILLp(av) + 1;
2611                 EXTEND(SP, items+1); /* @_ could have been extended. */
2612                 Copy(AvARRAY(av), SP + 1, items, SV*);
2613             }
2614             mark = SP;
2615             SP += items;
2616             if (CxTYPE(cx) == CXt_SUB &&
2617                 !(CvDEPTH(cx->blk_sub.cv) = cx->blk_sub.olddepth))
2618                 SvREFCNT_dec(cx->blk_sub.cv);
2619             oldsave = PL_scopestack[PL_scopestack_ix - 1];
2620             LEAVE_SCOPE(oldsave);
2621
2622             /* Now do some callish stuff. */
2623             SAVETMPS;
2624             SAVEFREESV(cv); /* later, undo the 'avoid premature free' hack */
2625             if (CvISXSUB(cv)) {
2626                 OP* const retop = cx->blk_sub.retop;
2627                 SV **newsp;
2628                 I32 gimme;
2629                 if (reified) {
2630                     I32 index;
2631                     for (index=0; index<items; index++)
2632                         sv_2mortal(SP[-index]);
2633                 }
2634
2635                 /* XS subs don't have a CxSUB, so pop it */
2636                 POPBLOCK(cx, PL_curpm);
2637                 /* Push a mark for the start of arglist */
2638                 PUSHMARK(mark);
2639                 PUTBACK;
2640                 (void)(*CvXSUB(cv))(aTHX_ cv);
2641                 LEAVE;
2642                 return retop;
2643             }
2644             else {
2645                 AV* const padlist = CvPADLIST(cv);
2646                 if (CxTYPE(cx) == CXt_EVAL) {
2647                     PL_in_eval = CxOLD_IN_EVAL(cx);
2648                     PL_eval_root = cx->blk_eval.old_eval_root;
2649                     cx->cx_type = CXt_SUB;
2650                 }
2651                 cx->blk_sub.cv = cv;
2652                 cx->blk_sub.olddepth = CvDEPTH(cv);
2653
2654                 CvDEPTH(cv)++;
2655                 if (CvDEPTH(cv) < 2)
2656                     SvREFCNT_inc_simple_void_NN(cv);
2657                 else {
2658                     if (CvDEPTH(cv) == PERL_SUB_DEPTH_WARN && ckWARN(WARN_RECURSION))
2659                         sub_crush_depth(cv);
2660                     pad_push(padlist, CvDEPTH(cv));
2661                 }
2662                 SAVECOMPPAD();
2663                 PAD_SET_CUR_NOSAVE(padlist, CvDEPTH(cv));
2664                 if (CxHASARGS(cx))
2665                 {
2666                     AV *const av = MUTABLE_AV(PAD_SVl(0));
2667
2668                     cx->blk_sub.savearray = GvAV(PL_defgv);
2669                     GvAV(PL_defgv) = MUTABLE_AV(SvREFCNT_inc_simple(av));
2670                     CX_CURPAD_SAVE(cx->blk_sub);
2671                     cx->blk_sub.argarray = av;
2672
2673                     if (items >= AvMAX(av) + 1) {
2674                         SV **ary = AvALLOC(av);
2675                         if (AvARRAY(av) != ary) {
2676                             AvMAX(av) += AvARRAY(av) - AvALLOC(av);
2677                             AvARRAY(av) = ary;
2678                         }
2679                         if (items >= AvMAX(av) + 1) {
2680                             AvMAX(av) = items - 1;
2681                             Renew(ary,items+1,SV*);
2682                             AvALLOC(av) = ary;
2683                             AvARRAY(av) = ary;
2684                         }
2685                     }
2686                     ++mark;
2687                     Copy(mark,AvARRAY(av),items,SV*);
2688                     AvFILLp(av) = items - 1;
2689                     assert(!AvREAL(av));
2690                     if (reified) {
2691                         /* transfer 'ownership' of refcnts to new @_ */
2692                         AvREAL_on(av);
2693                         AvREIFY_off(av);
2694                     }
2695                     while (items--) {
2696                         if (*mark)
2697                             SvTEMP_off(*mark);
2698                         mark++;
2699                     }
2700                 }
2701                 if (PERLDB_SUB) {       /* Checking curstash breaks DProf. */
2702                     Perl_get_db_sub(aTHX_ NULL, cv);
2703                     if (PERLDB_GOTO) {
2704                         CV * const gotocv = get_cvs("DB::goto", 0);
2705                         if (gotocv) {
2706                             PUSHMARK( PL_stack_sp );
2707                             call_sv(MUTABLE_SV(gotocv), G_SCALAR | G_NODEBUG);
2708                             PL_stack_sp--;
2709                         }
2710                     }
2711                 }
2712                 RETURNOP(CvSTART(cv));
2713             }
2714         }
2715         else {
2716             label = SvPV_nolen_const(sv);
2717             if (!(do_dump || *label))
2718                 DIE(aTHX_ must_have_label);
2719         }
2720     }
2721     else if (PL_op->op_flags & OPf_SPECIAL) {
2722         if (! do_dump)
2723             DIE(aTHX_ must_have_label);
2724     }
2725     else
2726         label = cPVOP->op_pv;
2727
2728     PERL_ASYNC_CHECK();
2729
2730     if (label && *label) {
2731         OP *gotoprobe = NULL;
2732         bool leaving_eval = FALSE;
2733         bool in_block = FALSE;
2734         PERL_CONTEXT *last_eval_cx = NULL;
2735
2736         /* find label */
2737
2738         PL_lastgotoprobe = NULL;
2739         *enterops = 0;
2740         for (ix = cxstack_ix; ix >= 0; ix--) {
2741             cx = &cxstack[ix];
2742             switch (CxTYPE(cx)) {
2743             case CXt_EVAL:
2744                 leaving_eval = TRUE;
2745                 if (!CxTRYBLOCK(cx)) {
2746                     gotoprobe = (last_eval_cx ?
2747                                 last_eval_cx->blk_eval.old_eval_root :
2748                                 PL_eval_root);
2749                     last_eval_cx = cx;
2750                     break;
2751                 }
2752                 /* else fall through */
2753             case CXt_LOOP_LAZYIV:
2754             case CXt_LOOP_LAZYSV:
2755             case CXt_LOOP_FOR:
2756             case CXt_LOOP_PLAIN:
2757             case CXt_GIVEN:
2758             case CXt_WHEN:
2759                 gotoprobe = cx->blk_oldcop->op_sibling;
2760                 break;
2761             case CXt_SUBST:
2762                 continue;
2763             case CXt_BLOCK:
2764                 if (ix) {
2765                     gotoprobe = cx->blk_oldcop->op_sibling;
2766                     in_block = TRUE;
2767                 } else
2768                     gotoprobe = PL_main_root;
2769                 break;
2770             case CXt_SUB:
2771                 if (CvDEPTH(cx->blk_sub.cv) && !CxMULTICALL(cx)) {
2772                     gotoprobe = CvROOT(cx->blk_sub.cv);
2773                     break;
2774                 }
2775                 /* FALL THROUGH */
2776             case CXt_FORMAT:
2777             case CXt_NULL:
2778                 DIE(aTHX_ "Can't \"goto\" out of a pseudo block");
2779             default:
2780                 if (ix)
2781                     DIE(aTHX_ "panic: goto");
2782                 gotoprobe = PL_main_root;
2783                 break;
2784             }
2785             if (gotoprobe) {
2786                 retop = dofindlabel(gotoprobe, label,
2787                                     enterops, enterops + GOTO_DEPTH);
2788                 if (retop)
2789                     break;
2790                 if (gotoprobe->op_sibling &&
2791                         gotoprobe->op_sibling->op_type == OP_UNSTACK &&
2792                         gotoprobe->op_sibling->op_sibling) {
2793                     retop = dofindlabel(gotoprobe->op_sibling->op_sibling,
2794                                         label, enterops, enterops + GOTO_DEPTH);
2795                     if (retop)
2796                         break;
2797                 }
2798             }
2799             PL_lastgotoprobe = gotoprobe;
2800         }
2801         if (!retop)
2802             DIE(aTHX_ "Can't find label %s", label);
2803
2804         /* if we're leaving an eval, check before we pop any frames
2805            that we're not going to punt, otherwise the error
2806            won't be caught */
2807
2808         if (leaving_eval && *enterops && enterops[1]) {
2809             I32 i;
2810             for (i = 1; enterops[i]; i++)
2811                 if (enterops[i]->op_type == OP_ENTERITER)
2812                     DIE(aTHX_ "Can't \"goto\" into the middle of a foreach loop");
2813         }
2814
2815         if (*enterops && enterops[1]) {
2816             I32 i = enterops[1]->op_type == OP_ENTER && in_block ? 2 : 1;
2817             if (enterops[i])
2818                 deprecate("\"goto\" to jump into a construct");
2819         }
2820
2821         /* pop unwanted frames */
2822
2823         if (ix < cxstack_ix) {
2824             I32 oldsave;
2825
2826             if (ix < 0)
2827                 ix = 0;
2828             dounwind(ix);
2829             TOPBLOCK(cx);
2830             oldsave = PL_scopestack[PL_scopestack_ix];
2831             LEAVE_SCOPE(oldsave);
2832         }
2833
2834         /* push wanted frames */
2835
2836         if (*enterops && enterops[1]) {
2837             OP * const oldop = PL_op;
2838             ix = enterops[1]->op_type == OP_ENTER && in_block ? 2 : 1;
2839             for (; enterops[ix]; ix++) {
2840                 PL_op = enterops[ix];
2841                 /* Eventually we may want to stack the needed arguments
2842                  * for each op.  For now, we punt on the hard ones. */
2843                 if (PL_op->op_type == OP_ENTERITER)
2844                     DIE(aTHX_ "Can't \"goto\" into the middle of a foreach loop");
2845                 PL_op->op_ppaddr(aTHX);
2846             }
2847             PL_op = oldop;
2848         }
2849     }
2850
2851     if (do_dump) {
2852 #ifdef VMS
2853         if (!retop) retop = PL_main_start;
2854 #endif
2855         PL_restartop = retop;
2856         PL_do_undump = TRUE;
2857
2858         my_unexec();
2859
2860         PL_restartop = 0;               /* hmm, must be GNU unexec().. */
2861         PL_do_undump = FALSE;
2862     }
2863
2864     RETURNOP(retop);
2865 }
2866
2867 PP(pp_exit)
2868 {
2869     dVAR;
2870     dSP;
2871     I32 anum;
2872
2873     if (MAXARG < 1)
2874         anum = 0;
2875     else {
2876         anum = SvIVx(POPs);
2877 #ifdef VMS
2878         if (anum == 1 && (PL_op->op_private & OPpEXIT_VMSISH))
2879             anum = 0;
2880         VMSISH_HUSHED  = VMSISH_HUSHED || (PL_op->op_private & OPpHUSH_VMSISH);
2881 #endif
2882     }
2883     PL_exit_flags |= PERL_EXIT_EXPECTED;
2884 #ifdef PERL_MAD
2885     /* KLUDGE: disable exit 0 in BEGIN blocks when we're just compiling */
2886     if (anum || !(PL_minus_c && PL_madskills))
2887         my_exit(anum);
2888 #else
2889     my_exit(anum);
2890 #endif
2891     PUSHs(&PL_sv_undef);
2892     RETURN;
2893 }
2894
2895 /* Eval. */
2896
2897 STATIC void
2898 S_save_lines(pTHX_ AV *array, SV *sv)
2899 {
2900     const char *s = SvPVX_const(sv);
2901     const char * const send = SvPVX_const(sv) + SvCUR(sv);
2902     I32 line = 1;
2903
2904     PERL_ARGS_ASSERT_SAVE_LINES;
2905
2906     while (s && s < send) {
2907         const char *t;
2908         SV * const tmpstr = newSV_type(SVt_PVMG);
2909
2910         t = (const char *)memchr(s, '\n', send - s);
2911         if (t)
2912             t++;
2913         else
2914             t = send;
2915
2916         sv_setpvn(tmpstr, s, t - s);
2917         av_store(array, line++, tmpstr);
2918         s = t;
2919     }
2920 }
2921
2922 /*
2923 =for apidoc docatch
2924
2925 Check for the cases 0 or 3 of cur_env.je_ret, only used inside an eval context.
2926
2927 0 is used as continue inside eval,
2928
2929 3 is used for a die caught by an inner eval - continue inner loop
2930
2931 See cop.h: je_mustcatch, when set at any runlevel to TRUE, means eval ops must
2932 establish a local jmpenv to handle exception traps.
2933
2934 =cut
2935 */
2936 STATIC OP *
2937 S_docatch(pTHX_ OP *o)
2938 {
2939     dVAR;
2940     int ret;
2941     OP * const oldop = PL_op;
2942     dJMPENV;
2943
2944 #ifdef DEBUGGING
2945     assert(CATCH_GET == TRUE);
2946 #endif
2947     PL_op = o;
2948
2949     JMPENV_PUSH(ret);
2950     switch (ret) {
2951     case 0:
2952         assert(cxstack_ix >= 0);
2953         assert(CxTYPE(&cxstack[cxstack_ix]) == CXt_EVAL);
2954         cxstack[cxstack_ix].blk_eval.cur_top_env = PL_top_env;
2955  redo_body:
2956         CALLRUNOPS(aTHX);
2957         break;
2958     case 3:
2959         /* die caught by an inner eval - continue inner loop */
2960         if (PL_restartop && PL_restartjmpenv == PL_top_env) {
2961             PL_restartjmpenv = NULL;
2962             PL_op = PL_restartop;
2963             PL_restartop = 0;
2964             goto redo_body;
2965         }
2966         /* FALL THROUGH */
2967     default:
2968         JMPENV_POP;
2969         PL_op = oldop;
2970         JMPENV_JUMP(ret);
2971         /* NOTREACHED */
2972     }
2973     JMPENV_POP;
2974     PL_op = oldop;
2975     return NULL;
2976 }
2977
2978 /* James Bond: Do you expect me to talk?
2979    Auric Goldfinger: No, Mr. Bond. I expect you to die.
2980
2981    This code is an ugly hack, doesn't work with lexicals in subroutines that are
2982    called more than once, and is only used by regcomp.c, for (?{}) blocks.
2983
2984    Currently it is not used outside the core code. Best if it stays that way.
2985 */
2986 OP *
2987 Perl_sv_compile_2op(pTHX_ SV *sv, OP** startop, const char *code, PAD** padp)
2988 /* sv Text to convert to OP tree. */
2989 /* startop op_free() this to undo. */
2990 /* code Short string id of the caller. */
2991 {
2992     dVAR; dSP;                          /* Make POPBLOCK work. */
2993     PERL_CONTEXT *cx;
2994     SV **newsp;
2995     I32 gimme = G_VOID;
2996     I32 optype;
2997     OP dummy;
2998     char tbuf[TYPE_DIGITS(long) + 12 + 10];
2999     char *tmpbuf = tbuf;
3000     char *safestr;
3001     int runtime;
3002     CV* runcv = NULL;   /* initialise to avoid compiler warnings */
3003     STRLEN len;
3004     bool need_catch;
3005
3006     PERL_ARGS_ASSERT_SV_COMPILE_2OP;
3007
3008     ENTER_with_name("eval");
3009     lex_start(sv, NULL, 0);
3010     SAVETMPS;
3011     /* switch to eval mode */
3012
3013     if (IN_PERL_COMPILETIME) {
3014         SAVECOPSTASH_FREE(&PL_compiling);
3015         CopSTASH_set(&PL_compiling, PL_curstash);
3016     }
3017     if (PERLDB_NAMEEVAL && CopLINE(PL_curcop)) {
3018         SV * const sv = sv_newmortal();
3019         Perl_sv_setpvf(aTHX_ sv, "_<(%.10seval %lu)[%s:%"IVdf"]",
3020                        code, (unsigned long)++PL_evalseq,
3021                        CopFILE(PL_curcop), (IV)CopLINE(PL_curcop));
3022         tmpbuf = SvPVX(sv);
3023         len = SvCUR(sv);
3024     }
3025     else
3026         len = my_snprintf(tmpbuf, sizeof(tbuf), "_<(%.10s_eval %lu)", code,
3027                           (unsigned long)++PL_evalseq);
3028     SAVECOPFILE_FREE(&PL_compiling);
3029     CopFILE_set(&PL_compiling, tmpbuf+2);
3030     SAVECOPLINE(&PL_compiling);
3031     CopLINE_set(&PL_compiling, 1);
3032     /* XXX For C<eval "...">s within BEGIN {} blocks, this ends up
3033        deleting the eval's FILEGV from the stash before gv_check() runs
3034        (i.e. before run-time proper). To work around the coredump that
3035        ensues, we always turn GvMULTI_on for any globals that were
3036        introduced within evals. See force_ident(). GSAR 96-10-12 */
3037     safestr = savepvn(tmpbuf, len);
3038     SAVEDELETE(PL_defstash, safestr, len);
3039     SAVEHINTS();
3040 #ifdef OP_IN_REGISTER
3041     PL_opsave = op;
3042 #else
3043     SAVEVPTR(PL_op);
3044 #endif
3045
3046     /* we get here either during compilation, or via pp_regcomp at runtime */
3047     runtime = IN_PERL_RUNTIME;
3048     if (runtime)
3049         runcv = find_runcv(NULL);
3050
3051     PL_op = &dummy;
3052     PL_op->op_type = OP_ENTEREVAL;
3053     PL_op->op_flags = 0;                        /* Avoid uninit warning. */
3054     PUSHBLOCK(cx, CXt_EVAL|(IN_PERL_COMPILETIME ? 0 : CXp_REAL), SP);
3055     PUSHEVAL(cx, 0);
3056     need_catch = CATCH_GET;
3057     CATCH_SET(TRUE);
3058
3059     if (runtime)
3060         (void) doeval(G_SCALAR, startop, runcv, PL_curcop->cop_seq);
3061     else
3062         (void) doeval(G_SCALAR, startop, PL_compcv, PL_cop_seqmax);
3063     CATCH_SET(need_catch);
3064     POPBLOCK(cx,PL_curpm);
3065     POPEVAL(cx);
3066
3067     (*startop)->op_type = OP_NULL;
3068     (*startop)->op_ppaddr = PL_ppaddr[OP_NULL];
3069     /* XXX DAPM do this properly one year */
3070     *padp = MUTABLE_AV(SvREFCNT_inc_simple(PL_comppad));
3071     LEAVE_with_name("eval");
3072     if (IN_PERL_COMPILETIME)
3073         CopHINTS_set(&PL_compiling, PL_hints);
3074 #ifdef OP_IN_REGISTER
3075     op = PL_opsave;
3076 #endif
3077     PERL_UNUSED_VAR(newsp);
3078     PERL_UNUSED_VAR(optype);
3079
3080     return PL_eval_start;
3081 }
3082
3083
3084 /*
3085 =for apidoc find_runcv
3086
3087 Locate the CV corresponding to the currently executing sub or eval.
3088 If db_seqp is non_null, skip CVs that are in the DB package and populate
3089 *db_seqp with the cop sequence number at the point that the DB:: code was
3090 entered. (allows debuggers to eval in the scope of the breakpoint rather
3091 than in the scope of the debugger itself).
3092
3093 =cut
3094 */
3095
3096 CV*
3097 Perl_find_runcv(pTHX_ U32 *db_seqp)
3098 {
3099     dVAR;
3100     PERL_SI      *si;
3101
3102     if (db_seqp)
3103         *db_seqp = PL_curcop->cop_seq;
3104     for (si = PL_curstackinfo; si; si = si->si_prev) {
3105         I32 ix;
3106         for (ix = si->si_cxix; ix >= 0; ix--) {
3107             const PERL_CONTEXT *cx = &(si->si_cxstack[ix]);
3108             if (CxTYPE(cx) == CXt_SUB || CxTYPE(cx) == CXt_FORMAT) {
3109                 CV * const cv = cx->blk_sub.cv;
3110                 /* skip DB:: code */
3111                 if (db_seqp && PL_debstash && CvSTASH(cv) == PL_debstash) {
3112                     *db_seqp = cx->blk_oldcop->cop_seq;
3113                     continue;
3114                 }
3115                 return cv;
3116             }
3117             else if (CxTYPE(cx) == CXt_EVAL && !CxTRYBLOCK(cx))
3118                 return PL_compcv;
3119         }
3120     }
3121     return PL_main_cv;
3122 }
3123
3124
3125 /* Run yyparse() in a setjmp wrapper. Returns:
3126  *   0: yyparse() successful
3127  *   1: yyparse() failed
3128  *   3: yyparse() died
3129  */
3130 STATIC int
3131 S_try_yyparse(pTHX_ int gramtype)
3132 {
3133     int ret;
3134     dJMPENV;
3135
3136     assert(CxTYPE(&cxstack[cxstack_ix]) == CXt_EVAL);
3137     JMPENV_PUSH(ret);
3138     switch (ret) {
3139     case 0:
3140         ret = yyparse(gramtype) ? 1 : 0;
3141         break;
3142     case 3:
3143         break;
3144     default:
3145         JMPENV_POP;
3146         JMPENV_JUMP(ret);
3147         /* NOTREACHED */
3148     }
3149     JMPENV_POP;
3150     return ret;
3151 }
3152
3153
3154 /* Compile a require/do, an eval '', or a /(?{...})/.
3155  * In the last case, startop is non-null, and contains the address of
3156  * a pointer that should be set to the just-compiled code.
3157  * outside is the lexically enclosing CV (if any) that invoked us.
3158  * Returns a bool indicating whether the compile was successful; if so,
3159  * PL_eval_start contains the first op of the compiled ocde; otherwise,
3160  * pushes undef (also croaks if startop != NULL).
3161  */
3162
3163 STATIC bool
3164 S_doeval(pTHX_ int gimme, OP** startop, CV* outside, U32 seq)
3165 {
3166     dVAR; dSP;
3167     OP * const saveop = PL_op;
3168     bool in_require = (saveop && saveop->op_type == OP_REQUIRE);
3169     int yystatus;
3170
3171     PL_in_eval = (in_require
3172                   ? (EVAL_INREQUIRE | (PL_in_eval & EVAL_INEVAL))
3173                   : EVAL_INEVAL);
3174
3175     PUSHMARK(SP);
3176
3177     SAVESPTR(PL_compcv);
3178     PL_compcv = MUTABLE_CV(newSV_type(SVt_PVCV));
3179     CvEVAL_on(PL_compcv);
3180     assert(CxTYPE(&cxstack[cxstack_ix]) == CXt_EVAL);
3181     cxstack[cxstack_ix].blk_eval.cv = PL_compcv;
3182
3183     CvOUTSIDE_SEQ(PL_compcv) = seq;
3184     CvOUTSIDE(PL_compcv) = MUTABLE_CV(SvREFCNT_inc_simple(outside));
3185
3186     /* set up a scratch pad */
3187
3188     CvPADLIST(PL_compcv) = pad_new(padnew_SAVE);
3189     PL_op = NULL; /* avoid PL_op and PL_curpad referring to different CVs */
3190
3191
3192     if (!PL_madskills)
3193         SAVEMORTALIZESV(PL_compcv);     /* must remain until end of current statement */
3194
3195     /* make sure we compile in the right package */
3196
3197     if (CopSTASH_ne(PL_curcop, PL_curstash)) {
3198         SAVESPTR(PL_curstash);
3199         PL_curstash = CopSTASH(PL_curcop);
3200     }
3201     /* XXX:ajgo do we really need to alloc an AV for begin/checkunit */
3202     SAVESPTR(PL_beginav);
3203     PL_beginav = newAV();
3204     SAVEFREESV(PL_beginav);
3205     SAVESPTR(PL_unitcheckav);
3206     PL_unitcheckav = newAV();
3207     SAVEFREESV(PL_unitcheckav);
3208
3209 #ifdef PERL_MAD
3210     SAVEBOOL(PL_madskills);
3211     PL_madskills = 0;
3212 #endif
3213
3214     /* try to compile it */
3215
3216     PL_eval_root = NULL;
3217     PL_curcop = &PL_compiling;
3218     CopARYBASE_set(PL_curcop, 0);
3219     if (saveop && (saveop->op_type != OP_REQUIRE) && (saveop->op_flags & OPf_SPECIAL))
3220         PL_in_eval |= EVAL_KEEPERR;
3221     else
3222         CLEAR_ERRSV();
3223
3224     CALL_BLOCK_HOOKS(bhk_eval, saveop);
3225
3226     /* note that yyparse() may raise an exception, e.g. C<BEGIN{die}>,
3227      * so honour CATCH_GET and trap it here if necessary */
3228
3229     yystatus = (!in_require && CATCH_GET) ? S_try_yyparse(aTHX_ GRAMPROG) : yyparse(GRAMPROG);
3230
3231     if (yystatus || PL_parser->error_count || !PL_eval_root) {
3232         SV **newsp;                     /* Used by POPBLOCK. */
3233         PERL_CONTEXT *cx = NULL;
3234         I32 optype;                     /* Used by POPEVAL. */
3235         SV *namesv = NULL;
3236         const char *msg;
3237
3238         PERL_UNUSED_VAR(newsp);
3239         PERL_UNUSED_VAR(optype);
3240
3241         /* note that if yystatus == 3, then the EVAL CX block has already
3242          * been popped, and various vars restored */
3243         PL_op = saveop;
3244         if (yystatus != 3) {
3245             if (PL_eval_root) {
3246                 op_free(PL_eval_root);
3247                 PL_eval_root = NULL;
3248             }
3249             SP = PL_stack_base + POPMARK;       /* pop original mark */
3250             if (!startop) {
3251                 POPBLOCK(cx,PL_curpm);
3252                 POPEVAL(cx);
3253                 namesv = cx->blk_eval.old_namesv;
3254             }
3255         }
3256         if (yystatus != 3)
3257             LEAVE_with_name("eval"); /* pp_entereval knows about this LEAVE.  */
3258
3259         msg = SvPVx_nolen_const(ERRSV);
3260         if (in_require) {
3261             if (!cx) {
3262                 /* If cx is still NULL, it means that we didn't go in the
3263                  * POPEVAL branch. */
3264                 cx = &cxstack[cxstack_ix];
3265                 assert(CxTYPE(cx) == CXt_EVAL);
3266                 namesv = cx->blk_eval.old_namesv;
3267             }
3268             (void)hv_store(GvHVn(PL_incgv),
3269                            SvPVX_const(namesv), SvCUR(namesv),
3270                            &PL_sv_undef, 0);
3271             Perl_croak(aTHX_ "%sCompilation failed in require",
3272                        *msg ? msg : "Unknown error\n");
3273         }
3274         else if (startop) {
3275             if (yystatus != 3) {
3276                 POPBLOCK(cx,PL_curpm);
3277                 POPEVAL(cx);
3278             }
3279             Perl_croak(aTHX_ "%sCompilation failed in regexp",
3280                        (*msg ? msg : "Unknown error\n"));
3281         }
3282         else {
3283             if (!*msg) {
3284                 sv_setpvs(ERRSV, "Compilation error");
3285             }
3286         }
3287         PUSHs(&PL_sv_undef);
3288         PUTBACK;
3289         return FALSE;
3290     }
3291     CopLINE_set(&PL_compiling, 0);
3292     if (startop) {
3293         *startop = PL_eval_root;
3294     } else
3295         SAVEFREEOP(PL_eval_root);
3296
3297     /* Set the context for this new optree.
3298      * Propagate the context from the eval(). */
3299     if ((gimme & G_WANT) == G_VOID)
3300         scalarvoid(PL_eval_root);
3301     else if ((gimme & G_WANT) == G_ARRAY)
3302         list(PL_eval_root);
3303     else
3304         scalar(PL_eval_root);
3305
3306     DEBUG_x(dump_eval());
3307
3308     /* Register with debugger: */
3309     if (PERLDB_INTER && saveop && saveop->op_type == OP_REQUIRE) {
3310         CV * const cv = get_cvs("DB::postponed", 0);
3311         if (cv) {
3312             dSP;
3313             PUSHMARK(SP);
3314             XPUSHs(MUTABLE_SV(CopFILEGV(&PL_compiling)));
3315             PUTBACK;
3316             call_sv(MUTABLE_SV(cv), G_DISCARD);
3317         }
3318     }
3319
3320     if (PL_unitcheckav) {
3321         OP *es = PL_eval_start;
3322         call_list(PL_scopestack_ix, PL_unitcheckav);
3323         PL_eval_start = es;
3324     }
3325
3326     /* compiled okay, so do it */
3327
3328     CvDEPTH(PL_compcv) = 1;
3329     SP = PL_stack_base + POPMARK;               /* pop original mark */
3330     PL_op = saveop;                     /* The caller may need it. */
3331     PL_parser->lex_state = LEX_NOTPARSING;      /* $^S needs this. */
3332
3333     PUTBACK;
3334     return TRUE;
3335 }
3336
3337 STATIC PerlIO *
3338 S_check_type_and_open(pTHX_ SV *name)
3339 {
3340     Stat_t st;
3341     const char *p = SvPV_nolen_const(name);
3342     const int st_rc = PerlLIO_stat(p, &st);
3343
3344     PERL_ARGS_ASSERT_CHECK_TYPE_AND_OPEN;
3345
3346     if (st_rc < 0 || S_ISDIR(st.st_mode) || S_ISBLK(st.st_mode)) {
3347         return NULL;
3348     }
3349
3350 #if !defined(PERLIO_IS_STDIO) && !defined(USE_SFIO)
3351     return PerlIO_openn(aTHX_ NULL, PERL_SCRIPT_MODE, -1, 0, 0, NULL, 1, &name);
3352 #else
3353     return PerlIO_open(p, PERL_SCRIPT_MODE);
3354 #endif
3355 }
3356
3357 #ifndef PERL_DISABLE_PMC
3358 STATIC PerlIO *
3359 S_doopen_pm(pTHX_ SV *name)
3360 {
3361     STRLEN namelen;
3362     const char *p = SvPV_const(name, namelen);
3363
3364     PERL_ARGS_ASSERT_DOOPEN_PM;
3365
3366     if (namelen > 3 && memEQs(p + namelen - 3, 3, ".pm")) {
3367         SV *const pmcsv = sv_mortalcopy(name);
3368         Stat_t pmcstat;
3369
3370         sv_catpvn(pmcsv, "c", 1);
3371
3372         if (PerlLIO_stat(SvPV_nolen_const(pmcsv), &pmcstat) >= 0)
3373             return check_type_and_open(pmcsv);
3374     }
3375     return check_type_and_open(name);
3376 }
3377 #else
3378 #  define doopen_pm(name) check_type_and_open(name)
3379 #endif /* !PERL_DISABLE_PMC */
3380
3381 PP(pp_require)
3382 {
3383     dVAR; dSP;
3384     register PERL_CONTEXT *cx;
3385     SV *sv;
3386     const char *name;
3387     STRLEN len;
3388     char * unixname;
3389     STRLEN unixlen;
3390 #ifdef VMS
3391     int vms_unixname = 0;
3392 #endif
3393     const char *tryname = NULL;
3394     SV *namesv = NULL;
3395     const I32 gimme = GIMME_V;
3396     int filter_has_file = 0;
3397     PerlIO *tryrsfp = NULL;
3398     SV *filter_cache = NULL;
3399     SV *filter_state = NULL;
3400     SV *filter_sub = NULL;
3401     SV *hook_sv = NULL;
3402     SV *encoding;
3403     OP *op;
3404
3405     sv = POPs;
3406     if ( (SvNIOKp(sv) || SvVOK(sv)) && PL_op->op_type != OP_DOFILE) {
3407         sv = sv_2mortal(new_version(sv));
3408         if (!sv_derived_from(PL_patchlevel, "version"))
3409             upg_version(PL_patchlevel, TRUE);
3410         if (cUNOP->op_first->op_type == OP_CONST && cUNOP->op_first->op_private & OPpCONST_NOVER) {
3411             if ( vcmp(sv,PL_patchlevel) <= 0 )
3412                 DIE(aTHX_ "Perls since %"SVf" too modern--this is %"SVf", stopped",
3413                     SVfARG(vnormal(sv)), SVfARG(vnormal(PL_patchlevel)));
3414         }
3415         else {
3416             if ( vcmp(sv,PL_patchlevel) > 0 ) {
3417                 I32 first = 0;
3418                 AV *lav;
3419                 SV * const req = SvRV(sv);
3420                 SV * const pv = *hv_fetchs(MUTABLE_HV(req), "original", FALSE);
3421
3422                 /* get the left hand term */
3423                 lav = MUTABLE_AV(SvRV(*hv_fetchs(MUTABLE_HV(req), "version", FALSE)));
3424
3425                 first  = SvIV(*av_fetch(lav,0,0));
3426                 if (   first > (int)PERL_REVISION    /* probably 'use 6.0' */
3427                     || hv_exists(MUTABLE_HV(req), "qv", 2 ) /* qv style */
3428                     || av_len(lav) > 1               /* FP with > 3 digits */
3429                     || strstr(SvPVX(pv),".0")        /* FP with leading 0 */
3430                    ) {
3431                     DIE(aTHX_ "Perl %"SVf" required--this is only "
3432                         "%"SVf", stopped", SVfARG(vnormal(req)),
3433                         SVfARG(vnormal(PL_patchlevel)));
3434                 }
3435                 else { /* probably 'use 5.10' or 'use 5.8' */
3436                     SV *hintsv;
3437                     I32 second = 0;
3438
3439                     if (av_len(lav)>=1)
3440                         second = SvIV(*av_fetch(lav,1,0));
3441
3442                     second /= second >= 600  ? 100 : 10;
3443                     hintsv = Perl_newSVpvf(aTHX_ "v%d.%d.0",
3444                                            (int)first, (int)second);
3445                     upg_version(hintsv, TRUE);
3446
3447                     DIE(aTHX_ "Perl %"SVf" required (did you mean %"SVf"?)"
3448                         "--this is only %"SVf", stopped",
3449                         SVfARG(vnormal(req)),
3450                         SVfARG(vnormal(sv_2mortal(hintsv))),
3451                         SVfARG(vnormal(PL_patchlevel)));
3452                 }
3453             }
3454         }
3455
3456         /* We do this only with "use", not "require" or "no". */
3457         if (PL_compcv && !(cUNOP->op_first->op_private & OPpCONST_NOVER)) {
3458             /* If we request a version >= 5.9.5, load feature.pm with the
3459              * feature bundle that corresponds to the required version. */
3460             if (vcmp(sv, sv_2mortal(upg_version(newSVnv(5.009005), FALSE))) >= 0) {
3461                 SV *const importsv = vnormal(sv);
3462                 *SvPVX_mutable(importsv) = ':';
3463                 ENTER_with_name("load_feature");
3464                 Perl_load_module(aTHX_ 0, newSVpvs("feature"), NULL, importsv, NULL);
3465                 LEAVE_with_name("load_feature");
3466             }
3467             /* If a version >= 5.11.0 is requested, strictures are on by default! */
3468             if (vcmp(sv, sv_2mortal(upg_version(newSVnv(5.011000), FALSE))) >= 0) {
3469                 PL_hints |= (HINT_STRICT_REFS | HINT_STRICT_SUBS | HINT_STRICT_VARS);
3470             }
3471         }
3472
3473         RETPUSHYES;
3474     }
3475     name = SvPV_const(sv, len);
3476     if (!(name && len > 0 && *name))
3477         DIE(aTHX_ "Null filename used");
3478     TAINT_PROPER("require");
3479
3480
3481 #ifdef VMS
3482     /* The key in the %ENV hash is in the syntax of file passed as the argument
3483      * usually this is in UNIX format, but sometimes in VMS format, which
3484      * can result in a module being pulled in more than once.
3485      * To prevent this, the key must be stored in UNIX format if the VMS
3486      * name can be translated to UNIX.
3487      */
3488     if ((unixname = tounixspec(name, NULL)) != NULL) {
3489         unixlen = strlen(unixname);
3490         vms_unixname = 1;
3491     }
3492     else
3493 #endif
3494     {
3495         /* if not VMS or VMS name can not be translated to UNIX, pass it
3496          * through.
3497          */
3498         unixname = (char *) name;
3499         unixlen = len;
3500     }
3501     if (PL_op->op_type == OP_REQUIRE) {
3502         SV * const * const svp = hv_fetch(GvHVn(PL_incgv),
3503                                           unixname, unixlen, 0);
3504         if ( svp ) {
3505             if (*svp != &PL_sv_undef)
3506                 RETPUSHYES;
3507             else
3508                 DIE(aTHX_ "Attempt to reload %s aborted.\n"
3509                             "Compilation failed in require", unixname);
3510         }
3511     }
3512
3513     /* prepare to compile file */
3514
3515     if (path_is_absolute(name)) {
3516         /* At this point, name is SvPVX(sv)  */
3517         tryname = name;
3518         tryrsfp = doopen_pm(sv);
3519     }
3520     if (!tryrsfp) {
3521         AV * const ar = GvAVn(PL_incgv);
3522         I32 i;
3523 #ifdef VMS
3524         if (vms_unixname)
3525 #endif
3526         {
3527             namesv = newSV_type(SVt_PV);
3528             for (i = 0; i <= AvFILL(ar); i++) {
3529                 SV * const dirsv = *av_fetch(ar, i, TRUE);
3530
3531                 if (SvTIED_mg((const SV *)ar, PERL_MAGIC_tied))
3532                     mg_get(dirsv);
3533                 if (SvROK(dirsv)) {
3534                     int count;
3535                     SV **svp;
3536                     SV *loader = dirsv;
3537
3538                     if (SvTYPE(SvRV(loader)) == SVt_PVAV
3539                         && !sv_isobject(loader))
3540                     {
3541                         loader = *av_fetch(MUTABLE_AV(SvRV(loader)), 0, TRUE);
3542                     }
3543
3544                     Perl_sv_setpvf(aTHX_ namesv, "/loader/0x%"UVxf"/%s",
3545                                    PTR2UV(SvRV(dirsv)), name);
3546                     tryname = SvPVX_const(namesv);
3547                     tryrsfp = NULL;
3548
3549                     ENTER_with_name("call_INC");
3550                     SAVETMPS;
3551                     EXTEND(SP, 2);
3552
3553                     PUSHMARK(SP);
3554                     PUSHs(dirsv);
3555                     PUSHs(sv);
3556                     PUTBACK;
3557                     if (sv_isobject(loader))
3558                         count = call_method("INC", G_ARRAY);
3559                     else
3560                         count = call_sv(loader, G_ARRAY);
3561                     SPAGAIN;
3562
3563                     if (count > 0) {
3564                         int i = 0;
3565                         SV *arg;
3566
3567                         SP -= count - 1;
3568                         arg = SP[i++];
3569
3570                         if (SvROK(arg) && (SvTYPE(SvRV(arg)) <= SVt_PVLV)
3571                             && !isGV_with_GP(SvRV(arg))) {
3572                             filter_cache = SvRV(arg);
3573                             SvREFCNT_inc_simple_void_NN(filter_cache);
3574
3575                             if (i < count) {
3576                                 arg = SP[i++];
3577                             }
3578                         }
3579
3580                         if (SvROK(arg) && isGV_with_GP(SvRV(arg))) {
3581                             arg = SvRV(arg);
3582                         }
3583
3584                         if (isGV_with_GP(arg)) {
3585                             IO * const io = GvIO((const GV *)arg);
3586
3587                             ++filter_has_file;
3588
3589                             if (io) {
3590                                 tryrsfp = IoIFP(io);
3591                                 if (IoOFP(io) && IoOFP(io) != IoIFP(io)) {
3592                                     PerlIO_close(IoOFP(io));
3593                                 }
3594                                 IoIFP(io) = NULL;
3595                                 IoOFP(io) = NULL;
3596                             }
3597
3598                             if (i < count) {
3599                                 arg = SP[i++];
3600                             }
3601                         }
3602
3603                         if (SvROK(arg) && SvTYPE(SvRV(arg)) == SVt_PVCV) {
3604                             filter_sub = arg;
3605                             SvREFCNT_inc_simple_void_NN(filter_sub);
3606
3607                             if (i < count) {
3608                                 filter_state = SP[i];
3609                                 SvREFCNT_inc_simple_void(filter_state);
3610                             }
3611                         }
3612
3613                         if (!tryrsfp && (filter_cache || filter_sub)) {
3614                             tryrsfp = PerlIO_open(BIT_BUCKET,
3615                                                   PERL_SCRIPT_MODE);
3616                         }
3617                         SP--;
3618                     }
3619
3620                     PUTBACK;
3621                     FREETMPS;
3622                     LEAVE_with_name("call_INC");
3623
3624                     /* Adjust file name if the hook has set an %INC entry.
3625                        This needs to happen after the FREETMPS above.  */
3626                     svp = hv_fetch(GvHVn(PL_incgv), name, len, 0);
3627                     if (svp)
3628                         tryname = SvPV_nolen_const(*svp);
3629
3630                     if (tryrsfp) {
3631                         hook_sv = dirsv;
3632                         break;
3633                     }
3634
3635                     filter_has_file = 0;
3636                     if (filter_cache) {
3637                         SvREFCNT_dec(filter_cache);
3638                         filter_cache = NULL;
3639                     }
3640                     if (filter_state) {
3641                         SvREFCNT_dec(filter_state);
3642                         filter_state = NULL;
3643                     }
3644                     if (filter_sub) {
3645                         SvREFCNT_dec(filter_sub);
3646                         filter_sub = NULL;
3647                     }
3648                 }
3649                 else {
3650                   if (!path_is_absolute(name)
3651                   ) {
3652                     const char *dir;
3653                     STRLEN dirlen;
3654
3655                     if (SvOK(dirsv)) {
3656                         dir = SvPV_const(dirsv, dirlen);
3657                     } else {
3658                         dir = "";
3659                         dirlen = 0;
3660                     }
3661
3662 #ifdef VMS
3663                     char *unixdir;
3664                     if ((unixdir = tounixpath(dir, NULL)) == NULL)
3665                         continue;
3666                     sv_setpv(namesv, unixdir);
3667                     sv_catpv(namesv, unixname);
3668 #else
3669 #  ifdef __SYMBIAN32__
3670                     if (PL_origfilename[0] &&
3671                         PL_origfilename[1] == ':' &&
3672                         !(dir[0] && dir[1] == ':'))
3673                         Perl_sv_setpvf(aTHX_ namesv,
3674                                        "%c:%s\\%s",
3675                                        PL_origfilename[0],
3676                                        dir, name);
3677                     else
3678                         Perl_sv_setpvf(aTHX_ namesv,
3679                                        "%s\\%s",
3680                                        dir, name);
3681 #  else
3682                     /* The equivalent of
3683                        Perl_sv_setpvf(aTHX_ namesv, "%s/%s", dir, name);
3684                        but without the need to parse the format string, or
3685                        call strlen on either pointer, and with the correct
3686                        allocation up front.  */
3687                     {
3688                         char *tmp = SvGROW(namesv, dirlen + len + 2);
3689
3690                         memcpy(tmp, dir, dirlen);
3691                         tmp +=dirlen;
3692                         *tmp++ = '/';
3693                         /* name came from an SV, so it will have a '\0' at the
3694                            end that we can copy as part of this memcpy().  */
3695                         memcpy(tmp, name, len + 1);
3696
3697                         SvCUR_set(namesv, dirlen + len + 1);
3698                         SvPOK_on(namesv);
3699                     }
3700 #  endif
3701 #endif
3702                     TAINT_PROPER("require");
3703                     tryname = SvPVX_const(namesv);
3704                     tryrsfp = doopen_pm(namesv);
3705                     if (tryrsfp) {
3706                         if (tryname[0] == '.' && tryname[1] == '/') {
3707                             ++tryname;
3708                             while (*++tryname == '/');
3709                         }
3710                         break;
3711                     }
3712                     else if (errno == EMFILE)
3713                         /* no point in trying other paths if out of handles */
3714                         break;
3715                   }
3716                 }
3717             }
3718         }
3719     }
3720     if (tryrsfp) {
3721         SAVECOPFILE_FREE(&PL_compiling);
3722         CopFILE_set(&PL_compiling, tryname);
3723     }
3724     SvREFCNT_dec(namesv);
3725     if (!tryrsfp) {
3726         if (PL_op->op_type == OP_REQUIRE) {
3727             if(errno == EMFILE) {
3728                 /* diag_listed_as: Can't locate %s */
3729                 DIE(aTHX_ "Can't locate %s:   %s", name, Strerror(errno));
3730             } else {
3731                 if (namesv) {                   /* did we lookup @INC? */
3732                     AV * const ar = GvAVn(PL_incgv);
3733                     I32 i;
3734                     SV *const inc = newSVpvs_flags("", SVs_TEMP);
3735                     for (i = 0; i <= AvFILL(ar); i++) {
3736                         sv_catpvs(inc, " ");
3737                         sv_catsv(inc, *av_fetch(ar, i, TRUE));
3738                     }
3739
3740                     /* diag_listed_as: Can't locate %s */
3741                     DIE(aTHX_
3742                         "Can't locate %s in @INC%s%s (@INC contains:%" SVf ")",
3743                         name,
3744                         (memEQ(name + len - 2, ".h", 3)
3745                          ? " (change .h to .ph maybe?) (did you run h2ph?)" : ""),
3746                         (memEQ(name + len - 3, ".ph", 4)
3747                          ? " (did you run h2ph?)" : ""),
3748                         inc
3749                         );
3750                 }
3751             }
3752             DIE(aTHX_ "Can't locate %s", name);
3753         }
3754
3755         RETPUSHUNDEF;
3756     }
3757     else
3758         SETERRNO(0, SS_NORMAL);
3759
3760     /* Assume success here to prevent recursive requirement. */
3761     /* name is never assigned to again, so len is still strlen(name)  */
3762     /* Check whether a hook in @INC has already filled %INC */
3763     if (!hook_sv) {
3764         (void)hv_store(GvHVn(PL_incgv),
3765                        unixname, unixlen, newSVpv(CopFILE(&PL_compiling),0),0);
3766     } else {
3767         SV** const svp = hv_fetch(GvHVn(PL_incgv), unixname, unixlen, 0);
3768         if (!svp)
3769             (void)hv_store(GvHVn(PL_incgv),
3770                            unixname, unixlen, SvREFCNT_inc_simple(hook_sv), 0 );
3771     }
3772
3773     ENTER_with_name("eval");
3774     SAVETMPS;
3775     lex_start(NULL, tryrsfp, 0);
3776
3777     SAVEHINTS();
3778     PL_hints = 0;
3779     hv_clear(GvHV(PL_hintgv));
3780
3781     SAVECOMPILEWARNINGS();
3782     if (PL_dowarn & G_WARN_ALL_ON)
3783         PL_compiling.cop_warnings = pWARN_ALL ;
3784     else if (PL_dowarn & G_WARN_ALL_OFF)
3785         PL_compiling.cop_warnings = pWARN_NONE ;
3786     else
3787         PL_compiling.cop_warnings = pWARN_STD ;
3788
3789     if (filter_sub || filter_cache) {
3790         /* We can use the SvPV of the filter PVIO itself as our cache, rather
3791            than hanging another SV from it. In turn, filter_add() optionally
3792            takes the SV to use as the filter (or creates a new SV if passed
3793            NULL), so simply pass in whatever value filter_cache has.  */
3794         SV * const datasv = filter_add(S_run_user_filter, filter_cache);
3795         IoLINES(datasv) = filter_has_file;
3796         IoTOP_GV(datasv) = MUTABLE_GV(filter_state);
3797         IoBOTTOM_GV(datasv) = MUTABLE_GV(filter_sub);
3798     }
3799
3800     /* switch to eval mode */
3801     PUSHBLOCK(cx, CXt_EVAL, SP);
3802     PUSHEVAL(cx, name);
3803     cx->blk_eval.retop = PL_op->op_next;
3804
3805     SAVECOPLINE(&PL_compiling);
3806     CopLINE_set(&PL_compiling, 0);
3807
3808     PUTBACK;
3809
3810     /* Store and reset encoding. */
3811     encoding = PL_encoding;
3812     PL_encoding = NULL;
3813
3814     if (doeval(gimme, NULL, NULL, PL_curcop->cop_seq))
3815         op = DOCATCH(PL_eval_start);
3816     else
3817         op = PL_op->op_next;
3818
3819     /* Restore encoding. */
3820     PL_encoding = encoding;
3821
3822     return op;
3823 }
3824
3825 /* This is a op added to hold the hints hash for
3826    pp_entereval. The hash can be modified by the code
3827    being eval'ed, so we return a copy instead. */
3828
3829 PP(pp_hintseval)
3830 {
3831     dVAR;
3832     dSP;
3833     mXPUSHs(MUTABLE_SV(hv_copy_hints_hv(MUTABLE_HV(cSVOP_sv))));
3834     RETURN;
3835 }
3836
3837
3838 PP(pp_entereval)
3839 {
3840     dVAR; dSP;
3841     register PERL_CONTEXT *cx;
3842     SV *sv;
3843     const I32 gimme = GIMME_V;
3844     const U32 was = PL_breakable_sub_gen;
3845     char tbuf[TYPE_DIGITS(long) + 12];
3846     char *tmpbuf = tbuf;
3847     STRLEN len;
3848     CV* runcv;
3849     U32 seq;
3850     HV *saved_hh = NULL;
3851
3852     if (PL_op->op_private & OPpEVAL_HAS_HH) {
3853         saved_hh = MUTABLE_HV(SvREFCNT_inc(POPs));
3854     }
3855     sv = POPs;
3856     if (!SvPOK(sv)) {
3857         /* make sure we've got a plain PV (no overload etc) before testing
3858          * for taint. Making a copy here is probably overkill, but better
3859          * safe than sorry */
3860         STRLEN len;
3861         const char * const p = SvPV_const(sv, len);
3862
3863         sv = newSVpvn_flags(p, len, SVs_TEMP | SvUTF8(sv));
3864     }
3865
3866     TAINT_IF(SvTAINTED(sv));
3867     TAINT_PROPER("eval");
3868
3869     ENTER_with_name("eval");
3870     lex_start(sv, NULL, 0);
3871     SAVETMPS;
3872
3873     /* switch to eval mode */
3874
3875     if (PERLDB_NAMEEVAL && CopLINE(PL_curcop)) {
3876         SV * const temp_sv = sv_newmortal();
3877         Perl_sv_setpvf(aTHX_ temp_sv, "_<(eval %lu)[%s:%"IVdf"]",
3878                        (unsigned long)++PL_evalseq,
3879                        CopFILE(PL_curcop), (IV)CopLINE(PL_curcop));
3880         tmpbuf = SvPVX(temp_sv);
3881         len = SvCUR(temp_sv);
3882     }
3883     else
3884         len = my_snprintf(tmpbuf, sizeof(tbuf), "_<(eval %lu)", (unsigned long)++PL_evalseq);
3885     SAVECOPFILE_FREE(&PL_compiling);
3886     CopFILE_set(&PL_compiling, tmpbuf+2);
3887     SAVECOPLINE(&PL_compiling);
3888     CopLINE_set(&PL_compiling, 1);
3889     /* XXX For C<eval "...">s within BEGIN {} blocks, this ends up
3890        deleting the eval's FILEGV from the stash before gv_check() runs
3891        (i.e. before run-time proper). To work around the coredump that
3892        ensues, we always turn GvMULTI_on for any globals that were
3893        introduced within evals. See force_ident(). GSAR 96-10-12 */
3894     SAVEHINTS();
3895     PL_hints = PL_op->op_targ;
3896     if (saved_hh) {
3897         /* SAVEHINTS created a new HV in PL_hintgv, which we need to GC */
3898         SvREFCNT_dec(GvHV(PL_hintgv));
3899         GvHV(PL_hintgv) = saved_hh;
3900     }
3901     SAVECOMPILEWARNINGS();
3902     PL_compiling.cop_warnings = DUP_WARNINGS(PL_curcop->cop_warnings);
3903     cophh_free(CopHINTHASH_get(&PL_compiling));
3904     if (Perl_fetch_cop_label(aTHX_ PL_curcop, NULL, NULL)) {
3905         /* The label, if present, is the first entry on the chain. So rather
3906            than writing a blank label in front of it (which involves an
3907            allocation), just use the next entry in the chain.  */
3908         PL_compiling.cop_hints_hash
3909             = cophh_copy(PL_curcop->cop_hints_hash->refcounted_he_next);
3910         /* Check the assumption that this removed the label.  */
3911         assert(Perl_fetch_cop_label(aTHX_ &PL_compiling, NULL, NULL) == NULL);
3912     }
3913     else
3914         PL_compiling.cop_hints_hash = cophh_copy(PL_curcop->cop_hints_hash);
3915     /* special case: an eval '' executed within the DB package gets lexically
3916      * placed in the first non-DB CV rather than the current CV - this
3917      * allows the debugger to execute code, find lexicals etc, in the
3918      * scope of the code being debugged. Passing &seq gets find_runcv
3919      * to do the dirty work for us */
3920     runcv = find_runcv(&seq);
3921
3922     PUSHBLOCK(cx, (CXt_EVAL|CXp_REAL), SP);
3923     PUSHEVAL(cx, 0);
3924     cx->blk_eval.retop = PL_op->op_next;
3925
3926     /* prepare to compile string */
3927
3928     if ((PERLDB_LINE || PERLDB_SAVESRC) && PL_curstash != PL_debstash)
3929         save_lines(CopFILEAV(&PL_compiling), PL_parser->linestr);
3930     PUTBACK;
3931
3932     if (doeval(gimme, NULL, runcv, seq)) {
3933         if (was != PL_breakable_sub_gen /* Some subs defined here. */
3934             ? (PERLDB_LINE || PERLDB_SAVESRC)
3935             :  PERLDB_SAVESRC_NOSUBS) {
3936             /* Retain the filegv we created.  */
3937         } else {
3938             char *const safestr = savepvn(tmpbuf, len);
3939             SAVEDELETE(PL_defstash, safestr, len);
3940         }
3941         return DOCATCH(PL_eval_start);
3942     } else {
3943         /* We have already left the scope set up earler thanks to the LEAVE
3944            in doeval().  */
3945         if (was != PL_breakable_sub_gen /* Some subs defined here. */
3946             ? (PERLDB_LINE || PERLDB_SAVESRC)
3947             :  PERLDB_SAVESRC_INVALID) {
3948             /* Retain the filegv we created.  */
3949         } else {
3950             (void)hv_delete(PL_defstash, tmpbuf, len, G_DISCARD);
3951         }
3952         return PL_op->op_next;
3953     }
3954 }
3955
3956 PP(pp_leaveeval)
3957 {
3958     dVAR; dSP;
3959     register SV **mark;
3960     SV **newsp;
3961     PMOP *newpm;
3962     I32 gimme;
3963     register PERL_CONTEXT *cx;
3964     OP *retop;
3965     const U8 save_flags = PL_op -> op_flags;
3966     I32 optype;
3967     SV *namesv;
3968
3969     POPBLOCK(cx,newpm);
3970     POPEVAL(cx);
3971     namesv = cx->blk_eval.old_namesv;
3972     retop = cx->blk_eval.retop;
3973
3974     TAINT_NOT;
3975     if (gimme == G_VOID)
3976         MARK = newsp;
3977     else if (gimme == G_SCALAR) {
3978         MARK = newsp + 1;
3979         if (MARK <= SP) {
3980             if (SvFLAGS(TOPs) & SVs_TEMP)
3981                 *MARK = TOPs;
3982             else
3983                 *MARK = sv_mortalcopy(TOPs);
3984         }
3985         else {
3986             MEXTEND(mark,0);
3987             *MARK = &PL_sv_undef;
3988         }
3989         SP = MARK;
3990     }
3991     else {
3992         /* in case LEAVE wipes old return values */
3993         for (mark = newsp + 1; mark <= SP; mark++) {
3994             if (!(SvFLAGS(*mark) & SVs_TEMP)) {
3995                 *mark = sv_mortalcopy(*mark);
3996                 TAINT_NOT;      /* Each item is independent */
3997             }
3998         }
3999     }
4000     PL_curpm = newpm;   /* Don't pop $1 et al till now */
4001
4002 #ifdef DEBUGGING
4003     assert(CvDEPTH(PL_compcv) == 1);
4004 #endif
4005     CvDEPTH(PL_compcv) = 0;
4006
4007     if (optype == OP_REQUIRE &&
4008         !(gimme == G_SCALAR ? SvTRUE(*SP) : SP > newsp))
4009     {
4010         /* Unassume the success we assumed earlier. */
4011         (void)hv_delete(GvHVn(PL_incgv),
4012                         SvPVX_const(namesv), SvCUR(namesv),
4013                         G_DISCARD);
4014         retop = Perl_die(aTHX_ "%"SVf" did not return a true value",
4015                                SVfARG(namesv));
4016         /* die_unwind() did LEAVE, or we won't be here */
4017     }
4018     else {
4019         LEAVE_with_name("eval");
4020         if (!(save_flags & OPf_SPECIAL)) {
4021             CLEAR_ERRSV();
4022         }
4023     }
4024
4025     RETURNOP(retop);
4026 }
4027
4028 /* Common code for Perl_call_sv and Perl_fold_constants, put here to keep it
4029    close to the related Perl_create_eval_scope.  */
4030 void
4031 Perl_delete_eval_scope(pTHX)
4032 {
4033     SV **newsp;
4034     PMOP *newpm;
4035     I32 gimme;
4036     register PERL_CONTEXT *cx;
4037     I32 optype;
4038
4039     POPBLOCK(cx,newpm);
4040     POPEVAL(cx);
4041     PL_curpm = newpm;
4042     LEAVE_with_name("eval_scope");
4043     PERL_UNUSED_VAR(newsp);
4044     PERL_UNUSED_VAR(gimme);
4045     PERL_UNUSED_VAR(optype);
4046 }
4047
4048 /* Common-ish code salvaged from Perl_call_sv and pp_entertry, because it was
4049    also needed by Perl_fold_constants.  */
4050 PERL_CONTEXT *
4051 Perl_create_eval_scope(pTHX_ U32 flags)
4052 {
4053     PERL_CONTEXT *cx;
4054     const I32 gimme = GIMME_V;
4055
4056     ENTER_with_name("eval_scope");
4057     SAVETMPS;
4058
4059     PUSHBLOCK(cx, (CXt_EVAL|CXp_TRYBLOCK), PL_stack_sp);
4060     PUSHEVAL(cx, 0);
4061
4062     PL_in_eval = EVAL_INEVAL;
4063     if (flags & G_KEEPERR)
4064         PL_in_eval |= EVAL_KEEPERR;
4065     else
4066         CLEAR_ERRSV();
4067     if (flags & G_FAKINGEVAL) {
4068         PL_eval_root = PL_op; /* Only needed so that goto works right. */
4069     }
4070     return cx;
4071 }
4072
4073 PP(pp_entertry)
4074 {
4075     dVAR;
4076     PERL_CONTEXT * const cx = create_eval_scope(0);
4077     cx->blk_eval.retop = cLOGOP->op_other->op_next;
4078     return DOCATCH(PL_op->op_next);
4079 }
4080
4081 PP(pp_leavetry)
4082 {
4083     dVAR; dSP;
4084     SV **newsp;
4085     PMOP *newpm;
4086     I32 gimme;
4087     register PERL_CONTEXT *cx;
4088     I32 optype;
4089
4090     POPBLOCK(cx,newpm);
4091     POPEVAL(cx);
4092     PERL_UNUSED_VAR(optype);
4093
4094     TAINT_NOT;
4095     if (gimme == G_VOID)
4096         SP = newsp;
4097     else if (gimme == G_SCALAR) {
4098         register SV **mark;
4099         MARK = newsp + 1;
4100         if (MARK <= SP) {
4101             if (SvFLAGS(TOPs) & (SVs_PADTMP|SVs_TEMP))
4102                 *MARK = TOPs;
4103             else
4104                 *MARK = sv_mortalcopy(TOPs);
4105         }
4106         else {
4107             MEXTEND(mark,0);
4108             *MARK = &PL_sv_undef;
4109         }
4110         SP = MARK;
4111     }
4112     else {
4113         /* in case LEAVE wipes old return values */
4114         register SV **mark;
4115         for (mark = newsp + 1; mark <= SP; mark++) {
4116             if (!(SvFLAGS(*mark) & (SVs_PADTMP|SVs_TEMP))) {
4117                 *mark = sv_mortalcopy(*mark);
4118                 TAINT_NOT;      /* Each item is independent */
4119             }
4120         }
4121     }
4122     PL_curpm = newpm;   /* Don't pop $1 et al till now */
4123
4124     LEAVE_with_name("eval_scope");
4125     CLEAR_ERRSV();
4126     RETURN;
4127 }
4128
4129 PP(pp_entergiven)
4130 {
4131     dVAR; dSP;
4132     register PERL_CONTEXT *cx;
4133     const I32 gimme = GIMME_V;
4134
4135     ENTER_with_name("given");
4136     SAVETMPS;
4137
4138     sv_setsv(PAD_SV(PL_op->op_targ), POPs);
4139
4140     PUSHBLOCK(cx, CXt_GIVEN, SP);
4141     PUSHGIVEN(cx);
4142
4143     RETURN;
4144 }
4145
4146 PP(pp_leavegiven)
4147 {
4148     dVAR; dSP;
4149     register PERL_CONTEXT *cx;
4150     I32 gimme;
4151     SV **newsp;
4152     PMOP *newpm;
4153     PERL_UNUSED_CONTEXT;
4154
4155     POPBLOCK(cx,newpm);
4156     assert(CxTYPE(cx) == CXt_GIVEN);
4157
4158     TAINT_NOT;
4159     if (gimme == G_VOID)
4160         SP = newsp;
4161     else if (gimme == G_SCALAR) {
4162         register SV **mark;
4163         MARK = newsp + 1;
4164         if (MARK <= SP) {
4165             if (SvFLAGS(TOPs) & (SVs_PADTMP|SVs_TEMP))
4166                 *MARK = TOPs;
4167             else
4168                 *MARK = sv_mortalcopy(TOPs);
4169         }
4170         else {
4171             MEXTEND(mark,0);
4172             *MARK = &PL_sv_undef;
4173         }
4174         SP = MARK;
4175     }
4176     else {
4177         /* in case LEAVE wipes old return values */
4178         register SV **mark;
4179         for (mark = newsp + 1; mark <= SP; mark++) {
4180             if (!(SvFLAGS(*mark) & (SVs_PADTMP|SVs_TEMP))) {
4181                 *mark = sv_mortalcopy(*mark);
4182                 TAINT_NOT;      /* Each item is independent */
4183             }
4184         }
4185     }
4186     PL_curpm = newpm;   /* Don't pop $1 et al till now */
4187
4188     LEAVE_with_name("given");
4189     RETURN;
4190 }
4191
4192 /* Helper routines used by pp_smartmatch */
4193 STATIC PMOP *
4194 S_make_matcher(pTHX_ REGEXP *re)
4195 {
4196     dVAR;
4197     PMOP *matcher = (PMOP *) newPMOP(OP_MATCH, OPf_WANT_SCALAR | OPf_STACKED);
4198
4199     PERL_ARGS_ASSERT_MAKE_MATCHER;
4200
4201     PM_SETRE(matcher, ReREFCNT_inc(re));
4202
4203     SAVEFREEOP((OP *) matcher);
4204     ENTER_with_name("matcher"); SAVETMPS;
4205     SAVEOP();
4206     return matcher;
4207 }
4208
4209 STATIC bool
4210 S_matcher_matches_sv(pTHX_ PMOP *matcher, SV *sv)
4211 {
4212     dVAR;
4213     dSP;
4214
4215     PERL_ARGS_ASSERT_MATCHER_MATCHES_SV;
4216
4217     PL_op = (OP *) matcher;
4218     XPUSHs(sv);
4219     PUTBACK;
4220     (void) pp_match();
4221     SPAGAIN;
4222     return (SvTRUEx(POPs));
4223 }
4224
4225 STATIC void
4226 S_destroy_matcher(pTHX_ PMOP *matcher)
4227 {
4228     dVAR;
4229
4230     PERL_ARGS_ASSERT_DESTROY_MATCHER;
4231     PERL_UNUSED_ARG(matcher);
4232
4233     FREETMPS;
4234     LEAVE_with_name("matcher");
4235 }
4236
4237 /* Do a smart match */
4238 PP(pp_smartmatch)
4239 {
4240     DEBUG_M(Perl_deb(aTHX_ "Starting smart match resolution\n"));
4241     return do_smartmatch(NULL, NULL);
4242 }
4243
4244 /* This version of do_smartmatch() implements the
4245  * table of smart matches that is found in perlsyn.
4246  */
4247 STATIC OP *
4248 S_do_smartmatch(pTHX_ HV *seen_this, HV *seen_other)
4249 {
4250     dVAR;
4251     dSP;
4252
4253     bool object_on_left = FALSE;
4254     SV *e = TOPs;       /* e is for 'expression' */
4255     SV *d = TOPm1s;     /* d is for 'default', as in PL_defgv */
4256
4257     /* Take care only to invoke mg_get() once for each argument.
4258      * Currently we do this by copying the SV if it's magical. */
4259     if (d) {
4260         if (SvGMAGICAL(d))
4261             d = sv_mortalcopy(d);
4262     }
4263     else
4264         d = &PL_sv_undef;
4265
4266     assert(e);
4267     if (SvGMAGICAL(e))
4268         e = sv_mortalcopy(e);
4269
4270     /* First of all, handle overload magic of the rightmost argument */
4271     if (SvAMAGIC(e)) {
4272         SV * tmpsv;
4273         DEBUG_M(Perl_deb(aTHX_ "    applying rule Any-Object\n"));
4274         DEBUG_M(Perl_deb(aTHX_ "        attempting overload\n"));
4275
4276         tmpsv = amagic_call(d, e, smart_amg, 0);
4277         if (tmpsv) {
4278             SPAGAIN;
4279             (void)POPs;
4280             SETs(tmpsv);
4281             RETURN;
4282         }
4283         DEBUG_M(Perl_deb(aTHX_ "        failed to run overload method; continuing...\n"));
4284     }
4285
4286     SP -= 2;    /* Pop the values */
4287
4288
4289     /* ~~ undef */
4290     if (!SvOK(e)) {
4291         DEBUG_M(Perl_deb(aTHX_ "    applying rule Any-undef\n"));
4292         if (SvOK(d))
4293             RETPUSHNO;
4294         else
4295             RETPUSHYES;
4296     }
4297
4298     if (sv_isobject(e) && (SvTYPE(SvRV(e)) != SVt_REGEXP)) {
4299         DEBUG_M(Perl_deb(aTHX_ "    applying rule Any-Object\n"));
4300         Perl_croak(aTHX_ "Smart matching a non-overloaded object breaks encapsulation");
4301     }
4302     if (sv_isobject(d) && (SvTYPE(SvRV(d)) != SVt_REGEXP))
4303         object_on_left = TRUE;
4304
4305     /* ~~ sub */
4306     if (SvROK(e) && SvTYPE(SvRV(e)) == SVt_PVCV) {
4307         I32 c;
4308         if (object_on_left) {
4309             goto sm_any_sub; /* Treat objects like scalars */
4310         }
4311         else if (SvROK(d) && SvTYPE(SvRV(d)) == SVt_PVHV) {
4312             /* Test sub truth for each key */
4313             HE *he;
4314             bool andedresults = TRUE;
4315             HV *hv = (HV*) SvRV(d);
4316             I32 numkeys = hv_iterinit(hv);
4317             DEBUG_M(Perl_deb(aTHX_ "    applying rule Hash-CodeRef\n"));
4318             if (numkeys == 0)
4319                 RETPUSHYES;
4320             while ( (he = hv_iternext(hv)) ) {
4321                 DEBUG_M(Perl_deb(aTHX_ "        testing hash key...\n"));
4322                 ENTER_with_name("smartmatch_hash_key_test");
4323                 SAVETMPS;
4324                 PUSHMARK(SP);
4325                 PUSHs(hv_iterkeysv(he));
4326                 PUTBACK;
4327                 c = call_sv(e, G_SCALAR);
4328                 SPAGAIN;
4329                 if (c == 0)
4330                     andedresults = FALSE;
4331                 else
4332                     andedresults = SvTRUEx(POPs) && andedresults;
4333                 FREETMPS;
4334                 LEAVE_with_name("smartmatch_hash_key_test");
4335             }
4336             if (andedresults)
4337                 RETPUSHYES;
4338             else
4339                 RETPUSHNO;
4340         }
4341         else if (SvROK(d) && SvTYPE(SvRV(d)) == SVt_PVAV) {
4342             /* Test sub truth for each element */
4343             I32 i;
4344             bool andedresults = TRUE;
4345             AV *av = (AV*) SvRV(d);
4346             const I32 len = av_len(av);
4347             DEBUG_M(Perl_deb(aTHX_ "    applying rule Array-CodeRef\n"));
4348             if (len == -1)
4349                 RETPUSHYES;
4350             for (i = 0; i <= len; ++i) {
4351                 SV * const * const svp = av_fetch(av, i, FALSE);
4352                 DEBUG_M(Perl_deb(aTHX_ "        testing array element...\n"));
4353                 ENTER_with_name("smartmatch_array_elem_test");
4354                 SAVETMPS;
4355                 PUSHMARK(SP);
4356                 if (svp)
4357                     PUSHs(*svp);
4358                 PUTBACK;
4359                 c = call_sv(e, G_SCALAR);
4360                 SPAGAIN;
4361                 if (c == 0)
4362                     andedresults = FALSE;
4363                 else
4364                     andedresults = SvTRUEx(POPs) && andedresults;
4365                 FREETMPS;
4366                 LEAVE_with_name("smartmatch_array_elem_test");
4367             }
4368             if (andedresults)
4369                 RETPUSHYES;
4370             else
4371                 RETPUSHNO;
4372         }
4373         else {
4374           sm_any_sub:
4375             DEBUG_M(Perl_deb(aTHX_ "    applying rule Any-CodeRef\n"));
4376             ENTER_with_name("smartmatch_coderef");
4377             SAVETMPS;
4378             PUSHMARK(SP);
4379             PUSHs(d);
4380             PUTBACK;
4381             c = call_sv(e, G_SCALAR);
4382             SPAGAIN;
4383             if (c == 0)
4384                 PUSHs(&PL_sv_no);
4385             else if (SvTEMP(TOPs))
4386                 SvREFCNT_inc_void(TOPs);
4387             FREETMPS;
4388             LEAVE_with_name("smartmatch_coderef");
4389             RETURN;
4390         }
4391     }
4392     /* ~~ %hash */
4393     else if (SvROK(e) && SvTYPE(SvRV(e)) == SVt_PVHV) {
4394         if (object_on_left) {
4395             goto sm_any_hash; /* Treat objects like scalars */
4396         }
4397         else if (!SvOK(d)) {
4398             DEBUG_M(Perl_deb(aTHX_ "    applying rule Any-Hash ($a undef)\n"));
4399             RETPUSHNO;
4400         }
4401         else if (SvROK(d) && SvTYPE(SvRV(d)) == SVt_PVHV) {
4402             /* Check that the key-sets are identical */
4403             HE *he;
4404             HV *other_hv = MUTABLE_HV(SvRV(d));
4405             bool tied = FALSE;
4406             bool other_tied = FALSE;
4407             U32 this_key_count  = 0,
4408                 other_key_count = 0;
4409             HV *hv = MUTABLE_HV(SvRV(e));
4410
4411             DEBUG_M(Perl_deb(aTHX_ "    applying rule Hash-Hash\n"));
4412             /* Tied hashes don't know how many keys they have. */
4413             if (SvTIED_mg((SV*)hv, PERL_MAGIC_tied)) {
4414                 tied = TRUE;
4415             }
4416             else if (SvTIED_mg((const SV *)other_hv, PERL_MAGIC_tied)) {
4417                 HV * const temp = other_hv;
4418                 other_hv = hv;
4419                 hv = temp;
4420                 tied = TRUE;
4421             }
4422             if (SvTIED_mg((const SV *)other_hv, PERL_MAGIC_tied))
4423                 other_tied = TRUE;
4424
4425             if (!tied && HvUSEDKEYS((const HV *) hv) != HvUSEDKEYS(other_hv))
4426                 RETPUSHNO;
4427
4428             /* The hashes have the same number of keys, so it suffices
4429                to check that one is a subset of the other. */
4430             (void) hv_iterinit(hv);
4431             while ( (he = hv_iternext(hv)) ) {
4432                 SV *key = hv_iterkeysv(he);
4433
4434                 DEBUG_M(Perl_deb(aTHX_ "        comparing hash key...\n"));
4435                 ++ this_key_count;
4436
4437                 if(!hv_exists_ent(other_hv, key, 0)) {
4438                     (void) hv_iterinit(hv);     /* reset iterator */
4439                     RETPUSHNO;
4440                 }
4441             }
4442
4443             if (other_tied) {
4444                 (void) hv_iterinit(other_hv);
4445                 while ( hv_iternext(other_hv) )
4446                     ++other_key_count;
4447             }
4448             else
4449                 other_key_count = HvUSEDKEYS(other_hv);
4450
4451             if (this_key_count != other_key_count)
4452                 RETPUSHNO;
4453             else
4454                 RETPUSHYES;
4455         }
4456         else if (SvROK(d) && SvTYPE(SvRV(d)) == SVt_PVAV) {
4457             AV * const other_av = MUTABLE_AV(SvRV(d));
4458             const I32 other_len = av_len(other_av) + 1;
4459             I32 i;
4460             HV *hv = MUTABLE_HV(SvRV(e));
4461
4462             DEBUG_M(Perl_deb(aTHX_ "    applying rule Array-Hash\n"));
4463             for (i = 0; i < other_len; ++i) {
4464                 SV ** const svp = av_fetch(other_av, i, FALSE);
4465                 DEBUG_M(Perl_deb(aTHX_ "        checking for key existence...\n"));
4466                 if (svp) {      /* ??? When can this not happen? */
4467                     if (hv_exists_ent(hv, *svp, 0))
4468                         RETPUSHYES;
4469                 }
4470             }
4471             RETPUSHNO;
4472         }
4473         else if (SvROK(d) && SvTYPE(SvRV(d)) == SVt_REGEXP) {
4474             DEBUG_M(Perl_deb(aTHX_ "    applying rule Regex-Hash\n"));
4475           sm_regex_hash:
4476             {
4477                 PMOP * const matcher = make_matcher((REGEXP*) SvRV(d));
4478                 HE *he;
4479                 HV *hv = MUTABLE_HV(SvRV(e));
4480
4481                 (void) hv_iterinit(hv);
4482                 while ( (he = hv_iternext(hv)) ) {
4483                     DEBUG_M(Perl_deb(aTHX_ "        testing key against pattern...\n"));
4484                     if (matcher_matches_sv(matcher, hv_iterkeysv(he))) {
4485                         (void) hv_iterinit(hv);
4486                         destroy_matcher(matcher);
4487                         RETPUSHYES;
4488                     }
4489                 }
4490                 destroy_matcher(matcher);
4491                 RETPUSHNO;
4492             }
4493         }
4494         else {
4495           sm_any_hash:
4496             DEBUG_M(Perl_deb(aTHX_ "    applying rule Any-Hash\n"));
4497             if (hv_exists_ent(MUTABLE_HV(SvRV(e)), d, 0))
4498                 RETPUSHYES;
4499             else
4500                 RETPUSHNO;
4501         }
4502     }
4503     /* ~~ @array */
4504     else if (SvROK(e) && SvTYPE(SvRV(e)) == SVt_PVAV) {
4505         if (object_on_left) {
4506             goto sm_any_array; /* Treat objects like scalars */
4507         }
4508         else if (SvROK(d) && SvTYPE(SvRV(d)) == SVt_PVHV) {
4509             AV * const other_av = MUTABLE_AV(SvRV(e));
4510             const I32 other_len = av_len(other_av) + 1;
4511             I32 i;
4512
4513             DEBUG_M(Perl_deb(aTHX_ "    applying rule Hash-Array\n"));
4514             for (i = 0; i < other_len; ++i) {
4515                 SV ** const svp = av_fetch(other_av, i, FALSE);
4516
4517                 DEBUG_M(Perl_deb(aTHX_ "        testing for key existence...\n"));
4518                 if (svp) {      /* ??? When can this not happen? */
4519                     if (hv_exists_ent(MUTABLE_HV(SvRV(d)), *svp, 0))
4520                         RETPUSHYES;
4521                 }
4522             }
4523             RETPUSHNO;
4524         }
4525         if (SvROK(d) && SvTYPE(SvRV(d)) == SVt_PVAV) {
4526             AV *other_av = MUTABLE_AV(SvRV(d));
4527             DEBUG_M(Perl_deb(aTHX_ "    applying rule Array-Array\n"));
4528             if (av_len(MUTABLE_AV(SvRV(e))) != av_len(other_av))
4529                 RETPUSHNO;
4530             else {
4531                 I32 i;
4532                 const I32 other_len = av_len(other_av);
4533
4534                 if (NULL == seen_this) {
4535                     seen_this = newHV();
4536                     (void) sv_2mortal(MUTABLE_SV(seen_this));
4537                 }
4538                 if (NULL == seen_other) {
4539                     seen_other = newHV();
4540                     (void) sv_2mortal(MUTABLE_SV(seen_other));
4541                 }
4542                 for(i = 0; i <= other_len; ++i) {
4543                     SV * const * const this_elem = av_fetch(MUTABLE_AV(SvRV(e)), i, FALSE);
4544                     SV * const * const other_elem = av_fetch(other_av, i, FALSE);
4545
4546                     if (!this_elem || !other_elem) {
4547                         if ((this_elem && SvOK(*this_elem))
4548                                 || (other_elem && SvOK(*other_elem)))
4549                             RETPUSHNO;
4550                     }
4551                     else if (hv_exists_ent(seen_this,
4552                                 sv_2mortal(newSViv(PTR2IV(*this_elem))), 0) ||
4553                             hv_exists_ent(seen_other,
4554                                 sv_2mortal(newSViv(PTR2IV(*other_elem))), 0))
4555                     {
4556                         if (*this_elem != *other_elem)
4557                             RETPUSHNO;
4558                     }
4559                     else {
4560                         (void)hv_store_ent(seen_this,
4561                                 sv_2mortal(newSViv(PTR2IV(*this_elem))),
4562                                 &PL_sv_undef, 0);
4563                         (void)hv_store_ent(seen_other,
4564                                 sv_2mortal(newSViv(PTR2IV(*other_elem))),
4565                                 &PL_sv_undef, 0);
4566                         PUSHs(*other_elem);
4567                         PUSHs(*this_elem);
4568
4569                         PUTBACK;
4570                         DEBUG_M(Perl_deb(aTHX_ "        recursively comparing array element...\n"));
4571                         (void) do_smartmatch(seen_this, seen_other);
4572                         SPAGAIN;
4573                         DEBUG_M(Perl_deb(aTHX_ "        recursion finished\n"));
4574
4575                         if (!SvTRUEx(POPs))
4576                             RETPUSHNO;
4577                     }
4578                 }
4579                 RETPUSHYES;
4580             }
4581         }
4582         else if (SvROK(d) && SvTYPE(SvRV(d)) == SVt_REGEXP) {
4583             DEBUG_M(Perl_deb(aTHX_ "    applying rule Regex-Array\n"));
4584           sm_regex_array:
4585             {
4586                 PMOP * const matcher = make_matcher((REGEXP*) SvRV(d));
4587                 const I32 this_len = av_len(MUTABLE_AV(SvRV(e)));
4588                 I32 i;
4589
4590                 for(i = 0; i <= this_len; ++i) {
4591                     SV * const * const svp = av_fetch(MUTABLE_AV(SvRV(e)), i, FALSE);
4592                     DEBUG_M(Perl_deb(aTHX_ "        testing element against pattern...\n"));
4593                     if (svp && matcher_matches_sv(matcher, *svp)) {
4594                         destroy_matcher(matcher);
4595                         RETPUSHYES;
4596                     }
4597                 }
4598                 destroy_matcher(matcher);
4599                 RETPUSHNO;
4600             }
4601         }
4602         else if (!SvOK(d)) {
4603             /* undef ~~ array */
4604             const I32 this_len = av_len(MUTABLE_AV(SvRV(e)));
4605             I32 i;
4606
4607             DEBUG_M(Perl_deb(aTHX_ "    applying rule Undef-Array\n"));
4608             for (i = 0; i <= this_len; ++i) {
4609                 SV * const * const svp = av_fetch(MUTABLE_AV(SvRV(e)), i, FALSE);
4610                 DEBUG_M(Perl_deb(aTHX_ "        testing for undef element...\n"));
4611                 if (!svp || !SvOK(*svp))
4612                     RETPUSHYES;
4613             }
4614             RETPUSHNO;
4615         }
4616         else {
4617           sm_any_array:
4618             {
4619                 I32 i;
4620                 const I32 this_len = av_len(MUTABLE_AV(SvRV(e)));
4621
4622                 DEBUG_M(Perl_deb(aTHX_ "    applying rule Any-Array\n"));
4623                 for (i = 0; i <= this_len; ++i) {
4624                     SV * const * const svp = av_fetch(MUTABLE_AV(SvRV(e)), i, FALSE);
4625                     if (!svp)
4626                         continue;
4627
4628                     PUSHs(d);
4629                     PUSHs(*svp);
4630                     PUTBACK;
4631                     /* infinite recursion isn't supposed to happen here */
4632                     DEBUG_M(Perl_deb(aTHX_ "        recursively testing array element...\n"));
4633                     (void) do_smartmatch(NULL, NULL);
4634                     SPAGAIN;
4635                     DEBUG_M(Perl_deb(aTHX_ "        recursion finished\n"));
4636                     if (SvTRUEx(POPs))
4637                         RETPUSHYES;
4638                 }
4639                 RETPUSHNO;
4640             }
4641         }
4642     }
4643     /* ~~ qr// */
4644     else if (SvROK(e) && SvTYPE(SvRV(e)) == SVt_REGEXP) {
4645         if (!object_on_left && SvROK(d) && SvTYPE(SvRV(d)) == SVt_PVHV) {
4646             SV *t = d; d = e; e = t;
4647             DEBUG_M(Perl_deb(aTHX_ "    applying rule Hash-Regex\n"));
4648             goto sm_regex_hash;
4649         }
4650         else if (!object_on_left && SvROK(d) && SvTYPE(SvRV(d)) == SVt_PVAV) {
4651             SV *t = d; d = e; e = t;
4652             DEBUG_M(Perl_deb(aTHX_ "    applying rule Array-Regex\n"));
4653             goto sm_regex_array;
4654         }
4655         else {
4656             PMOP * const matcher = make_matcher((REGEXP*) SvRV(e));
4657
4658             DEBUG_M(Perl_deb(aTHX_ "    applying rule Any-Regex\n"));
4659             PUTBACK;
4660             PUSHs(matcher_matches_sv(matcher, d)
4661                     ? &PL_sv_yes
4662                     : &PL_sv_no);
4663             destroy_matcher(matcher);
4664             RETURN;
4665         }
4666     }
4667     /* ~~ scalar */
4668     /* See if there is overload magic on left */
4669     else if (object_on_left && SvAMAGIC(d)) {
4670         SV *tmpsv;
4671         DEBUG_M(Perl_deb(aTHX_ "    applying rule Object-Any\n"));
4672         DEBUG_M(Perl_deb(aTHX_ "        attempting overload\n"));
4673         PUSHs(d); PUSHs(e);
4674         PUTBACK;
4675         tmpsv = amagic_call(d, e, smart_amg, AMGf_noright);
4676         if (tmpsv) {
4677             SPAGAIN;
4678             (void)POPs;
4679             SETs(tmpsv);
4680             RETURN;
4681         }
4682         SP -= 2;
4683         DEBUG_M(Perl_deb(aTHX_ "        failed to run overload method; falling back...\n"));
4684         goto sm_any_scalar;
4685     }
4686     else if (!SvOK(d)) {
4687         /* undef ~~ scalar ; we already know that the scalar is SvOK */
4688         DEBUG_M(Perl_deb(aTHX_ "    applying rule undef-Any\n"));
4689         RETPUSHNO;
4690     }
4691     else
4692   sm_any_scalar:
4693     if (SvNIOK(e) || (SvPOK(e) && looks_like_number(e) && SvNIOK(d))) {
4694         DEBUG_M(if (SvNIOK(e))
4695                     Perl_deb(aTHX_ "    applying rule Any-Num\n");
4696                 else
4697                     Perl_deb(aTHX_ "    applying rule Num-numish\n");
4698         );
4699         /* numeric comparison */
4700         PUSHs(d); PUSHs(e);
4701         PUTBACK;
4702         if (CopHINTS_get(PL_curcop) & HINT_INTEGER)
4703             (void) pp_i_eq();
4704         else
4705             (void) pp_eq();
4706         SPAGAIN;
4707         if (SvTRUEx(POPs))
4708             RETPUSHYES;
4709         else
4710             RETPUSHNO;
4711     }
4712
4713     /* As a last resort, use string comparison */
4714     DEBUG_M(Perl_deb(aTHX_ "    applying rule Any-Any\n"));
4715     PUSHs(d); PUSHs(e);
4716     PUTBACK;
4717     return pp_seq();
4718 }
4719
4720 PP(pp_enterwhen)
4721 {
4722     dVAR; dSP;
4723     register PERL_CONTEXT *cx;
4724     const I32 gimme = GIMME_V;
4725
4726     /* This is essentially an optimization: if the match
4727        fails, we don't want to push a context and then
4728        pop it again right away, so we skip straight
4729        to the op that follows the leavewhen.
4730        RETURNOP calls PUTBACK which restores the stack pointer after the POPs.
4731     */
4732     if ((0 == (PL_op->op_flags & OPf_SPECIAL)) && !SvTRUEx(POPs))
4733         RETURNOP(cLOGOP->op_other->op_next);
4734
4735     ENTER_with_name("eval");
4736     SAVETMPS;
4737
4738     PUSHBLOCK(cx, CXt_WHEN, SP);
4739     PUSHWHEN(cx);
4740
4741     RETURN;
4742 }
4743
4744 PP(pp_leavewhen)
4745 {
4746     dVAR; dSP;
4747     register PERL_CONTEXT *cx;
4748     I32 gimme;
4749     SV **newsp;
4750     PMOP *newpm;
4751
4752     POPBLOCK(cx,newpm);
4753     assert(CxTYPE(cx) == CXt_WHEN);
4754
4755     SP = newsp;
4756     PUTBACK;
4757
4758     PL_curpm = newpm;   /* pop $1 et al */
4759
4760     LEAVE_with_name("eval");
4761     return NORMAL;
4762 }
4763
4764 PP(pp_continue)
4765 {
4766     dVAR;
4767     I32 cxix;
4768     register PERL_CONTEXT *cx;
4769     I32 inner;
4770
4771     cxix = dopoptowhen(cxstack_ix);
4772     if (cxix < 0)
4773         DIE(aTHX_ "Can't \"continue\" outside a when block");
4774     if (cxix < cxstack_ix)
4775         dounwind(cxix);
4776
4777     /* clear off anything above the scope we're re-entering */
4778     inner = PL_scopestack_ix;
4779     TOPBLOCK(cx);
4780     if (PL_scopestack_ix < inner)
4781         leave_scope(PL_scopestack[PL_scopestack_ix]);
4782     PL_curcop = cx->blk_oldcop;
4783     return cx->blk_givwhen.leave_op;
4784 }
4785
4786 PP(pp_break)
4787 {
4788     dVAR;
4789     I32 cxix;
4790     register PERL_CONTEXT *cx;
4791     I32 inner;
4792     dSP;
4793
4794     cxix = dopoptogiven(cxstack_ix);
4795     if (cxix < 0) {
4796         if (PL_op->op_flags & OPf_SPECIAL)
4797             DIE(aTHX_ "Can't use when() outside a topicalizer");
4798         else
4799             DIE(aTHX_ "Can't \"break\" outside a given block");
4800     }
4801     if (CxFOREACH(&cxstack[cxix]) && (0 == (PL_op->op_flags & OPf_SPECIAL)))
4802         DIE(aTHX_ "Can't \"break\" in a loop topicalizer");
4803
4804     if (cxix < cxstack_ix)
4805         dounwind(cxix);
4806
4807     /* clear off anything above the scope we're re-entering */
4808     inner = PL_scopestack_ix;
4809     TOPBLOCK(cx);
4810     if (PL_scopestack_ix < inner)
4811         leave_scope(PL_scopestack[PL_scopestack_ix]);
4812     PL_curcop = cx->blk_oldcop;
4813
4814     if (CxFOREACH(cx))
4815         return (cx)->blk_loop.my_op->op_nextop;
4816     else
4817         /* RETURNOP calls PUTBACK which restores the old old sp */
4818         RETURNOP(cx->blk_givwhen.leave_op);
4819 }
4820
4821 STATIC OP *
4822 S_doparseform(pTHX_ SV *sv)
4823 {
4824     STRLEN len;
4825     register char *s = SvPV_force(sv, len);
4826     register char * const send = s + len;
4827     register char *base = NULL;
4828     register I32 skipspaces = 0;
4829     bool noblank   = FALSE;
4830     bool repeat    = FALSE;
4831     bool postspace = FALSE;
4832     U32 *fops;
4833     register U32 *fpc;
4834     U32 *linepc = NULL;
4835     register I32 arg;
4836     bool ischop;
4837     bool unchopnum = FALSE;
4838     int maxops = 12; /* FF_LINEMARK + FF_END + 10 (\0 without preceding \n) */
4839
4840     PERL_ARGS_ASSERT_DOPARSEFORM;
4841
4842     if (len == 0)
4843         Perl_croak(aTHX_ "Null picture in formline");
4844
4845     /* estimate the buffer size needed */
4846     for (base = s; s <= send; s++) {
4847         if (*s == '\n' || *s == '@' || *s == '^')
4848             maxops += 10;
4849     }
4850     s = base;
4851     base = NULL;
4852
4853     Newx(fops, maxops, U32);
4854     fpc = fops;
4855
4856     if (s < send) {
4857         linepc = fpc;
4858         *fpc++ = FF_LINEMARK;
4859         noblank = repeat = FALSE;
4860         base = s;
4861     }
4862
4863     while (s <= send) {
4864         switch (*s++) {
4865         default:
4866             skipspaces = 0;
4867             continue;
4868
4869         case '~':
4870             if (*s == '~') {
4871                 repeat = TRUE;
4872                 *s = ' ';
4873             }
4874             noblank = TRUE;
4875             s[-1] = ' ';
4876             /* FALL THROUGH */
4877         case ' ': case '\t':
4878             skipspaces++;
4879             continue;
4880         case 0:
4881             if (s < send) {
4882                 skipspaces = 0;
4883                 continue;
4884             } /* else FALL THROUGH */
4885         case '\n':
4886             arg = s - base;
4887             skipspaces++;
4888             arg -= skipspaces;
4889             if (arg) {
4890                 if (postspace)
4891                     *fpc++ = FF_SPACE;
4892                 *fpc++ = FF_LITERAL;
4893                 *fpc++ = (U16)arg;
4894             }
4895             postspace = FALSE;
4896             if (s <= send)
4897                 skipspaces--;
4898             if (skipspaces) {
4899                 *fpc++ = FF_SKIP;
4900                 *fpc++ = (U16)skipspaces;
4901             }
4902             skipspaces = 0;
4903             if (s <= send)
4904                 *fpc++ = FF_NEWLINE;
4905             if (noblank) {
4906                 *fpc++ = FF_BLANK;
4907                 if (repeat)
4908                     arg = fpc - linepc + 1;
4909                 else
4910                     arg = 0;
4911                 *fpc++ = (U16)arg;
4912             }
4913             if (s < send) {
4914                 linepc = fpc;
4915                 *fpc++ = FF_LINEMARK;
4916                 noblank = repeat = FALSE;
4917                 base = s;
4918             }
4919             else
4920                 s++;
4921             continue;
4922
4923         case '@':
4924         case '^':
4925             ischop = s[-1] == '^';
4926
4927             if (postspace) {
4928                 *fpc++ = FF_SPACE;
4929                 postspace = FALSE;
4930             }
4931             arg = (s - base) - 1;
4932             if (arg) {
4933                 *fpc++ = FF_LITERAL;
4934                 *fpc++ = (U16)arg;
4935             }
4936
4937             base = s - 1;
4938             *fpc++ = FF_FETCH;
4939             if (*s == '*') {
4940                 s++;
4941                 *fpc++ = 2;  /* skip the @* or ^* */
4942                 if (ischop) {
4943                     *fpc++ = FF_LINESNGL;
4944                     *fpc++ = FF_CHOP;
4945                 } else
4946                     *fpc++ = FF_LINEGLOB;
4947             }
4948             else if (*s == '#' || (*s == '.' && s[1] == '#')) {
4949                 arg = ischop ? 512 : 0;
4950                 base = s - 1;
4951                 while (*s == '#')
4952                     s++;
4953                 if (*s == '.') {
4954                     const char * const f = ++s;
4955                     while (*s == '#')
4956                         s++;
4957                     arg |= 256 + (s - f);
4958                 }
4959                 *fpc++ = s - base;              /* fieldsize for FETCH */
4960                 *fpc++ = FF_DECIMAL;
4961                 *fpc++ = (U16)arg;
4962                 unchopnum |= ! ischop;
4963             }
4964             else if (*s == '0' && s[1] == '#') {  /* Zero padded decimals */
4965                 arg = ischop ? 512 : 0;
4966                 base = s - 1;
4967                 s++;                                /* skip the '0' first */
4968                 while (*s == '#')
4969                     s++;
4970                 if (*s == '.') {
4971                     const char * const f = ++s;
4972                     while (*s == '#')
4973                         s++;
4974                     arg |= 256 + (s - f);
4975                 }
4976                 *fpc++ = s - base;                /* fieldsize for FETCH */
4977                 *fpc++ = FF_0DECIMAL;
4978                 *fpc++ = (U16)arg;
4979                 unchopnum |= ! ischop;
4980             }
4981             else {
4982                 I32 prespace = 0;
4983                 bool ismore = FALSE;
4984
4985                 if (*s == '>') {
4986                     while (*++s == '>') ;
4987                     prespace = FF_SPACE;
4988                 }
4989                 else if (*s == '|') {
4990                     while (*++s == '|') ;
4991                     prespace = FF_HALFSPACE;
4992                     postspace = TRUE;
4993                 }
4994                 else {
4995                     if (*s == '<')
4996                         while (*++s == '<') ;
4997                     postspace = TRUE;
4998                 }
4999                 if (*s == '.' && s[1] == '.' && s[2] == '.') {
5000                     s += 3;
5001                     ismore = TRUE;
5002                 }
5003                 *fpc++ = s - base;              /* fieldsize for FETCH */
5004
5005                 *fpc++ = ischop ? FF_CHECKCHOP : FF_CHECKNL;
5006
5007                 if (prespace)
5008                     *fpc++ = (U16)prespace;
5009                 *fpc++ = FF_ITEM;
5010                 if (ismore)
5011                     *fpc++ = FF_MORE;
5012                 if (ischop)
5013                     *fpc++ = FF_CHOP;
5014             }
5015             base = s;
5016             skipspaces = 0;
5017             continue;
5018         }
5019     }
5020     *fpc++ = FF_END;
5021
5022     assert (fpc <= fops + maxops); /* ensure our buffer estimate was valid */
5023     arg = fpc - fops;
5024     { /* need to jump to the next word */
5025         int z;
5026         z = WORD_ALIGN - SvCUR(sv) % WORD_ALIGN;
5027         SvGROW(sv, SvCUR(sv) + z + arg * sizeof(U32) + 4);
5028         s = SvPVX(sv) + SvCUR(sv) + z;
5029     }
5030     Copy(fops, s, arg, U32);
5031     Safefree(fops);
5032     sv_magic(sv, NULL, PERL_MAGIC_fm, NULL, 0);
5033     SvCOMPILED_on(sv);
5034
5035     if (unchopnum && repeat)
5036         DIE(aTHX_ "Repeated format line will never terminate (~~ and @#)");
5037     return 0;
5038 }
5039
5040
5041 STATIC bool
5042 S_num_overflow(NV value, I32 fldsize, I32 frcsize)
5043 {
5044     /* Can value be printed in fldsize chars, using %*.*f ? */
5045     NV pwr = 1;
5046     NV eps = 0.5;
5047     bool res = FALSE;
5048     int intsize = fldsize - (value < 0 ? 1 : 0);
5049
5050     if (frcsize & 256)
5051         intsize--;
5052     frcsize &= 255;
5053     intsize -= frcsize;
5054
5055     while (intsize--) pwr *= 10.0;
5056     while (frcsize--) eps /= 10.0;
5057
5058     if( value >= 0 ){
5059         if (value + eps >= pwr)
5060             res = TRUE;
5061     } else {
5062         if (value - eps <= -pwr)
5063             res = TRUE;
5064     }
5065     return res;
5066 }
5067
5068 static I32
5069 S_run_user_filter(pTHX_ int idx, SV *buf_sv, int maxlen)
5070 {
5071     dVAR;
5072     SV * const datasv = FILTER_DATA(idx);
5073     const int filter_has_file = IoLINES(datasv);
5074     SV * const filter_state = MUTABLE_SV(IoTOP_GV(datasv));
5075     SV * const filter_sub = MUTABLE_SV(IoBOTTOM_GV(datasv));
5076     int status = 0;
5077     SV *upstream;
5078     STRLEN got_len;
5079     char *got_p = NULL;
5080     char *prune_from = NULL;
5081     bool read_from_cache = FALSE;
5082     STRLEN umaxlen;
5083
5084     PERL_ARGS_ASSERT_RUN_USER_FILTER;
5085
5086     assert(maxlen >= 0);
5087     umaxlen = maxlen;
5088
5089     /* I was having segfault trouble under Linux 2.2.5 after a
5090        parse error occured.  (Had to hack around it with a test
5091        for PL_parser->error_count == 0.)  Solaris doesn't segfault --
5092        not sure where the trouble is yet.  XXX */
5093
5094     {
5095         SV *const cache = datasv;
5096         if (SvOK(cache)) {
5097             STRLEN cache_len;
5098             const char *cache_p = SvPV(cache, cache_len);
5099             STRLEN take = 0;
5100
5101             if (umaxlen) {
5102                 /* Running in block mode and we have some cached data already.
5103                  */
5104                 if (cache_len >= umaxlen) {
5105                     /* In fact, so much data we don't even need to call
5106                        filter_read.  */
5107                     take = umaxlen;
5108                 }
5109             } else {
5110                 const char *const first_nl =
5111                     (const char *)memchr(cache_p, '\n', cache_len);
5112                 if (first_nl) {
5113                     take = first_nl + 1 - cache_p;
5114                 }
5115             }
5116             if (take) {
5117                 sv_catpvn(buf_sv, cache_p, take);
5118                 sv_chop(cache, cache_p + take);
5119                 /* Definately not EOF  */
5120                 return 1;
5121             }
5122
5123             sv_catsv(buf_sv, cache);
5124             if (umaxlen) {
5125                 umaxlen -= cache_len;
5126             }
5127             SvOK_off(cache);
5128             read_from_cache = TRUE;
5129         }
5130     }
5131
5132     /* Filter API says that the filter appends to the contents of the buffer.
5133        Usually the buffer is "", so the details don't matter. But if it's not,
5134        then clearly what it contains is already filtered by this filter, so we
5135        don't want to pass it in a second time.
5136        I'm going to use a mortal in case the upstream filter croaks.  */
5137     upstream = ((SvOK(buf_sv) && sv_len(buf_sv)) || SvGMAGICAL(buf_sv))
5138         ? sv_newmortal() : buf_sv;
5139     SvUPGRADE(upstream, SVt_PV);
5140
5141     if (filter_has_file) {
5142         status = FILTER_READ(idx+1, upstream, 0);
5143     }
5144
5145     if (filter_sub && status >= 0) {
5146         dSP;
5147         int count;
5148
5149         ENTER_with_name("call_filter_sub");
5150         SAVE_DEFSV;
5151         SAVETMPS;
5152         EXTEND(SP, 2);
5153
5154         DEFSV_set(upstream);
5155         PUSHMARK(SP);
5156         mPUSHi(0);
5157         if (filter_state) {
5158             PUSHs(filter_state);
5159         }
5160         PUTBACK;
5161         count = call_sv(filter_sub, G_SCALAR);
5162         SPAGAIN;
5163
5164         if (count > 0) {
5165             SV *out = POPs;
5166             if (SvOK(out)) {
5167                 status = SvIV(out);
5168             }
5169         }
5170
5171         PUTBACK;
5172         FREETMPS;
5173         LEAVE_with_name("call_filter_sub");
5174     }
5175
5176     if(SvOK(upstream)) {
5177         got_p = SvPV(upstream, got_len);
5178         if (umaxlen) {
5179             if (got_len > umaxlen) {
5180                 prune_from = got_p + umaxlen;
5181             }
5182         } else {
5183             char *const first_nl = (char *)memchr(got_p, '\n', got_len);
5184             if (first_nl && first_nl + 1 < got_p + got_len) {
5185                 /* There's a second line here... */
5186                 prune_from = first_nl + 1;
5187             }
5188         }
5189     }
5190     if (prune_from) {
5191         /* Oh. Too long. Stuff some in our cache.  */
5192         STRLEN cached_len = got_p + got_len - prune_from;
5193         SV *const cache = datasv;
5194
5195         if (SvOK(cache)) {
5196             /* Cache should be empty.  */
5197             assert(!SvCUR(cache));
5198         }
5199
5200         sv_setpvn(cache, prune_from, cached_len);
5201         /* If you ask for block mode, you may well split UTF-8 characters.
5202            "If it breaks, you get to keep both parts"
5203            (Your code is broken if you  don't put them back together again
5204            before something notices.) */
5205         if (SvUTF8(upstream)) {
5206             SvUTF8_on(cache);
5207         }
5208         SvCUR_set(upstream, got_len - cached_len);
5209         *prune_from = 0;
5210         /* Can't yet be EOF  */
5211         if (status == 0)
5212             status = 1;
5213     }
5214
5215     /* If they are at EOF but buf_sv has something in it, then they may never
5216        have touched the SV upstream, so it may be undefined.  If we naively
5217        concatenate it then we get a warning about use of uninitialised value.
5218     */
5219     if (upstream != buf_sv && (SvOK(upstream) || SvGMAGICAL(upstream))) {
5220         sv_catsv(buf_sv, upstream);
5221     }
5222
5223     if (status <= 0) {
5224         IoLINES(datasv) = 0;
5225         if (filter_state) {
5226             SvREFCNT_dec(filter_state);
5227             IoTOP_GV(datasv) = NULL;
5228         }
5229         if (filter_sub) {
5230             SvREFCNT_dec(filter_sub);
5231             IoBOTTOM_GV(datasv) = NULL;
5232         }
5233         filter_del(S_run_user_filter);
5234     }
5235     if (status == 0 && read_from_cache) {
5236         /* If we read some data from the cache (and by getting here it implies
5237            that we emptied the cache) then we aren't yet at EOF, and mustn't
5238            report that to our caller.  */
5239         return 1;
5240     }
5241     return status;
5242 }
5243
5244 /* perhaps someone can come up with a better name for
5245    this?  it is not really "absolute", per se ... */
5246 static bool
5247 S_path_is_absolute(const char *name)
5248 {
5249     PERL_ARGS_ASSERT_PATH_IS_ABSOLUTE;
5250
5251     if (PERL_FILE_IS_ABSOLUTE(name)
5252 #ifdef WIN32
5253         || (*name == '.' && ((name[1] == '/' ||
5254                              (name[1] == '.' && name[2] == '/'))
5255                          || (name[1] == '\\' ||
5256                              ( name[1] == '.' && name[2] == '\\')))
5257             )
5258 #else
5259         || (*name == '.' && (name[1] == '/' ||
5260                              (name[1] == '.' && name[2] == '/')))
5261 #endif
5262          )
5263     {
5264         return TRUE;
5265     }
5266     else
5267         return FALSE;
5268 }
5269
5270 /*
5271  * Local variables:
5272  * c-indentation-style: bsd
5273  * c-basic-offset: 4
5274  * indent-tabs-mode: t
5275  * End:
5276  *
5277  * ex: set ts=8 sts=4 sw=4 noet:
5278  */