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