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 /*
2835 =for apidoc docatch
2836
2837 Check for the cases 0 or 3 of cur_env.je_ret, only used inside an eval context.
2838
2839 0 is used as continue inside eval,
2840
2841 3 is used for a die caught by an inner eval - continue inner loop
2842
2843 See cop.h: je_mustcatch, when set at any runlevel to TRUE, means eval ops must
2844 establish a local jmpenv to handle exception traps.
2845
2846 =cut
2847 */
2848 STATIC OP *
2849 S_docatch(pTHX_ OP *o)
2850 {
2851     dVAR;
2852     int ret;
2853     OP * const oldop = PL_op;
2854     dJMPENV;
2855
2856 #ifdef DEBUGGING
2857     assert(CATCH_GET == TRUE);
2858 #endif
2859     PL_op = o;
2860
2861     JMPENV_PUSH(ret);
2862     switch (ret) {
2863     case 0:
2864         assert(cxstack_ix >= 0);
2865         assert(CxTYPE(&cxstack[cxstack_ix]) == CXt_EVAL);
2866         cxstack[cxstack_ix].blk_eval.cur_top_env = PL_top_env;
2867  redo_body:
2868         CALLRUNOPS(aTHX);
2869         break;
2870     case 3:
2871         /* die caught by an inner eval - continue inner loop */
2872
2873         /* NB XXX we rely on the old popped CxEVAL still being at the top
2874          * of the stack; the way die_where() currently works, this
2875          * assumption is valid. In theory The cur_top_env value should be
2876          * returned in another global, the way retop (aka PL_restartop)
2877          * is. */
2878         assert(CxTYPE(&cxstack[cxstack_ix+1]) == CXt_EVAL);
2879
2880         if (PL_restartop
2881             && cxstack[cxstack_ix+1].blk_eval.cur_top_env == PL_top_env)
2882         {
2883             PL_op = PL_restartop;
2884             PL_restartop = 0;
2885             goto redo_body;
2886         }
2887         /* FALL THROUGH */
2888     default:
2889         JMPENV_POP;
2890         PL_op = oldop;
2891         JMPENV_JUMP(ret);
2892         /* NOTREACHED */
2893     }
2894     JMPENV_POP;
2895     PL_op = oldop;
2896     return NULL;
2897 }
2898
2899 OP *
2900 Perl_sv_compile_2op(pTHX_ SV *sv, OP** startop, const char *code, PAD** padp)
2901 /* sv Text to convert to OP tree. */
2902 /* startop op_free() this to undo. */
2903 /* code Short string id of the caller. */
2904 {
2905     /* FIXME - how much of this code is common with pp_entereval?  */
2906     dVAR; dSP;                          /* Make POPBLOCK work. */
2907     PERL_CONTEXT *cx;
2908     SV **newsp;
2909     I32 gimme = G_VOID;
2910     I32 optype;
2911     OP dummy;
2912     char tbuf[TYPE_DIGITS(long) + 12 + 10];
2913     char *tmpbuf = tbuf;
2914     char *safestr;
2915     int runtime;
2916     CV* runcv = NULL;   /* initialise to avoid compiler warnings */
2917     STRLEN len;
2918
2919     PERL_ARGS_ASSERT_SV_COMPILE_2OP;
2920
2921     ENTER_with_name("eval");
2922     lex_start(sv, NULL, FALSE);
2923     SAVETMPS;
2924     /* switch to eval mode */
2925
2926     if (IN_PERL_COMPILETIME) {
2927         SAVECOPSTASH_FREE(&PL_compiling);
2928         CopSTASH_set(&PL_compiling, PL_curstash);
2929     }
2930     if (PERLDB_NAMEEVAL && CopLINE(PL_curcop)) {
2931         SV * const sv = sv_newmortal();
2932         Perl_sv_setpvf(aTHX_ sv, "_<(%.10seval %lu)[%s:%"IVdf"]",
2933                        code, (unsigned long)++PL_evalseq,
2934                        CopFILE(PL_curcop), (IV)CopLINE(PL_curcop));
2935         tmpbuf = SvPVX(sv);
2936         len = SvCUR(sv);
2937     }
2938     else
2939         len = my_snprintf(tmpbuf, sizeof(tbuf), "_<(%.10s_eval %lu)", code,
2940                           (unsigned long)++PL_evalseq);
2941     SAVECOPFILE_FREE(&PL_compiling);
2942     CopFILE_set(&PL_compiling, tmpbuf+2);
2943     SAVECOPLINE(&PL_compiling);
2944     CopLINE_set(&PL_compiling, 1);
2945     /* XXX For C<eval "...">s within BEGIN {} blocks, this ends up
2946        deleting the eval's FILEGV from the stash before gv_check() runs
2947        (i.e. before run-time proper). To work around the coredump that
2948        ensues, we always turn GvMULTI_on for any globals that were
2949        introduced within evals. See force_ident(). GSAR 96-10-12 */
2950     safestr = savepvn(tmpbuf, len);
2951     SAVEDELETE(PL_defstash, safestr, len);
2952     SAVEHINTS();
2953 #ifdef OP_IN_REGISTER
2954     PL_opsave = op;
2955 #else
2956     SAVEVPTR(PL_op);
2957 #endif
2958
2959     /* we get here either during compilation, or via pp_regcomp at runtime */
2960     runtime = IN_PERL_RUNTIME;
2961     if (runtime)
2962         runcv = find_runcv(NULL);
2963
2964     PL_op = &dummy;
2965     PL_op->op_type = OP_ENTEREVAL;
2966     PL_op->op_flags = 0;                        /* Avoid uninit warning. */
2967     PUSHBLOCK(cx, CXt_EVAL|(IN_PERL_COMPILETIME ? 0 : CXp_REAL), SP);
2968     PUSHEVAL(cx, 0);
2969
2970     if (runtime)
2971         (void) doeval(G_SCALAR, startop, runcv, PL_curcop->cop_seq);
2972     else
2973         (void) doeval(G_SCALAR, startop, PL_compcv, PL_cop_seqmax);
2974     POPBLOCK(cx,PL_curpm);
2975     POPEVAL(cx);
2976
2977     (*startop)->op_type = OP_NULL;
2978     (*startop)->op_ppaddr = PL_ppaddr[OP_NULL];
2979     lex_end();
2980     /* XXX DAPM do this properly one year */
2981     *padp = MUTABLE_AV(SvREFCNT_inc_simple(PL_comppad));
2982     LEAVE_with_name("eval");
2983     if (IN_PERL_COMPILETIME)
2984         CopHINTS_set(&PL_compiling, PL_hints);
2985 #ifdef OP_IN_REGISTER
2986     op = PL_opsave;
2987 #endif
2988     PERL_UNUSED_VAR(newsp);
2989     PERL_UNUSED_VAR(optype);
2990
2991     return PL_eval_start;
2992 }
2993
2994
2995 /*
2996 =for apidoc find_runcv
2997
2998 Locate the CV corresponding to the currently executing sub or eval.
2999 If db_seqp is non_null, skip CVs that are in the DB package and populate
3000 *db_seqp with the cop sequence number at the point that the DB:: code was
3001 entered. (allows debuggers to eval in the scope of the breakpoint rather
3002 than in the scope of the debugger itself).
3003
3004 =cut
3005 */
3006
3007 CV*
3008 Perl_find_runcv(pTHX_ U32 *db_seqp)
3009 {
3010     dVAR;
3011     PERL_SI      *si;
3012
3013     if (db_seqp)
3014         *db_seqp = PL_curcop->cop_seq;
3015     for (si = PL_curstackinfo; si; si = si->si_prev) {
3016         I32 ix;
3017         for (ix = si->si_cxix; ix >= 0; ix--) {
3018             const PERL_CONTEXT *cx = &(si->si_cxstack[ix]);
3019             if (CxTYPE(cx) == CXt_SUB || CxTYPE(cx) == CXt_FORMAT) {
3020                 CV * const cv = cx->blk_sub.cv;
3021                 /* skip DB:: code */
3022                 if (db_seqp && PL_debstash && CvSTASH(cv) == PL_debstash) {
3023                     *db_seqp = cx->blk_oldcop->cop_seq;
3024                     continue;
3025                 }
3026                 return cv;
3027             }
3028             else if (CxTYPE(cx) == CXt_EVAL && !CxTRYBLOCK(cx))
3029                 return PL_compcv;
3030         }
3031     }
3032     return PL_main_cv;
3033 }
3034
3035
3036 /* Compile a require/do, an eval '', or a /(?{...})/.
3037  * In the last case, startop is non-null, and contains the address of
3038  * a pointer that should be set to the just-compiled code.
3039  * outside is the lexically enclosing CV (if any) that invoked us.
3040  * Returns a bool indicating whether the compile was successful; if so,
3041  * PL_eval_start contains the first op of the compiled ocde; otherwise,
3042  * pushes undef (also croaks if startop != NULL).
3043  */
3044
3045 STATIC bool
3046 S_doeval(pTHX_ int gimme, OP** startop, CV* outside, U32 seq)
3047 {
3048     dVAR; dSP;
3049     OP * const saveop = PL_op;
3050
3051     PL_in_eval = ((saveop && saveop->op_type == OP_REQUIRE)
3052                   ? (EVAL_INREQUIRE | (PL_in_eval & EVAL_INEVAL))
3053                   : EVAL_INEVAL);
3054
3055     PUSHMARK(SP);
3056
3057     SAVESPTR(PL_compcv);
3058     PL_compcv = MUTABLE_CV(newSV_type(SVt_PVCV));
3059     CvEVAL_on(PL_compcv);
3060     assert(CxTYPE(&cxstack[cxstack_ix]) == CXt_EVAL);
3061     cxstack[cxstack_ix].blk_eval.cv = PL_compcv;
3062
3063     CvOUTSIDE_SEQ(PL_compcv) = seq;
3064     CvOUTSIDE(PL_compcv) = MUTABLE_CV(SvREFCNT_inc_simple(outside));
3065
3066     /* set up a scratch pad */
3067
3068     CvPADLIST(PL_compcv) = pad_new(padnew_SAVE);
3069     PL_op = NULL; /* avoid PL_op and PL_curpad referring to different CVs */
3070
3071
3072     if (!PL_madskills)
3073         SAVEMORTALIZESV(PL_compcv);     /* must remain until end of current statement */
3074
3075     /* make sure we compile in the right package */
3076
3077     if (CopSTASH_ne(PL_curcop, PL_curstash)) {
3078         SAVESPTR(PL_curstash);
3079         PL_curstash = CopSTASH(PL_curcop);
3080     }
3081     /* XXX:ajgo do we really need to alloc an AV for begin/checkunit */
3082     SAVESPTR(PL_beginav);
3083     PL_beginav = newAV();
3084     SAVEFREESV(PL_beginav);
3085     SAVESPTR(PL_unitcheckav);
3086     PL_unitcheckav = newAV();
3087     SAVEFREESV(PL_unitcheckav);
3088
3089 #ifdef PERL_MAD
3090     SAVEBOOL(PL_madskills);
3091     PL_madskills = 0;
3092 #endif
3093
3094     /* try to compile it */
3095
3096     PL_eval_root = NULL;
3097     PL_curcop = &PL_compiling;
3098     CopARYBASE_set(PL_curcop, 0);
3099     if (saveop && (saveop->op_type != OP_REQUIRE) && (saveop->op_flags & OPf_SPECIAL))
3100         PL_in_eval |= EVAL_KEEPERR;
3101     else
3102         CLEAR_ERRSV();
3103     if (yyparse() || PL_parser->error_count || !PL_eval_root) {
3104         SV **newsp;                     /* Used by POPBLOCK. */
3105         PERL_CONTEXT *cx = &cxstack[cxstack_ix];
3106         I32 optype = 0;                 /* Might be reset by POPEVAL. */
3107         const char *msg;
3108
3109         PL_op = saveop;
3110         if (PL_eval_root) {
3111             op_free(PL_eval_root);
3112             PL_eval_root = NULL;
3113         }
3114         SP = PL_stack_base + POPMARK;           /* pop original mark */
3115         if (!startop) {
3116             POPBLOCK(cx,PL_curpm);
3117             POPEVAL(cx);
3118         }
3119         lex_end();
3120         LEAVE_with_name("eval"); /* pp_entereval knows about this LEAVE.  */
3121
3122         msg = SvPVx_nolen_const(ERRSV);
3123         if (optype == OP_REQUIRE) {
3124             const SV * const nsv = cx->blk_eval.old_namesv;
3125             (void)hv_store(GvHVn(PL_incgv), SvPVX_const(nsv), SvCUR(nsv),
3126                           &PL_sv_undef, 0);
3127             Perl_croak(aTHX_ "%sCompilation failed in require",
3128                        *msg ? msg : "Unknown error\n");
3129         }
3130         else if (startop) {
3131             POPBLOCK(cx,PL_curpm);
3132             POPEVAL(cx);
3133             Perl_croak(aTHX_ "%sCompilation failed in regexp",
3134                        (*msg ? msg : "Unknown error\n"));
3135         }
3136         else {
3137             if (!*msg) {
3138                 sv_setpvs(ERRSV, "Compilation error");
3139             }
3140         }
3141         PERL_UNUSED_VAR(newsp);
3142         PUSHs(&PL_sv_undef);
3143         PUTBACK;
3144         return FALSE;
3145     }
3146     CopLINE_set(&PL_compiling, 0);
3147     if (startop) {
3148         *startop = PL_eval_root;
3149     } else
3150         SAVEFREEOP(PL_eval_root);
3151
3152     /* Set the context for this new optree.
3153      * Propagate the context from the eval(). */
3154     if ((gimme & G_WANT) == G_VOID)
3155         scalarvoid(PL_eval_root);
3156     else if ((gimme & G_WANT) == G_ARRAY)
3157         list(PL_eval_root);
3158     else
3159         scalar(PL_eval_root);
3160
3161     DEBUG_x(dump_eval());
3162
3163     /* Register with debugger: */
3164     if (PERLDB_INTER && saveop && saveop->op_type == OP_REQUIRE) {
3165         CV * const cv = get_cvs("DB::postponed", 0);
3166         if (cv) {
3167             dSP;
3168             PUSHMARK(SP);
3169             XPUSHs(MUTABLE_SV(CopFILEGV(&PL_compiling)));
3170             PUTBACK;
3171             call_sv(MUTABLE_SV(cv), G_DISCARD);
3172         }
3173     }
3174
3175     if (PL_unitcheckav)
3176         call_list(PL_scopestack_ix, PL_unitcheckav);
3177
3178     /* compiled okay, so do it */
3179
3180     CvDEPTH(PL_compcv) = 1;
3181     SP = PL_stack_base + POPMARK;               /* pop original mark */
3182     PL_op = saveop;                     /* The caller may need it. */
3183     PL_parser->lex_state = LEX_NOTPARSING;      /* $^S needs this. */
3184
3185     PUTBACK;
3186     return TRUE;
3187 }
3188
3189 STATIC PerlIO *
3190 S_check_type_and_open(pTHX_ const char *name)
3191 {
3192     Stat_t st;
3193     const int st_rc = PerlLIO_stat(name, &st);
3194
3195     PERL_ARGS_ASSERT_CHECK_TYPE_AND_OPEN;
3196
3197     if (st_rc < 0 || S_ISDIR(st.st_mode) || S_ISBLK(st.st_mode)) {
3198         return NULL;
3199     }
3200
3201     return PerlIO_open(name, PERL_SCRIPT_MODE);
3202 }
3203
3204 #ifndef PERL_DISABLE_PMC
3205 STATIC PerlIO *
3206 S_doopen_pm(pTHX_ const char *name, const STRLEN namelen)
3207 {
3208     PerlIO *fp;
3209
3210     PERL_ARGS_ASSERT_DOOPEN_PM;
3211
3212     if (namelen > 3 && memEQs(name + namelen - 3, 3, ".pm")) {
3213         SV *const pmcsv = newSV(namelen + 2);
3214         char *const pmc = SvPVX(pmcsv);
3215         Stat_t pmcstat;
3216
3217         memcpy(pmc, name, namelen);
3218         pmc[namelen] = 'c';
3219         pmc[namelen + 1] = '\0';
3220
3221         if (PerlLIO_stat(pmc, &pmcstat) < 0) {
3222             fp = check_type_and_open(name);
3223         }
3224         else {
3225             fp = check_type_and_open(pmc);
3226         }
3227         SvREFCNT_dec(pmcsv);
3228     }
3229     else {
3230         fp = check_type_and_open(name);
3231     }
3232     return fp;
3233 }
3234 #else
3235 #  define doopen_pm(name, namelen) check_type_and_open(name)
3236 #endif /* !PERL_DISABLE_PMC */
3237
3238 PP(pp_require)
3239 {
3240     dVAR; dSP;
3241     register PERL_CONTEXT *cx;
3242     SV *sv;
3243     const char *name;
3244     STRLEN len;
3245     char * unixname;
3246     STRLEN unixlen;
3247 #ifdef VMS
3248     int vms_unixname = 0;
3249 #endif
3250     const char *tryname = NULL;
3251     SV *namesv = NULL;
3252     const I32 gimme = GIMME_V;
3253     int filter_has_file = 0;
3254     PerlIO *tryrsfp = NULL;
3255     SV *filter_cache = NULL;
3256     SV *filter_state = NULL;
3257     SV *filter_sub = NULL;
3258     SV *hook_sv = NULL;
3259     SV *encoding;
3260     OP *op;
3261
3262     sv = POPs;
3263     if ( (SvNIOKp(sv) || SvVOK(sv)) && PL_op->op_type != OP_DOFILE) {
3264         sv = new_version(sv);
3265         if (!sv_derived_from(PL_patchlevel, "version"))
3266             upg_version(PL_patchlevel, TRUE);
3267         if (cUNOP->op_first->op_type == OP_CONST && cUNOP->op_first->op_private & OPpCONST_NOVER) {
3268             if ( vcmp(sv,PL_patchlevel) <= 0 )
3269                 DIE(aTHX_ "Perls since %"SVf" too modern--this is %"SVf", stopped",
3270                     SVfARG(vnormal(sv)), SVfARG(vnormal(PL_patchlevel)));
3271         }
3272         else {
3273             if ( vcmp(sv,PL_patchlevel) > 0 ) {
3274                 I32 first = 0;
3275                 AV *lav;
3276                 SV * const req = SvRV(sv);
3277                 SV * const pv = *hv_fetchs(MUTABLE_HV(req), "original", FALSE);
3278
3279                 /* get the left hand term */
3280                 lav = MUTABLE_AV(SvRV(*hv_fetchs(MUTABLE_HV(req), "version", FALSE)));
3281
3282                 first  = SvIV(*av_fetch(lav,0,0));
3283                 if (   first > (int)PERL_REVISION    /* probably 'use 6.0' */
3284                     || hv_exists(MUTABLE_HV(req), "qv", 2 ) /* qv style */
3285                     || av_len(lav) > 1               /* FP with > 3 digits */
3286                     || strstr(SvPVX(pv),".0")        /* FP with leading 0 */
3287                    ) {
3288                     DIE(aTHX_ "Perl %"SVf" required--this is only "
3289                         "%"SVf", stopped", SVfARG(vnormal(req)),
3290                         SVfARG(vnormal(PL_patchlevel)));
3291                 }
3292                 else { /* probably 'use 5.10' or 'use 5.8' */
3293                     SV *hintsv;
3294                     I32 second = 0;
3295
3296                     if (av_len(lav)>=1)
3297                         second = SvIV(*av_fetch(lav,1,0));
3298
3299                     second /= second >= 600  ? 100 : 10;
3300                     hintsv = Perl_newSVpvf(aTHX_ "v%d.%d.0",
3301                                            (int)first, (int)second);
3302                     upg_version(hintsv, TRUE);
3303
3304                     DIE(aTHX_ "Perl %"SVf" required (did you mean %"SVf"?)"
3305                         "--this is only %"SVf", stopped",
3306                         SVfARG(vnormal(req)),
3307                         SVfARG(vnormal(sv_2mortal(hintsv))),
3308                         SVfARG(vnormal(PL_patchlevel)));
3309                 }
3310             }
3311         }
3312
3313         /* We do this only with use, not require. */
3314         if (PL_compcv &&
3315           /* If we request a version >= 5.9.5, load feature.pm with the
3316            * feature bundle that corresponds to the required version. */
3317                 vcmp(sv, sv_2mortal(upg_version(newSVnv(5.009005), FALSE))) >= 0) {
3318             SV *const importsv = vnormal(sv);
3319             *SvPVX_mutable(importsv) = ':';
3320             ENTER_with_name("load_feature");
3321             Perl_load_module(aTHX_ 0, newSVpvs("feature"), NULL, importsv, NULL);
3322             LEAVE_with_name("load_feature");
3323         }
3324         /* If a version >= 5.11.0 is requested, strictures are on by default! */
3325         if (PL_compcv &&
3326                 vcmp(sv, sv_2mortal(upg_version(newSVnv(5.011000), FALSE))) >= 0) {
3327             PL_hints |= (HINT_STRICT_REFS | HINT_STRICT_SUBS | HINT_STRICT_VARS);
3328         }
3329
3330         RETPUSHYES;
3331     }
3332     name = SvPV_const(sv, len);
3333     if (!(name && len > 0 && *name))
3334         DIE(aTHX_ "Null filename used");
3335     TAINT_PROPER("require");
3336
3337
3338 #ifdef VMS
3339     /* The key in the %ENV hash is in the syntax of file passed as the argument
3340      * usually this is in UNIX format, but sometimes in VMS format, which
3341      * can result in a module being pulled in more than once.
3342      * To prevent this, the key must be stored in UNIX format if the VMS
3343      * name can be translated to UNIX.
3344      */
3345     if ((unixname = tounixspec(name, NULL)) != NULL) {
3346         unixlen = strlen(unixname);
3347         vms_unixname = 1;
3348     }
3349     else
3350 #endif
3351     {
3352         /* if not VMS or VMS name can not be translated to UNIX, pass it
3353          * through.
3354          */
3355         unixname = (char *) name;
3356         unixlen = len;
3357     }
3358     if (PL_op->op_type == OP_REQUIRE) {
3359         SV * const * const svp = hv_fetch(GvHVn(PL_incgv),
3360                                           unixname, unixlen, 0);
3361         if ( svp ) {
3362             if (*svp != &PL_sv_undef)
3363                 RETPUSHYES;
3364             else
3365                 DIE(aTHX_ "Attempt to reload %s aborted.\n"
3366                             "Compilation failed in require", unixname);
3367         }
3368     }
3369
3370     /* prepare to compile file */
3371
3372     if (path_is_absolute(name)) {
3373         tryname = name;
3374         tryrsfp = doopen_pm(name, len);
3375     }
3376     if (!tryrsfp) {
3377         AV * const ar = GvAVn(PL_incgv);
3378         I32 i;
3379 #ifdef VMS
3380         if (vms_unixname)
3381 #endif
3382         {
3383             namesv = newSV_type(SVt_PV);
3384             for (i = 0; i <= AvFILL(ar); i++) {
3385                 SV * const dirsv = *av_fetch(ar, i, TRUE);
3386
3387                 if (SvTIED_mg((const SV *)ar, PERL_MAGIC_tied))
3388                     mg_get(dirsv);
3389                 if (SvROK(dirsv)) {
3390                     int count;
3391                     SV **svp;
3392                     SV *loader = dirsv;
3393
3394                     if (SvTYPE(SvRV(loader)) == SVt_PVAV
3395                         && !sv_isobject(loader))
3396                     {
3397                         loader = *av_fetch(MUTABLE_AV(SvRV(loader)), 0, TRUE);
3398                     }
3399
3400                     Perl_sv_setpvf(aTHX_ namesv, "/loader/0x%"UVxf"/%s",
3401                                    PTR2UV(SvRV(dirsv)), name);
3402                     tryname = SvPVX_const(namesv);
3403                     tryrsfp = NULL;
3404
3405                     ENTER_with_name("call_INC");
3406                     SAVETMPS;
3407                     EXTEND(SP, 2);
3408
3409                     PUSHMARK(SP);
3410                     PUSHs(dirsv);
3411                     PUSHs(sv);
3412                     PUTBACK;
3413                     if (sv_isobject(loader))
3414                         count = call_method("INC", G_ARRAY);
3415                     else
3416                         count = call_sv(loader, G_ARRAY);
3417                     SPAGAIN;
3418
3419                     /* Adjust file name if the hook has set an %INC entry */
3420                     svp = hv_fetch(GvHVn(PL_incgv), name, len, 0);
3421                     if (svp)
3422                         tryname = SvPV_nolen_const(*svp);
3423
3424                     if (count > 0) {
3425                         int i = 0;
3426                         SV *arg;
3427
3428                         SP -= count - 1;
3429                         arg = SP[i++];
3430
3431                         if (SvROK(arg) && (SvTYPE(SvRV(arg)) <= SVt_PVLV)
3432                             && !isGV_with_GP(SvRV(arg))) {
3433                             filter_cache = SvRV(arg);
3434                             SvREFCNT_inc_simple_void_NN(filter_cache);
3435
3436                             if (i < count) {
3437                                 arg = SP[i++];
3438                             }
3439                         }
3440
3441                         if (SvROK(arg) && isGV_with_GP(SvRV(arg))) {
3442                             arg = SvRV(arg);
3443                         }
3444
3445                         if (isGV_with_GP(arg)) {
3446                             IO * const io = GvIO((const GV *)arg);
3447
3448                             ++filter_has_file;
3449
3450                             if (io) {
3451                                 tryrsfp = IoIFP(io);
3452                                 if (IoOFP(io) && IoOFP(io) != IoIFP(io)) {
3453                                     PerlIO_close(IoOFP(io));
3454                                 }
3455                                 IoIFP(io) = NULL;
3456                                 IoOFP(io) = NULL;
3457                             }
3458
3459                             if (i < count) {
3460                                 arg = SP[i++];
3461                             }
3462                         }
3463
3464                         if (SvROK(arg) && SvTYPE(SvRV(arg)) == SVt_PVCV) {
3465                             filter_sub = arg;
3466                             SvREFCNT_inc_simple_void_NN(filter_sub);
3467
3468                             if (i < count) {
3469                                 filter_state = SP[i];
3470                                 SvREFCNT_inc_simple_void(filter_state);
3471                             }
3472                         }
3473
3474                         if (!tryrsfp && (filter_cache || filter_sub)) {
3475                             tryrsfp = PerlIO_open(BIT_BUCKET,
3476                                                   PERL_SCRIPT_MODE);
3477                         }
3478                         SP--;
3479                     }
3480
3481                     PUTBACK;
3482                     FREETMPS;
3483                     LEAVE_with_name("call_INC");
3484
3485                     if (tryrsfp) {
3486                         hook_sv = dirsv;
3487                         break;
3488                     }
3489
3490                     filter_has_file = 0;
3491                     if (filter_cache) {
3492                         SvREFCNT_dec(filter_cache);
3493                         filter_cache = NULL;
3494                     }
3495                     if (filter_state) {
3496                         SvREFCNT_dec(filter_state);
3497                         filter_state = NULL;
3498                     }
3499                     if (filter_sub) {
3500                         SvREFCNT_dec(filter_sub);
3501                         filter_sub = NULL;
3502                     }
3503                 }
3504                 else {
3505                   if (!path_is_absolute(name)
3506                   ) {
3507                     const char *dir;
3508                     STRLEN dirlen;
3509
3510                     if (SvOK(dirsv)) {
3511                         dir = SvPV_const(dirsv, dirlen);
3512                     } else {
3513                         dir = "";
3514                         dirlen = 0;
3515                     }
3516
3517 #ifdef VMS
3518                     char *unixdir;
3519                     if ((unixdir = tounixpath(dir, NULL)) == NULL)
3520                         continue;
3521                     sv_setpv(namesv, unixdir);
3522                     sv_catpv(namesv, unixname);
3523 #else
3524 #  ifdef __SYMBIAN32__
3525                     if (PL_origfilename[0] &&
3526                         PL_origfilename[1] == ':' &&
3527                         !(dir[0] && dir[1] == ':'))
3528                         Perl_sv_setpvf(aTHX_ namesv,
3529                                        "%c:%s\\%s",
3530                                        PL_origfilename[0],
3531                                        dir, name);
3532                     else
3533                         Perl_sv_setpvf(aTHX_ namesv,
3534                                        "%s\\%s",
3535                                        dir, name);
3536 #  else
3537                     /* The equivalent of
3538                        Perl_sv_setpvf(aTHX_ namesv, "%s/%s", dir, name);
3539                        but without the need to parse the format string, or
3540                        call strlen on either pointer, and with the correct
3541                        allocation up front.  */
3542                     {
3543                         char *tmp = SvGROW(namesv, dirlen + len + 2);
3544
3545                         memcpy(tmp, dir, dirlen);
3546                         tmp +=dirlen;
3547                         *tmp++ = '/';
3548                         /* name came from an SV, so it will have a '\0' at the
3549                            end that we can copy as part of this memcpy().  */
3550                         memcpy(tmp, name, len + 1);
3551
3552                         SvCUR_set(namesv, dirlen + len + 1);
3553
3554                         /* Don't even actually have to turn SvPOK_on() as we
3555                            access it directly with SvPVX() below.  */
3556                     }
3557 #  endif
3558 #endif
3559                     TAINT_PROPER("require");
3560                     tryname = SvPVX_const(namesv);
3561                     tryrsfp = doopen_pm(tryname, SvCUR(namesv));
3562                     if (tryrsfp) {
3563                         if (tryname[0] == '.' && tryname[1] == '/') {
3564                             ++tryname;
3565                             while (*++tryname == '/');
3566                         }
3567                         break;
3568                     }
3569                     else if (errno == EMFILE)
3570                         /* no point in trying other paths if out of handles */
3571                         break;
3572                   }
3573                 }
3574             }
3575         }
3576     }
3577     SAVECOPFILE_FREE(&PL_compiling);
3578     CopFILE_set(&PL_compiling, tryrsfp ? tryname : name);
3579     SvREFCNT_dec(namesv);
3580     if (!tryrsfp) {
3581         if (PL_op->op_type == OP_REQUIRE) {
3582             const char *msgstr = name;
3583             if(errno == EMFILE) {
3584                 SV * const msg
3585                     = sv_2mortal(Perl_newSVpvf(aTHX_ "%s:   %s", msgstr,
3586                                                Strerror(errno)));
3587                 msgstr = SvPV_nolen_const(msg);
3588             } else {
3589                 if (namesv) {                   /* did we lookup @INC? */
3590                     AV * const ar = GvAVn(PL_incgv);
3591                     I32 i;
3592                     SV * const msg = sv_2mortal(Perl_newSVpvf(aTHX_
3593                         "%s in @INC%s%s (@INC contains:",
3594                         msgstr,
3595                         (instr(msgstr, ".h ")
3596                          ? " (change .h to .ph maybe?)" : ""),
3597                         (instr(msgstr, ".ph ")
3598                          ? " (did you run h2ph?)" : "")
3599                                                               ));
3600
3601                     for (i = 0; i <= AvFILL(ar); i++) {
3602                         sv_catpvs(msg, " ");
3603                         sv_catsv(msg, *av_fetch(ar, i, TRUE));
3604                     }
3605                     sv_catpvs(msg, ")");
3606                     msgstr = SvPV_nolen_const(msg);
3607                 }
3608             }
3609             DIE(aTHX_ "Can't locate %s", msgstr);
3610         }
3611
3612         RETPUSHUNDEF;
3613     }
3614     else
3615         SETERRNO(0, SS_NORMAL);
3616
3617     /* Assume success here to prevent recursive requirement. */
3618     /* name is never assigned to again, so len is still strlen(name)  */
3619     /* Check whether a hook in @INC has already filled %INC */
3620     if (!hook_sv) {
3621         (void)hv_store(GvHVn(PL_incgv),
3622                        unixname, unixlen, newSVpv(CopFILE(&PL_compiling),0),0);
3623     } else {
3624         SV** const svp = hv_fetch(GvHVn(PL_incgv), unixname, unixlen, 0);
3625         if (!svp)
3626             (void)hv_store(GvHVn(PL_incgv),
3627                            unixname, unixlen, SvREFCNT_inc_simple(hook_sv), 0 );
3628     }
3629
3630     ENTER_with_name("eval");
3631     SAVETMPS;
3632     lex_start(NULL, tryrsfp, TRUE);
3633
3634     SAVEHINTS();
3635     PL_hints = 0;
3636     hv_clear(GvHV(PL_hintgv));
3637
3638     SAVECOMPILEWARNINGS();
3639     if (PL_dowarn & G_WARN_ALL_ON)
3640         PL_compiling.cop_warnings = pWARN_ALL ;
3641     else if (PL_dowarn & G_WARN_ALL_OFF)
3642         PL_compiling.cop_warnings = pWARN_NONE ;
3643     else
3644         PL_compiling.cop_warnings = pWARN_STD ;
3645
3646     if (filter_sub || filter_cache) {
3647         /* We can use the SvPV of the filter PVIO itself as our cache, rather
3648            than hanging another SV from it. In turn, filter_add() optionally
3649            takes the SV to use as the filter (or creates a new SV if passed
3650            NULL), so simply pass in whatever value filter_cache has.  */
3651         SV * const datasv = filter_add(S_run_user_filter, filter_cache);
3652         IoLINES(datasv) = filter_has_file;
3653         IoTOP_GV(datasv) = MUTABLE_GV(filter_state);
3654         IoBOTTOM_GV(datasv) = MUTABLE_GV(filter_sub);
3655     }
3656
3657     /* switch to eval mode */
3658     PUSHBLOCK(cx, CXt_EVAL, SP);
3659     PUSHEVAL(cx, name);
3660     cx->blk_eval.retop = PL_op->op_next;
3661
3662     SAVECOPLINE(&PL_compiling);
3663     CopLINE_set(&PL_compiling, 0);
3664
3665     PUTBACK;
3666
3667     /* Store and reset encoding. */
3668     encoding = PL_encoding;
3669     PL_encoding = NULL;
3670
3671     if (doeval(gimme, NULL, NULL, PL_curcop->cop_seq))
3672         op = DOCATCH(PL_eval_start);
3673     else
3674         op = PL_op->op_next;
3675
3676     /* Restore encoding. */
3677     PL_encoding = encoding;
3678
3679     return op;
3680 }
3681
3682 /* This is a op added to hold the hints hash for
3683    pp_entereval. The hash can be modified by the code
3684    being eval'ed, so we return a copy instead. */
3685
3686 PP(pp_hintseval)
3687 {
3688     dVAR;
3689     dSP;
3690     mXPUSHs(MUTABLE_SV(Perl_hv_copy_hints_hv(aTHX_ MUTABLE_HV(cSVOP_sv))));
3691     RETURN;
3692 }
3693
3694
3695 PP(pp_entereval)
3696 {
3697     dVAR; dSP;
3698     register PERL_CONTEXT *cx;
3699     SV *sv;
3700     const I32 gimme = GIMME_V;
3701     const U32 was = PL_breakable_sub_gen;
3702     char tbuf[TYPE_DIGITS(long) + 12];
3703     char *tmpbuf = tbuf;
3704     STRLEN len;
3705     CV* runcv;
3706     U32 seq;
3707     HV *saved_hh = NULL;
3708
3709     if (PL_op->op_private & OPpEVAL_HAS_HH) {
3710         saved_hh = MUTABLE_HV(SvREFCNT_inc(POPs));
3711     }
3712     sv = POPs;
3713
3714     TAINT_IF(SvTAINTED(sv));
3715     TAINT_PROPER("eval");
3716
3717     ENTER_with_name("eval");
3718     lex_start(sv, NULL, FALSE);
3719     SAVETMPS;
3720
3721     /* switch to eval mode */
3722
3723     if (PERLDB_NAMEEVAL && CopLINE(PL_curcop)) {
3724         SV * const temp_sv = sv_newmortal();
3725         Perl_sv_setpvf(aTHX_ temp_sv, "_<(eval %lu)[%s:%"IVdf"]",
3726                        (unsigned long)++PL_evalseq,
3727                        CopFILE(PL_curcop), (IV)CopLINE(PL_curcop));
3728         tmpbuf = SvPVX(temp_sv);
3729         len = SvCUR(temp_sv);
3730     }
3731     else
3732         len = my_snprintf(tmpbuf, sizeof(tbuf), "_<(eval %lu)", (unsigned long)++PL_evalseq);
3733     SAVECOPFILE_FREE(&PL_compiling);
3734     CopFILE_set(&PL_compiling, tmpbuf+2);
3735     SAVECOPLINE(&PL_compiling);
3736     CopLINE_set(&PL_compiling, 1);
3737     /* XXX For C<eval "...">s within BEGIN {} blocks, this ends up
3738        deleting the eval's FILEGV from the stash before gv_check() runs
3739        (i.e. before run-time proper). To work around the coredump that
3740        ensues, we always turn GvMULTI_on for any globals that were
3741        introduced within evals. See force_ident(). GSAR 96-10-12 */
3742     SAVEHINTS();
3743     PL_hints = PL_op->op_targ;
3744     if (saved_hh) {
3745         /* SAVEHINTS created a new HV in PL_hintgv, which we need to GC */
3746         SvREFCNT_dec(GvHV(PL_hintgv));
3747         GvHV(PL_hintgv) = saved_hh;
3748     }
3749     SAVECOMPILEWARNINGS();
3750     PL_compiling.cop_warnings = DUP_WARNINGS(PL_curcop->cop_warnings);
3751     if (PL_compiling.cop_hints_hash) {
3752         Perl_refcounted_he_free(aTHX_ PL_compiling.cop_hints_hash);
3753     }
3754     PL_compiling.cop_hints_hash = PL_curcop->cop_hints_hash;
3755     if (PL_compiling.cop_hints_hash) {
3756         HINTS_REFCNT_LOCK;
3757         PL_compiling.cop_hints_hash->refcounted_he_refcnt++;
3758         HINTS_REFCNT_UNLOCK;
3759     }
3760     /* special case: an eval '' executed within the DB package gets lexically
3761      * placed in the first non-DB CV rather than the current CV - this
3762      * allows the debugger to execute code, find lexicals etc, in the
3763      * scope of the code being debugged. Passing &seq gets find_runcv
3764      * to do the dirty work for us */
3765     runcv = find_runcv(&seq);
3766
3767     PUSHBLOCK(cx, (CXt_EVAL|CXp_REAL), SP);
3768     PUSHEVAL(cx, 0);
3769     cx->blk_eval.retop = PL_op->op_next;
3770
3771     /* prepare to compile string */
3772
3773     if ((PERLDB_LINE || PERLDB_SAVESRC) && PL_curstash != PL_debstash)
3774         save_lines(CopFILEAV(&PL_compiling), PL_parser->linestr);
3775     PUTBACK;
3776
3777     if (doeval(gimme, NULL, runcv, seq)) {
3778         if (was != PL_breakable_sub_gen /* Some subs defined here. */
3779             ? (PERLDB_LINE || PERLDB_SAVESRC)
3780             :  PERLDB_SAVESRC_NOSUBS) {
3781             /* Retain the filegv we created.  */
3782         } else {
3783             char *const safestr = savepvn(tmpbuf, len);
3784             SAVEDELETE(PL_defstash, safestr, len);
3785         }
3786         return DOCATCH(PL_eval_start);
3787     } else {
3788         /* We have already left the scope set up earler thanks to the LEAVE
3789            in doeval().  */
3790         if (was != PL_breakable_sub_gen /* Some subs defined here. */
3791             ? (PERLDB_LINE || PERLDB_SAVESRC)
3792             :  PERLDB_SAVESRC_INVALID) {
3793             /* Retain the filegv we created.  */
3794         } else {
3795             (void)hv_delete(PL_defstash, tmpbuf, len, G_DISCARD);
3796         }
3797         return PL_op->op_next;
3798     }
3799 }
3800
3801 PP(pp_leaveeval)
3802 {
3803     dVAR; dSP;
3804     register SV **mark;
3805     SV **newsp;
3806     PMOP *newpm;
3807     I32 gimme;
3808     register PERL_CONTEXT *cx;
3809     OP *retop;
3810     const U8 save_flags = PL_op -> op_flags;
3811     I32 optype;
3812
3813     POPBLOCK(cx,newpm);
3814     POPEVAL(cx);
3815     retop = cx->blk_eval.retop;
3816
3817     TAINT_NOT;
3818     if (gimme == G_VOID)
3819         MARK = newsp;
3820     else if (gimme == G_SCALAR) {
3821         MARK = newsp + 1;
3822         if (MARK <= SP) {
3823             if (SvFLAGS(TOPs) & SVs_TEMP)
3824                 *MARK = TOPs;
3825             else
3826                 *MARK = sv_mortalcopy(TOPs);
3827         }
3828         else {
3829             MEXTEND(mark,0);
3830             *MARK = &PL_sv_undef;
3831         }
3832         SP = MARK;
3833     }
3834     else {
3835         /* in case LEAVE wipes old return values */
3836         for (mark = newsp + 1; mark <= SP; mark++) {
3837             if (!(SvFLAGS(*mark) & SVs_TEMP)) {
3838                 *mark = sv_mortalcopy(*mark);
3839                 TAINT_NOT;      /* Each item is independent */
3840             }
3841         }
3842     }
3843     PL_curpm = newpm;   /* Don't pop $1 et al till now */
3844
3845 #ifdef DEBUGGING
3846     assert(CvDEPTH(PL_compcv) == 1);
3847 #endif
3848     CvDEPTH(PL_compcv) = 0;
3849     lex_end();
3850
3851     if (optype == OP_REQUIRE &&
3852         !(gimme == G_SCALAR ? SvTRUE(*SP) : SP > newsp))
3853     {
3854         /* Unassume the success we assumed earlier. */
3855         SV * const nsv = cx->blk_eval.old_namesv;
3856         (void)hv_delete(GvHVn(PL_incgv), SvPVX_const(nsv), SvCUR(nsv), G_DISCARD);
3857         retop = Perl_die(aTHX_ "%"SVf" did not return a true value", SVfARG(nsv));
3858         /* die_where() did LEAVE, or we won't be here */
3859     }
3860     else {
3861         LEAVE_with_name("eval");
3862         if (!(save_flags & OPf_SPECIAL)) {
3863             CLEAR_ERRSV();
3864         }
3865     }
3866
3867     RETURNOP(retop);
3868 }
3869
3870 /* Common code for Perl_call_sv and Perl_fold_constants, put here to keep it
3871    close to the related Perl_create_eval_scope.  */
3872 void
3873 Perl_delete_eval_scope(pTHX)
3874 {
3875     SV **newsp;
3876     PMOP *newpm;
3877     I32 gimme;
3878     register PERL_CONTEXT *cx;
3879     I32 optype;
3880
3881     POPBLOCK(cx,newpm);
3882     POPEVAL(cx);
3883     PL_curpm = newpm;
3884     LEAVE_with_name("eval_scope");
3885     PERL_UNUSED_VAR(newsp);
3886     PERL_UNUSED_VAR(gimme);
3887     PERL_UNUSED_VAR(optype);
3888 }
3889
3890 /* Common-ish code salvaged from Perl_call_sv and pp_entertry, because it was
3891    also needed by Perl_fold_constants.  */
3892 PERL_CONTEXT *
3893 Perl_create_eval_scope(pTHX_ U32 flags)
3894 {
3895     PERL_CONTEXT *cx;
3896     const I32 gimme = GIMME_V;
3897
3898     ENTER_with_name("eval_scope");
3899     SAVETMPS;
3900
3901     PUSHBLOCK(cx, (CXt_EVAL|CXp_TRYBLOCK), PL_stack_sp);
3902     PUSHEVAL(cx, 0);
3903
3904     PL_in_eval = EVAL_INEVAL;
3905     if (flags & G_KEEPERR)
3906         PL_in_eval |= EVAL_KEEPERR;
3907     else
3908         CLEAR_ERRSV();
3909     if (flags & G_FAKINGEVAL) {
3910         PL_eval_root = PL_op; /* Only needed so that goto works right. */
3911     }
3912     return cx;
3913 }
3914
3915 PP(pp_entertry)
3916 {
3917     dVAR;
3918     PERL_CONTEXT * const cx = create_eval_scope(0);
3919     cx->blk_eval.retop = cLOGOP->op_other->op_next;
3920     return DOCATCH(PL_op->op_next);
3921 }
3922
3923 PP(pp_leavetry)
3924 {
3925     dVAR; dSP;
3926     SV **newsp;
3927     PMOP *newpm;
3928     I32 gimme;
3929     register PERL_CONTEXT *cx;
3930     I32 optype;
3931
3932     POPBLOCK(cx,newpm);
3933     POPEVAL(cx);
3934     PERL_UNUSED_VAR(optype);
3935
3936     TAINT_NOT;
3937     if (gimme == G_VOID)
3938         SP = newsp;
3939     else if (gimme == G_SCALAR) {
3940         register SV **mark;
3941         MARK = newsp + 1;
3942         if (MARK <= SP) {
3943             if (SvFLAGS(TOPs) & (SVs_PADTMP|SVs_TEMP))
3944                 *MARK = TOPs;
3945             else
3946                 *MARK = sv_mortalcopy(TOPs);
3947         }
3948         else {
3949             MEXTEND(mark,0);
3950             *MARK = &PL_sv_undef;
3951         }
3952         SP = MARK;
3953     }
3954     else {
3955         /* in case LEAVE wipes old return values */
3956         register SV **mark;
3957         for (mark = newsp + 1; mark <= SP; mark++) {
3958             if (!(SvFLAGS(*mark) & (SVs_PADTMP|SVs_TEMP))) {
3959                 *mark = sv_mortalcopy(*mark);
3960                 TAINT_NOT;      /* Each item is independent */
3961             }
3962         }
3963     }
3964     PL_curpm = newpm;   /* Don't pop $1 et al till now */
3965
3966     LEAVE_with_name("eval_scope");
3967     CLEAR_ERRSV();
3968     RETURN;
3969 }
3970
3971 PP(pp_entergiven)
3972 {
3973     dVAR; dSP;
3974     register PERL_CONTEXT *cx;
3975     const I32 gimme = GIMME_V;
3976
3977     ENTER_with_name("given");
3978     SAVETMPS;
3979
3980     sv_setsv(PAD_SV(PL_op->op_targ), POPs);
3981
3982     PUSHBLOCK(cx, CXt_GIVEN, SP);
3983     PUSHGIVEN(cx);
3984
3985     RETURN;
3986 }
3987
3988 PP(pp_leavegiven)
3989 {
3990     dVAR; dSP;
3991     register PERL_CONTEXT *cx;
3992     I32 gimme;
3993     SV **newsp;
3994     PMOP *newpm;
3995     PERL_UNUSED_CONTEXT;
3996
3997     POPBLOCK(cx,newpm);
3998     assert(CxTYPE(cx) == CXt_GIVEN);
3999
4000     SP = newsp;
4001     PUTBACK;
4002
4003     PL_curpm = newpm;   /* pop $1 et al */
4004
4005     LEAVE_with_name("given");
4006
4007     return NORMAL;
4008 }
4009
4010 /* Helper routines used by pp_smartmatch */
4011 STATIC PMOP *
4012 S_make_matcher(pTHX_ REGEXP *re)
4013 {
4014     dVAR;
4015     PMOP *matcher = (PMOP *) newPMOP(OP_MATCH, OPf_WANT_SCALAR | OPf_STACKED);
4016
4017     PERL_ARGS_ASSERT_MAKE_MATCHER;
4018
4019     PM_SETRE(matcher, ReREFCNT_inc(re));
4020
4021     SAVEFREEOP((OP *) matcher);
4022     ENTER_with_name("matcher"); SAVETMPS;
4023     SAVEOP();
4024     return matcher;
4025 }
4026
4027 STATIC bool
4028 S_matcher_matches_sv(pTHX_ PMOP *matcher, SV *sv)
4029 {
4030     dVAR;
4031     dSP;
4032
4033     PERL_ARGS_ASSERT_MATCHER_MATCHES_SV;
4034
4035     PL_op = (OP *) matcher;
4036     XPUSHs(sv);
4037     PUTBACK;
4038     (void) pp_match();
4039     SPAGAIN;
4040     return (SvTRUEx(POPs));
4041 }
4042
4043 STATIC void
4044 S_destroy_matcher(pTHX_ PMOP *matcher)
4045 {
4046     dVAR;
4047
4048     PERL_ARGS_ASSERT_DESTROY_MATCHER;
4049     PERL_UNUSED_ARG(matcher);
4050
4051     FREETMPS;
4052     LEAVE_with_name("matcher");
4053 }
4054
4055 /* Do a smart match */
4056 PP(pp_smartmatch)
4057 {
4058     DEBUG_M(Perl_deb(aTHX_ "Starting smart match resolution\n"));
4059     return do_smartmatch(NULL, NULL);
4060 }
4061
4062 /* This version of do_smartmatch() implements the
4063  * table of smart matches that is found in perlsyn.
4064  */
4065 STATIC OP *
4066 S_do_smartmatch(pTHX_ HV *seen_this, HV *seen_other)
4067 {
4068     dVAR;
4069     dSP;
4070
4071     bool object_on_left = FALSE;
4072     SV *e = TOPs;       /* e is for 'expression' */
4073     SV *d = TOPm1s;     /* d is for 'default', as in PL_defgv */
4074
4075     /* First of all, handle overload magic of the rightmost argument */
4076     if (SvAMAGIC(e)) {
4077         SV * tmpsv;
4078         DEBUG_M(Perl_deb(aTHX_ "    applying rule Any-Object\n"));
4079         DEBUG_M(Perl_deb(aTHX_ "        attempting overload\n"));
4080
4081         tmpsv = amagic_call(d, e, smart_amg, 0);
4082         if (tmpsv) {
4083             SPAGAIN;
4084             (void)POPs;
4085             SETs(tmpsv);
4086             RETURN;
4087         }
4088         DEBUG_M(Perl_deb(aTHX_ "        failed to run overload method; continuing...\n"));
4089     }
4090
4091     SP -= 2;    /* Pop the values */
4092
4093     /* Take care only to invoke mg_get() once for each argument.
4094      * Currently we do this by copying the SV if it's magical. */
4095     if (d) {
4096         if (SvGMAGICAL(d))
4097             d = sv_mortalcopy(d);
4098     }
4099     else
4100         d = &PL_sv_undef;
4101
4102     assert(e);
4103     if (SvGMAGICAL(e))
4104         e = sv_mortalcopy(e);
4105
4106     /* ~~ undef */
4107     if (!SvOK(e)) {
4108         DEBUG_M(Perl_deb(aTHX_ "    applying rule Any-undef\n"));
4109         if (SvOK(d))
4110             RETPUSHNO;
4111         else
4112             RETPUSHYES;
4113     }
4114
4115     if (sv_isobject(e) && (SvTYPE(SvRV(e)) != SVt_REGEXP)) {
4116         DEBUG_M(Perl_deb(aTHX_ "    applying rule Any-Object\n"));
4117         Perl_croak(aTHX_ "Smart matching a non-overloaded object breaks encapsulation");
4118     }
4119     if (sv_isobject(d) && (SvTYPE(SvRV(d)) != SVt_REGEXP))
4120         object_on_left = TRUE;
4121
4122     /* ~~ sub */
4123     if (SvROK(e) && SvTYPE(SvRV(e)) == SVt_PVCV) {
4124         I32 c;
4125         if (object_on_left) {
4126             goto sm_any_sub; /* Treat objects like scalars */
4127         }
4128         else if (SvROK(d) && SvTYPE(SvRV(d)) == SVt_PVHV) {
4129             /* Test sub truth for each key */
4130             HE *he;
4131             bool andedresults = TRUE;
4132             HV *hv = (HV*) SvRV(d);
4133             I32 numkeys = hv_iterinit(hv);
4134             DEBUG_M(Perl_deb(aTHX_ "    applying rule Hash-CodeRef\n"));
4135             if (numkeys == 0)
4136                 RETPUSHYES;
4137             while ( (he = hv_iternext(hv)) ) {
4138                 DEBUG_M(Perl_deb(aTHX_ "        testing hash key...\n"));
4139                 ENTER_with_name("smartmatch_hash_key_test");
4140                 SAVETMPS;
4141                 PUSHMARK(SP);
4142                 PUSHs(hv_iterkeysv(he));
4143                 PUTBACK;
4144                 c = call_sv(e, G_SCALAR);
4145                 SPAGAIN;
4146                 if (c == 0)
4147                     andedresults = FALSE;
4148                 else
4149                     andedresults = SvTRUEx(POPs) && andedresults;
4150                 FREETMPS;
4151                 LEAVE_with_name("smartmatch_hash_key_test");
4152             }
4153             if (andedresults)
4154                 RETPUSHYES;
4155             else
4156                 RETPUSHNO;
4157         }
4158         else if (SvROK(d) && SvTYPE(SvRV(d)) == SVt_PVAV) {
4159             /* Test sub truth for each element */
4160             I32 i;
4161             bool andedresults = TRUE;
4162             AV *av = (AV*) SvRV(d);
4163             const I32 len = av_len(av);
4164             DEBUG_M(Perl_deb(aTHX_ "    applying rule Array-CodeRef\n"));
4165             if (len == -1)
4166                 RETPUSHYES;
4167             for (i = 0; i <= len; ++i) {
4168                 SV * const * const svp = av_fetch(av, i, FALSE);
4169                 DEBUG_M(Perl_deb(aTHX_ "        testing array element...\n"));
4170                 ENTER_with_name("smartmatch_array_elem_test");
4171                 SAVETMPS;
4172                 PUSHMARK(SP);
4173                 if (svp)
4174                     PUSHs(*svp);
4175                 PUTBACK;
4176                 c = call_sv(e, G_SCALAR);
4177                 SPAGAIN;
4178                 if (c == 0)
4179                     andedresults = FALSE;
4180                 else
4181                     andedresults = SvTRUEx(POPs) && andedresults;
4182                 FREETMPS;
4183                 LEAVE_with_name("smartmatch_array_elem_test");
4184             }
4185             if (andedresults)
4186                 RETPUSHYES;
4187             else
4188                 RETPUSHNO;
4189         }
4190         else {
4191           sm_any_sub:
4192             DEBUG_M(Perl_deb(aTHX_ "    applying rule Any-CodeRef\n"));
4193             ENTER_with_name("smartmatch_coderef");
4194             SAVETMPS;
4195             PUSHMARK(SP);
4196             PUSHs(d);
4197             PUTBACK;
4198             c = call_sv(e, G_SCALAR);
4199             SPAGAIN;
4200             if (c == 0)
4201                 PUSHs(&PL_sv_no);
4202             else if (SvTEMP(TOPs))
4203                 SvREFCNT_inc_void(TOPs);
4204             FREETMPS;
4205             LEAVE_with_name("smartmatch_coderef");
4206             RETURN;
4207         }
4208     }
4209     /* ~~ %hash */
4210     else if (SvROK(e) && SvTYPE(SvRV(e)) == SVt_PVHV) {
4211         if (object_on_left) {
4212             goto sm_any_hash; /* Treat objects like scalars */
4213         }
4214         else if (!SvOK(d)) {
4215             DEBUG_M(Perl_deb(aTHX_ "    applying rule Any-Hash ($a undef)\n"));
4216             RETPUSHNO;
4217         }
4218         else if (SvROK(d) && SvTYPE(SvRV(d)) == SVt_PVHV) {
4219             /* Check that the key-sets are identical */
4220             HE *he;
4221             HV *other_hv = MUTABLE_HV(SvRV(d));
4222             bool tied = FALSE;
4223             bool other_tied = FALSE;
4224             U32 this_key_count  = 0,
4225                 other_key_count = 0;
4226             HV *hv = MUTABLE_HV(SvRV(e));
4227
4228             DEBUG_M(Perl_deb(aTHX_ "    applying rule Hash-Hash\n"));
4229             /* Tied hashes don't know how many keys they have. */
4230             if (SvTIED_mg((SV*)hv, PERL_MAGIC_tied)) {
4231                 tied = TRUE;
4232             }
4233             else if (SvTIED_mg((const SV *)other_hv, PERL_MAGIC_tied)) {
4234                 HV * const temp = other_hv;
4235                 other_hv = hv;
4236                 hv = temp;
4237                 tied = TRUE;
4238             }
4239             if (SvTIED_mg((const SV *)other_hv, PERL_MAGIC_tied))
4240                 other_tied = TRUE;
4241
4242             if (!tied && HvUSEDKEYS((const HV *) hv) != HvUSEDKEYS(other_hv))
4243                 RETPUSHNO;
4244
4245             /* The hashes have the same number of keys, so it suffices
4246                to check that one is a subset of the other. */
4247             (void) hv_iterinit(hv);
4248             while ( (he = hv_iternext(hv)) ) {
4249                 SV *key = hv_iterkeysv(he);
4250
4251                 DEBUG_M(Perl_deb(aTHX_ "        comparing hash key...\n"));
4252                 ++ this_key_count;
4253
4254                 if(!hv_exists_ent(other_hv, key, 0)) {
4255                     (void) hv_iterinit(hv);     /* reset iterator */
4256                     RETPUSHNO;
4257                 }
4258             }
4259
4260             if (other_tied) {
4261                 (void) hv_iterinit(other_hv);
4262                 while ( hv_iternext(other_hv) )
4263                     ++other_key_count;
4264             }
4265             else
4266                 other_key_count = HvUSEDKEYS(other_hv);
4267
4268             if (this_key_count != other_key_count)
4269                 RETPUSHNO;
4270             else
4271                 RETPUSHYES;
4272         }
4273         else if (SvROK(d) && SvTYPE(SvRV(d)) == SVt_PVAV) {
4274             AV * const other_av = MUTABLE_AV(SvRV(d));
4275             const I32 other_len = av_len(other_av) + 1;
4276             I32 i;
4277             HV *hv = MUTABLE_HV(SvRV(e));
4278
4279             DEBUG_M(Perl_deb(aTHX_ "    applying rule Array-Hash\n"));
4280             for (i = 0; i < other_len; ++i) {
4281                 SV ** const svp = av_fetch(other_av, i, FALSE);
4282                 DEBUG_M(Perl_deb(aTHX_ "        checking for key existence...\n"));
4283                 if (svp) {      /* ??? When can this not happen? */
4284                     if (hv_exists_ent(hv, *svp, 0))
4285                         RETPUSHYES;
4286                 }
4287             }
4288             RETPUSHNO;
4289         }
4290         else if (SvROK(d) && SvTYPE(SvRV(d)) == SVt_REGEXP) {
4291             DEBUG_M(Perl_deb(aTHX_ "    applying rule Regex-Hash\n"));
4292           sm_regex_hash:
4293             {
4294                 PMOP * const matcher = make_matcher((REGEXP*) SvRV(d));
4295                 HE *he;
4296                 HV *hv = MUTABLE_HV(SvRV(e));
4297
4298                 (void) hv_iterinit(hv);
4299                 while ( (he = hv_iternext(hv)) ) {
4300                     DEBUG_M(Perl_deb(aTHX_ "        testing key against pattern...\n"));
4301                     if (matcher_matches_sv(matcher, hv_iterkeysv(he))) {
4302                         (void) hv_iterinit(hv);
4303                         destroy_matcher(matcher);
4304                         RETPUSHYES;
4305                     }
4306                 }
4307                 destroy_matcher(matcher);
4308                 RETPUSHNO;
4309             }
4310         }
4311         else {
4312           sm_any_hash:
4313             DEBUG_M(Perl_deb(aTHX_ "    applying rule Any-Hash\n"));
4314             if (hv_exists_ent(MUTABLE_HV(SvRV(e)), d, 0))
4315                 RETPUSHYES;
4316             else
4317                 RETPUSHNO;
4318         }
4319     }
4320     /* ~~ @array */
4321     else if (SvROK(e) && SvTYPE(SvRV(e)) == SVt_PVAV) {
4322         if (object_on_left) {
4323             goto sm_any_array; /* Treat objects like scalars */
4324         }
4325         else if (SvROK(d) && SvTYPE(SvRV(d)) == SVt_PVHV) {
4326             AV * const other_av = MUTABLE_AV(SvRV(e));
4327             const I32 other_len = av_len(other_av) + 1;
4328             I32 i;
4329
4330             DEBUG_M(Perl_deb(aTHX_ "    applying rule Hash-Array\n"));
4331             for (i = 0; i < other_len; ++i) {
4332                 SV ** const svp = av_fetch(other_av, i, FALSE);
4333
4334                 DEBUG_M(Perl_deb(aTHX_ "        testing for key existence...\n"));
4335                 if (svp) {      /* ??? When can this not happen? */
4336                     if (hv_exists_ent(MUTABLE_HV(SvRV(d)), *svp, 0))
4337                         RETPUSHYES;
4338                 }
4339             }
4340             RETPUSHNO;
4341         }
4342         if (SvROK(d) && SvTYPE(SvRV(d)) == SVt_PVAV) {
4343             AV *other_av = MUTABLE_AV(SvRV(d));
4344             DEBUG_M(Perl_deb(aTHX_ "    applying rule Array-Array\n"));
4345             if (av_len(MUTABLE_AV(SvRV(e))) != av_len(other_av))
4346                 RETPUSHNO;
4347             else {
4348                 I32 i;
4349                 const I32 other_len = av_len(other_av);
4350
4351                 if (NULL == seen_this) {
4352                     seen_this = newHV();
4353                     (void) sv_2mortal(MUTABLE_SV(seen_this));
4354                 }
4355                 if (NULL == seen_other) {
4356                     seen_other = newHV();
4357                     (void) sv_2mortal(MUTABLE_SV(seen_other));
4358                 }
4359                 for(i = 0; i <= other_len; ++i) {
4360                     SV * const * const this_elem = av_fetch(MUTABLE_AV(SvRV(e)), i, FALSE);
4361                     SV * const * const other_elem = av_fetch(other_av, i, FALSE);
4362
4363                     if (!this_elem || !other_elem) {
4364                         if ((this_elem && SvOK(*this_elem))
4365                                 || (other_elem && SvOK(*other_elem)))
4366                             RETPUSHNO;
4367                     }
4368                     else if (hv_exists_ent(seen_this,
4369                                 sv_2mortal(newSViv(PTR2IV(*this_elem))), 0) ||
4370                             hv_exists_ent(seen_other,
4371                                 sv_2mortal(newSViv(PTR2IV(*other_elem))), 0))
4372                     {
4373                         if (*this_elem != *other_elem)
4374                             RETPUSHNO;
4375                     }
4376                     else {
4377                         (void)hv_store_ent(seen_this,
4378                                 sv_2mortal(newSViv(PTR2IV(*this_elem))),
4379                                 &PL_sv_undef, 0);
4380                         (void)hv_store_ent(seen_other,
4381                                 sv_2mortal(newSViv(PTR2IV(*other_elem))),
4382                                 &PL_sv_undef, 0);
4383                         PUSHs(*other_elem);
4384                         PUSHs(*this_elem);
4385
4386                         PUTBACK;
4387                         DEBUG_M(Perl_deb(aTHX_ "        recursively comparing array element...\n"));
4388                         (void) do_smartmatch(seen_this, seen_other);
4389                         SPAGAIN;
4390                         DEBUG_M(Perl_deb(aTHX_ "        recursion finished\n"));
4391
4392                         if (!SvTRUEx(POPs))
4393                             RETPUSHNO;
4394                     }
4395                 }
4396                 RETPUSHYES;
4397             }
4398         }
4399         else if (SvROK(d) && SvTYPE(SvRV(d)) == SVt_REGEXP) {
4400             DEBUG_M(Perl_deb(aTHX_ "    applying rule Regex-Array\n"));
4401           sm_regex_array:
4402             {
4403                 PMOP * const matcher = make_matcher((REGEXP*) SvRV(d));
4404                 const I32 this_len = av_len(MUTABLE_AV(SvRV(e)));
4405                 I32 i;
4406
4407                 for(i = 0; i <= this_len; ++i) {
4408                     SV * const * const svp = av_fetch(MUTABLE_AV(SvRV(e)), i, FALSE);
4409                     DEBUG_M(Perl_deb(aTHX_ "        testing element against pattern...\n"));
4410                     if (svp && matcher_matches_sv(matcher, *svp)) {
4411                         destroy_matcher(matcher);
4412                         RETPUSHYES;
4413                     }
4414                 }
4415                 destroy_matcher(matcher);
4416                 RETPUSHNO;
4417             }
4418         }
4419         else if (!SvOK(d)) {
4420             /* undef ~~ array */
4421             const I32 this_len = av_len(MUTABLE_AV(SvRV(e)));
4422             I32 i;
4423
4424             DEBUG_M(Perl_deb(aTHX_ "    applying rule Undef-Array\n"));
4425             for (i = 0; i <= this_len; ++i) {
4426                 SV * const * const svp = av_fetch(MUTABLE_AV(SvRV(e)), i, FALSE);
4427                 DEBUG_M(Perl_deb(aTHX_ "        testing for undef element...\n"));
4428                 if (!svp || !SvOK(*svp))
4429                     RETPUSHYES;
4430             }
4431             RETPUSHNO;
4432         }
4433         else {
4434           sm_any_array:
4435             {
4436                 I32 i;
4437                 const I32 this_len = av_len(MUTABLE_AV(SvRV(e)));
4438
4439                 DEBUG_M(Perl_deb(aTHX_ "    applying rule Any-Array\n"));
4440                 for (i = 0; i <= this_len; ++i) {
4441                     SV * const * const svp = av_fetch(MUTABLE_AV(SvRV(e)), i, FALSE);
4442                     if (!svp)
4443                         continue;
4444
4445                     PUSHs(d);
4446                     PUSHs(*svp);
4447                     PUTBACK;
4448                     /* infinite recursion isn't supposed to happen here */
4449                     DEBUG_M(Perl_deb(aTHX_ "        recursively testing array element...\n"));
4450                     (void) do_smartmatch(NULL, NULL);
4451                     SPAGAIN;
4452                     DEBUG_M(Perl_deb(aTHX_ "        recursion finished\n"));
4453                     if (SvTRUEx(POPs))
4454                         RETPUSHYES;
4455                 }
4456                 RETPUSHNO;
4457             }
4458         }
4459     }
4460     /* ~~ qr// */
4461     else if (SvROK(e) && SvTYPE(SvRV(e)) == SVt_REGEXP) {
4462         if (!object_on_left && SvROK(d) && SvTYPE(SvRV(d)) == SVt_PVHV) {
4463             SV *t = d; d = e; e = t;
4464             DEBUG_M(Perl_deb(aTHX_ "    applying rule Hash-Regex\n"));
4465             goto sm_regex_hash;
4466         }
4467         else if (!object_on_left && SvROK(d) && SvTYPE(SvRV(d)) == SVt_PVAV) {
4468             SV *t = d; d = e; e = t;
4469             DEBUG_M(Perl_deb(aTHX_ "    applying rule Array-Regex\n"));
4470             goto sm_regex_array;
4471         }
4472         else {
4473             PMOP * const matcher = make_matcher((REGEXP*) SvRV(e));
4474
4475             DEBUG_M(Perl_deb(aTHX_ "    applying rule Any-Regex\n"));
4476             PUTBACK;
4477             PUSHs(matcher_matches_sv(matcher, d)
4478                     ? &PL_sv_yes
4479                     : &PL_sv_no);
4480             destroy_matcher(matcher);
4481             RETURN;
4482         }
4483     }
4484     /* ~~ scalar */
4485     /* See if there is overload magic on left */
4486     else if (object_on_left && SvAMAGIC(d)) {
4487         SV *tmpsv;
4488         DEBUG_M(Perl_deb(aTHX_ "    applying rule Object-Any\n"));
4489         DEBUG_M(Perl_deb(aTHX_ "        attempting overload\n"));
4490         PUSHs(d); PUSHs(e);
4491         PUTBACK;
4492         tmpsv = amagic_call(d, e, smart_amg, AMGf_noright);
4493         if (tmpsv) {
4494             SPAGAIN;
4495             (void)POPs;
4496             SETs(tmpsv);
4497             RETURN;
4498         }
4499         SP -= 2;
4500         DEBUG_M(Perl_deb(aTHX_ "        failed to run overload method; falling back...\n"));
4501         goto sm_any_scalar;
4502     }
4503     else if (!SvOK(d)) {
4504         /* undef ~~ scalar ; we already know that the scalar is SvOK */
4505         DEBUG_M(Perl_deb(aTHX_ "    applying rule undef-Any\n"));
4506         RETPUSHNO;
4507     }
4508     else
4509   sm_any_scalar:
4510     if (SvNIOK(e) || (SvPOK(e) && looks_like_number(e) && SvNIOK(d))) {
4511         DEBUG_M(if (SvNIOK(e))
4512                     Perl_deb(aTHX_ "    applying rule Any-Num\n");
4513                 else
4514                     Perl_deb(aTHX_ "    applying rule Num-numish\n");
4515         );
4516         /* numeric comparison */
4517         PUSHs(d); PUSHs(e);
4518         PUTBACK;
4519         if (CopHINTS_get(PL_curcop) & HINT_INTEGER)
4520             (void) pp_i_eq();
4521         else
4522             (void) pp_eq();
4523         SPAGAIN;
4524         if (SvTRUEx(POPs))
4525             RETPUSHYES;
4526         else
4527             RETPUSHNO;
4528     }
4529
4530     /* As a last resort, use string comparison */
4531     DEBUG_M(Perl_deb(aTHX_ "    applying rule Any-Any\n"));
4532     PUSHs(d); PUSHs(e);
4533     PUTBACK;
4534     return pp_seq();
4535 }
4536
4537 PP(pp_enterwhen)
4538 {
4539     dVAR; dSP;
4540     register PERL_CONTEXT *cx;
4541     const I32 gimme = GIMME_V;
4542
4543     /* This is essentially an optimization: if the match
4544        fails, we don't want to push a context and then
4545        pop it again right away, so we skip straight
4546        to the op that follows the leavewhen.
4547     */
4548     if ((0 == (PL_op->op_flags & OPf_SPECIAL)) && !SvTRUEx(POPs))
4549         return cLOGOP->op_other->op_next;
4550
4551     ENTER_with_name("eval");
4552     SAVETMPS;
4553
4554     PUSHBLOCK(cx, CXt_WHEN, SP);
4555     PUSHWHEN(cx);
4556
4557     RETURN;
4558 }
4559
4560 PP(pp_leavewhen)
4561 {
4562     dVAR; dSP;
4563     register PERL_CONTEXT *cx;
4564     I32 gimme;
4565     SV **newsp;
4566     PMOP *newpm;
4567
4568     POPBLOCK(cx,newpm);
4569     assert(CxTYPE(cx) == CXt_WHEN);
4570
4571     SP = newsp;
4572     PUTBACK;
4573
4574     PL_curpm = newpm;   /* pop $1 et al */
4575
4576     LEAVE_with_name("eval");
4577     return NORMAL;
4578 }
4579
4580 PP(pp_continue)
4581 {
4582     dVAR;
4583     I32 cxix;
4584     register PERL_CONTEXT *cx;
4585     I32 inner;
4586
4587     cxix = dopoptowhen(cxstack_ix);
4588     if (cxix < 0)
4589         DIE(aTHX_ "Can't \"continue\" outside a when block");
4590     if (cxix < cxstack_ix)
4591         dounwind(cxix);
4592
4593     /* clear off anything above the scope we're re-entering */
4594     inner = PL_scopestack_ix;
4595     TOPBLOCK(cx);
4596     if (PL_scopestack_ix < inner)
4597         leave_scope(PL_scopestack[PL_scopestack_ix]);
4598     PL_curcop = cx->blk_oldcop;
4599     return cx->blk_givwhen.leave_op;
4600 }
4601
4602 PP(pp_break)
4603 {
4604     dVAR;
4605     I32 cxix;
4606     register PERL_CONTEXT *cx;
4607     I32 inner;
4608
4609     cxix = dopoptogiven(cxstack_ix);
4610     if (cxix < 0) {
4611         if (PL_op->op_flags & OPf_SPECIAL)
4612             DIE(aTHX_ "Can't use when() outside a topicalizer");
4613         else
4614             DIE(aTHX_ "Can't \"break\" outside a given block");
4615     }
4616     if (CxFOREACH(&cxstack[cxix]) && (0 == (PL_op->op_flags & OPf_SPECIAL)))
4617         DIE(aTHX_ "Can't \"break\" in a loop topicalizer");
4618
4619     if (cxix < cxstack_ix)
4620         dounwind(cxix);
4621
4622     /* clear off anything above the scope we're re-entering */
4623     inner = PL_scopestack_ix;
4624     TOPBLOCK(cx);
4625     if (PL_scopestack_ix < inner)
4626         leave_scope(PL_scopestack[PL_scopestack_ix]);
4627     PL_curcop = cx->blk_oldcop;
4628
4629     if (CxFOREACH(cx))
4630         return CX_LOOP_NEXTOP_GET(cx);
4631     else
4632         return cx->blk_givwhen.leave_op;
4633 }
4634
4635 STATIC OP *
4636 S_doparseform(pTHX_ SV *sv)
4637 {
4638     STRLEN len;
4639     register char *s = SvPV_force(sv, len);
4640     register char * const send = s + len;
4641     register char *base = NULL;
4642     register I32 skipspaces = 0;
4643     bool noblank   = FALSE;
4644     bool repeat    = FALSE;
4645     bool postspace = FALSE;
4646     U32 *fops;
4647     register U32 *fpc;
4648     U32 *linepc = NULL;
4649     register I32 arg;
4650     bool ischop;
4651     bool unchopnum = FALSE;
4652     int maxops = 12; /* FF_LINEMARK + FF_END + 10 (\0 without preceding \n) */
4653
4654     PERL_ARGS_ASSERT_DOPARSEFORM;
4655
4656     if (len == 0)
4657         Perl_croak(aTHX_ "Null picture in formline");
4658
4659     /* estimate the buffer size needed */
4660     for (base = s; s <= send; s++) {
4661         if (*s == '\n' || *s == '@' || *s == '^')
4662             maxops += 10;
4663     }
4664     s = base;
4665     base = NULL;
4666
4667     Newx(fops, maxops, U32);
4668     fpc = fops;
4669
4670     if (s < send) {
4671         linepc = fpc;
4672         *fpc++ = FF_LINEMARK;
4673         noblank = repeat = FALSE;
4674         base = s;
4675     }
4676
4677     while (s <= send) {
4678         switch (*s++) {
4679         default:
4680             skipspaces = 0;
4681             continue;
4682
4683         case '~':
4684             if (*s == '~') {
4685                 repeat = TRUE;
4686                 *s = ' ';
4687             }
4688             noblank = TRUE;
4689             s[-1] = ' ';
4690             /* FALL THROUGH */
4691         case ' ': case '\t':
4692             skipspaces++;
4693             continue;
4694         case 0:
4695             if (s < send) {
4696                 skipspaces = 0;
4697                 continue;
4698             } /* else FALL THROUGH */
4699         case '\n':
4700             arg = s - base;
4701             skipspaces++;
4702             arg -= skipspaces;
4703             if (arg) {
4704                 if (postspace)
4705                     *fpc++ = FF_SPACE;
4706                 *fpc++ = FF_LITERAL;
4707                 *fpc++ = (U16)arg;
4708             }
4709             postspace = FALSE;
4710             if (s <= send)
4711                 skipspaces--;
4712             if (skipspaces) {
4713                 *fpc++ = FF_SKIP;
4714                 *fpc++ = (U16)skipspaces;
4715             }
4716             skipspaces = 0;
4717             if (s <= send)
4718                 *fpc++ = FF_NEWLINE;
4719             if (noblank) {
4720                 *fpc++ = FF_BLANK;
4721                 if (repeat)
4722                     arg = fpc - linepc + 1;
4723                 else
4724                     arg = 0;
4725                 *fpc++ = (U16)arg;
4726             }
4727             if (s < send) {
4728                 linepc = fpc;
4729                 *fpc++ = FF_LINEMARK;
4730                 noblank = repeat = FALSE;
4731                 base = s;
4732             }
4733             else
4734                 s++;
4735             continue;
4736
4737         case '@':
4738         case '^':
4739             ischop = s[-1] == '^';
4740
4741             if (postspace) {
4742                 *fpc++ = FF_SPACE;
4743                 postspace = FALSE;
4744             }
4745             arg = (s - base) - 1;
4746             if (arg) {
4747                 *fpc++ = FF_LITERAL;
4748                 *fpc++ = (U16)arg;
4749             }
4750
4751             base = s - 1;
4752             *fpc++ = FF_FETCH;
4753             if (*s == '*') {
4754                 s++;
4755                 *fpc++ = 2;  /* skip the @* or ^* */
4756                 if (ischop) {
4757                     *fpc++ = FF_LINESNGL;
4758                     *fpc++ = FF_CHOP;
4759                 } else
4760                     *fpc++ = FF_LINEGLOB;
4761             }
4762             else if (*s == '#' || (*s == '.' && s[1] == '#')) {
4763                 arg = ischop ? 512 : 0;
4764                 base = s - 1;
4765                 while (*s == '#')
4766                     s++;
4767                 if (*s == '.') {
4768                     const char * const f = ++s;
4769                     while (*s == '#')
4770                         s++;
4771                     arg |= 256 + (s - f);
4772                 }
4773                 *fpc++ = s - base;              /* fieldsize for FETCH */
4774                 *fpc++ = FF_DECIMAL;
4775                 *fpc++ = (U16)arg;
4776                 unchopnum |= ! ischop;
4777             }
4778             else if (*s == '0' && s[1] == '#') {  /* Zero padded decimals */
4779                 arg = ischop ? 512 : 0;
4780                 base = s - 1;
4781                 s++;                                /* skip the '0' first */
4782                 while (*s == '#')
4783                     s++;
4784                 if (*s == '.') {
4785                     const char * const f = ++s;
4786                     while (*s == '#')
4787                         s++;
4788                     arg |= 256 + (s - f);
4789                 }
4790                 *fpc++ = s - base;                /* fieldsize for FETCH */
4791                 *fpc++ = FF_0DECIMAL;
4792                 *fpc++ = (U16)arg;
4793                 unchopnum |= ! ischop;
4794             }
4795             else {
4796                 I32 prespace = 0;
4797                 bool ismore = FALSE;
4798
4799                 if (*s == '>') {
4800                     while (*++s == '>') ;
4801                     prespace = FF_SPACE;
4802                 }
4803                 else if (*s == '|') {
4804                     while (*++s == '|') ;
4805                     prespace = FF_HALFSPACE;
4806                     postspace = TRUE;
4807                 }
4808                 else {
4809                     if (*s == '<')
4810                         while (*++s == '<') ;
4811                     postspace = TRUE;
4812                 }
4813                 if (*s == '.' && s[1] == '.' && s[2] == '.') {
4814                     s += 3;
4815                     ismore = TRUE;
4816                 }
4817                 *fpc++ = s - base;              /* fieldsize for FETCH */
4818
4819                 *fpc++ = ischop ? FF_CHECKCHOP : FF_CHECKNL;
4820
4821                 if (prespace)
4822                     *fpc++ = (U16)prespace;
4823                 *fpc++ = FF_ITEM;
4824                 if (ismore)
4825                     *fpc++ = FF_MORE;
4826                 if (ischop)
4827                     *fpc++ = FF_CHOP;
4828             }
4829             base = s;
4830             skipspaces = 0;
4831             continue;
4832         }
4833     }
4834     *fpc++ = FF_END;
4835
4836     assert (fpc <= fops + maxops); /* ensure our buffer estimate was valid */
4837     arg = fpc - fops;
4838     { /* need to jump to the next word */
4839         int z;
4840         z = WORD_ALIGN - SvCUR(sv) % WORD_ALIGN;
4841         SvGROW(sv, SvCUR(sv) + z + arg * sizeof(U32) + 4);
4842         s = SvPVX(sv) + SvCUR(sv) + z;
4843     }
4844     Copy(fops, s, arg, U32);
4845     Safefree(fops);
4846     sv_magic(sv, NULL, PERL_MAGIC_fm, NULL, 0);
4847     SvCOMPILED_on(sv);
4848
4849     if (unchopnum && repeat)
4850         DIE(aTHX_ "Repeated format line will never terminate (~~ and @#)");
4851     return 0;
4852 }
4853
4854
4855 STATIC bool
4856 S_num_overflow(NV value, I32 fldsize, I32 frcsize)
4857 {
4858     /* Can value be printed in fldsize chars, using %*.*f ? */
4859     NV pwr = 1;
4860     NV eps = 0.5;
4861     bool res = FALSE;
4862     int intsize = fldsize - (value < 0 ? 1 : 0);
4863
4864     if (frcsize & 256)
4865         intsize--;
4866     frcsize &= 255;
4867     intsize -= frcsize;
4868
4869     while (intsize--) pwr *= 10.0;
4870     while (frcsize--) eps /= 10.0;
4871
4872     if( value >= 0 ){
4873         if (value + eps >= pwr)
4874             res = TRUE;
4875     } else {
4876         if (value - eps <= -pwr)
4877             res = TRUE;
4878     }
4879     return res;
4880 }
4881
4882 static I32
4883 S_run_user_filter(pTHX_ int idx, SV *buf_sv, int maxlen)
4884 {
4885     dVAR;
4886     SV * const datasv = FILTER_DATA(idx);
4887     const int filter_has_file = IoLINES(datasv);
4888     SV * const filter_state = MUTABLE_SV(IoTOP_GV(datasv));
4889     SV * const filter_sub = MUTABLE_SV(IoBOTTOM_GV(datasv));
4890     int status = 0;
4891     SV *upstream;
4892     STRLEN got_len;
4893     char *got_p = NULL;
4894     char *prune_from = NULL;
4895     bool read_from_cache = FALSE;
4896     STRLEN umaxlen;
4897
4898     PERL_ARGS_ASSERT_RUN_USER_FILTER;
4899
4900     assert(maxlen >= 0);
4901     umaxlen = maxlen;
4902
4903     /* I was having segfault trouble under Linux 2.2.5 after a
4904        parse error occured.  (Had to hack around it with a test
4905        for PL_parser->error_count == 0.)  Solaris doesn't segfault --
4906        not sure where the trouble is yet.  XXX */
4907
4908     {
4909         SV *const cache = datasv;
4910         if (SvOK(cache)) {
4911             STRLEN cache_len;
4912             const char *cache_p = SvPV(cache, cache_len);
4913             STRLEN take = 0;
4914
4915             if (umaxlen) {
4916                 /* Running in block mode and we have some cached data already.
4917                  */
4918                 if (cache_len >= umaxlen) {
4919                     /* In fact, so much data we don't even need to call
4920                        filter_read.  */
4921                     take = umaxlen;
4922                 }
4923             } else {
4924                 const char *const first_nl =
4925                     (const char *)memchr(cache_p, '\n', cache_len);
4926                 if (first_nl) {
4927                     take = first_nl + 1 - cache_p;
4928                 }
4929             }
4930             if (take) {
4931                 sv_catpvn(buf_sv, cache_p, take);
4932                 sv_chop(cache, cache_p + take);
4933                 /* Definately not EOF  */
4934                 return 1;
4935             }
4936
4937             sv_catsv(buf_sv, cache);
4938             if (umaxlen) {
4939                 umaxlen -= cache_len;
4940             }
4941             SvOK_off(cache);
4942             read_from_cache = TRUE;
4943         }
4944     }
4945
4946     /* Filter API says that the filter appends to the contents of the buffer.
4947        Usually the buffer is "", so the details don't matter. But if it's not,
4948        then clearly what it contains is already filtered by this filter, so we
4949        don't want to pass it in a second time.
4950        I'm going to use a mortal in case the upstream filter croaks.  */
4951     upstream = ((SvOK(buf_sv) && sv_len(buf_sv)) || SvGMAGICAL(buf_sv))
4952         ? sv_newmortal() : buf_sv;
4953     SvUPGRADE(upstream, SVt_PV);
4954
4955     if (filter_has_file) {
4956         status = FILTER_READ(idx+1, upstream, 0);
4957     }
4958
4959     if (filter_sub && status >= 0) {
4960         dSP;
4961         int count;
4962
4963         ENTER_with_name("call_filter_sub");
4964         SAVE_DEFSV;
4965         SAVETMPS;
4966         EXTEND(SP, 2);
4967
4968         DEFSV_set(upstream);
4969         PUSHMARK(SP);
4970         mPUSHi(0);
4971         if (filter_state) {
4972             PUSHs(filter_state);
4973         }
4974         PUTBACK;
4975         count = call_sv(filter_sub, G_SCALAR);
4976         SPAGAIN;
4977
4978         if (count > 0) {
4979             SV *out = POPs;
4980             if (SvOK(out)) {
4981                 status = SvIV(out);
4982             }
4983         }
4984
4985         PUTBACK;
4986         FREETMPS;
4987         LEAVE_with_name("call_filter_sub");
4988     }
4989
4990     if(SvOK(upstream)) {
4991         got_p = SvPV(upstream, got_len);
4992         if (umaxlen) {
4993             if (got_len > umaxlen) {
4994                 prune_from = got_p + umaxlen;
4995             }
4996         } else {
4997             char *const first_nl = (char *)memchr(got_p, '\n', got_len);
4998             if (first_nl && first_nl + 1 < got_p + got_len) {
4999                 /* There's a second line here... */
5000                 prune_from = first_nl + 1;
5001             }
5002         }
5003     }
5004     if (prune_from) {
5005         /* Oh. Too long. Stuff some in our cache.  */
5006         STRLEN cached_len = got_p + got_len - prune_from;
5007         SV *const cache = datasv;
5008
5009         if (SvOK(cache)) {
5010             /* Cache should be empty.  */
5011             assert(!SvCUR(cache));
5012         }
5013
5014         sv_setpvn(cache, prune_from, cached_len);
5015         /* If you ask for block mode, you may well split UTF-8 characters.
5016            "If it breaks, you get to keep both parts"
5017            (Your code is broken if you  don't put them back together again
5018            before something notices.) */
5019         if (SvUTF8(upstream)) {
5020             SvUTF8_on(cache);
5021         }
5022         SvCUR_set(upstream, got_len - cached_len);
5023         *prune_from = 0;
5024         /* Can't yet be EOF  */
5025         if (status == 0)
5026             status = 1;
5027     }
5028
5029     /* If they are at EOF but buf_sv has something in it, then they may never
5030        have touched the SV upstream, so it may be undefined.  If we naively
5031        concatenate it then we get a warning about use of uninitialised value.
5032     */
5033     if (upstream != buf_sv && (SvOK(upstream) || SvGMAGICAL(upstream))) {
5034         sv_catsv(buf_sv, upstream);
5035     }
5036
5037     if (status <= 0) {
5038         IoLINES(datasv) = 0;
5039         if (filter_state) {
5040             SvREFCNT_dec(filter_state);
5041             IoTOP_GV(datasv) = NULL;
5042         }
5043         if (filter_sub) {
5044             SvREFCNT_dec(filter_sub);
5045             IoBOTTOM_GV(datasv) = NULL;
5046         }
5047         filter_del(S_run_user_filter);
5048     }
5049     if (status == 0 && read_from_cache) {
5050         /* If we read some data from the cache (and by getting here it implies
5051            that we emptied the cache) then we aren't yet at EOF, and mustn't
5052            report that to our caller.  */
5053         return 1;
5054     }
5055     return status;
5056 }
5057
5058 /* perhaps someone can come up with a better name for
5059    this?  it is not really "absolute", per se ... */
5060 static bool
5061 S_path_is_absolute(const char *name)
5062 {
5063     PERL_ARGS_ASSERT_PATH_IS_ABSOLUTE;
5064
5065     if (PERL_FILE_IS_ABSOLUTE(name)
5066 #ifdef WIN32
5067         || (*name == '.' && ((name[1] == '/' ||
5068                              (name[1] == '.' && name[2] == '/'))
5069                          || (name[1] == '\\' ||
5070                              ( name[1] == '.' && name[2] == '\\')))
5071             )
5072 #else
5073         || (*name == '.' && (name[1] == '/' ||
5074                              (name[1] == '.' && name[2] == '/')))
5075 #endif
5076          )
5077     {
5078         return TRUE;
5079     }
5080     else
5081         return FALSE;
5082 }
5083
5084 /*
5085  * Local variables:
5086  * c-indentation-style: bsd
5087  * c-basic-offset: 4
5088  * indent-tabs-mode: t
5089  * End:
5090  *
5091  * ex: set ts=8 sts=4 sw=4 noet:
5092  */