pp_ctl.c

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