pp_ctl.c

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