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