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