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