pp_ctl.c

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