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