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