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