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