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