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