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