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 < 0)
2807             {
2808                 SvREFCNT_dec(cv);
2809                 DIE(aTHX_ "Can't goto subroutine outside a subroutine");
2810             }
2811             if (cxix < cxstack_ix)
2812                 dounwind(cxix);
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 PERL_UNUSED_DECL;
2871                 I32 gimme PERL_UNUSED_DECL;
2872                 const SSize_t items = AvFILLp(arg) + 1;
2873                 SV** mark;
2874
2875                 /* put GvAV(defgv) back onto stack */
2876                 EXTEND(SP, items+1); /* @_ could have been extended. */
2877                 Copy(AvARRAY(arg), SP + 1, items, SV*);
2878                 mark = SP;
2879                 SP += items;
2880                 if (AvREAL(arg)) {
2881                     I32 index;
2882                     for (index=0; index<items; index++)
2883                         SvREFCNT_inc_void(sv_2mortal(SP[-index]));
2884                 }
2885                 SvREFCNT_dec(arg);
2886                 if (CxTYPE(cx) == CXt_SUB && CxHASARGS(cx)) {
2887                     /* Restore old @_ */
2888                     arg = GvAV(PL_defgv);
2889                     GvAV(PL_defgv) = cx->blk_sub.savearray;
2890                     SvREFCNT_dec(arg);
2891                 }
2892
2893                 /* XS subs don't have a CxSUB, so pop it */
2894                 POPBLOCK(cx, PL_curpm);
2895                 /* Push a mark for the start of arglist */
2896                 PUSHMARK(mark);
2897                 PUTBACK;
2898                 (void)(*CvXSUB(cv))(aTHX_ cv);
2899                 LEAVE;
2900                 return retop;
2901             }
2902             else {
2903                 PADLIST * const padlist = CvPADLIST(cv);
2904                 cx->blk_sub.cv = cv;
2905                 cx->blk_sub.olddepth = CvDEPTH(cv);
2906
2907                 CvDEPTH(cv)++;
2908                 if (CvDEPTH(cv) < 2)
2909                     SvREFCNT_inc_simple_void_NN(cv);
2910                 else {
2911                     if (CvDEPTH(cv) == PERL_SUB_DEPTH_WARN && ckWARN(WARN_RECURSION))
2912                         sub_crush_depth(cv);
2913                     pad_push(padlist, CvDEPTH(cv));
2914                 }
2915                 PL_curcop = cx->blk_oldcop;
2916                 SAVECOMPPAD();
2917                 PAD_SET_CUR_NOSAVE(padlist, CvDEPTH(cv));
2918                 if (CxHASARGS(cx))
2919                 {
2920                     CX_CURPAD_SAVE(cx->blk_sub);
2921
2922                     /* cx->blk_sub.argarray has no reference count, so we
2923                        need something to hang on to our argument array so
2924                        that cx->blk_sub.argarray does not end up pointing
2925                        to freed memory as the result of undef *_.  So put
2926                        it in the callee’s pad, donating our refer-
2927                        ence count. */
2928                     SvREFCNT_dec(PAD_SVl(0));
2929                     PAD_SVl(0) = (SV *)(cx->blk_sub.argarray = arg);
2930
2931                     /* GvAV(PL_defgv) might have been modified on scope
2932                        exit, so restore it. */
2933                     if (arg != GvAV(PL_defgv)) {
2934                         AV * const av = GvAV(PL_defgv);
2935                         GvAV(PL_defgv) = (AV *)SvREFCNT_inc_simple(arg);
2936                         SvREFCNT_dec(av);
2937                     }
2938                 }
2939                 else SvREFCNT_dec(arg);
2940                 if (PERLDB_SUB) {       /* Checking curstash breaks DProf. */
2941                     Perl_get_db_sub(aTHX_ NULL, cv);
2942                     if (PERLDB_GOTO) {
2943                         CV * const gotocv = get_cvs("DB::goto", 0);
2944                         if (gotocv) {
2945                             PUSHMARK( PL_stack_sp );
2946                             call_sv(MUTABLE_SV(gotocv), G_SCALAR | G_NODEBUG);
2947                             PL_stack_sp--;
2948                         }
2949                     }
2950                 }
2951                 RETURNOP(CvSTART(cv));
2952             }
2953         }
2954         else {
2955             label       = SvPV_nomg_const(sv, label_len);
2956             label_flags = SvUTF8(sv);
2957         }
2958     }
2959     else if (!(PL_op->op_flags & OPf_SPECIAL)) {
2960         label       = cPVOP->op_pv;
2961         label_flags = (cPVOP->op_private & OPpPV_IS_UTF8) ? SVf_UTF8 : 0;
2962         label_len   = strlen(label);
2963     }
2964     if (!(do_dump || label_len)) DIE(aTHX_ must_have_label);
2965
2966     PERL_ASYNC_CHECK();
2967
2968     if (label_len) {
2969         OP *gotoprobe = NULL;
2970         bool leaving_eval = FALSE;
2971         bool in_block = FALSE;
2972         PERL_CONTEXT *last_eval_cx = NULL;
2973
2974         /* find label */
2975
2976         PL_lastgotoprobe = NULL;
2977         *enterops = 0;
2978         for (ix = cxstack_ix; ix >= 0; ix--) {
2979             cx = &cxstack[ix];
2980             switch (CxTYPE(cx)) {
2981             case CXt_EVAL:
2982                 leaving_eval = TRUE;
2983                 if (!CxTRYBLOCK(cx)) {
2984                     gotoprobe = (last_eval_cx ?
2985                                 last_eval_cx->blk_eval.old_eval_root :
2986                                 PL_eval_root);
2987                     last_eval_cx = cx;
2988                     break;
2989                 }
2990                 /* else fall through */
2991             case CXt_LOOP_LAZYIV:
2992             case CXt_LOOP_LAZYSV:
2993             case CXt_LOOP_FOR:
2994             case CXt_LOOP_PLAIN:
2995             case CXt_GIVEN:
2996             case CXt_WHEN:
2997                 gotoprobe = cx->blk_oldcop->op_sibling;
2998                 break;
2999             case CXt_SUBST:
3000                 continue;
3001             case CXt_BLOCK:
3002                 if (ix) {
3003                     gotoprobe = cx->blk_oldcop->op_sibling;
3004                     in_block = TRUE;
3005                 } else
3006                     gotoprobe = PL_main_root;
3007                 break;
3008             case CXt_SUB:
3009                 if (CvDEPTH(cx->blk_sub.cv) && !CxMULTICALL(cx)) {
3010                     gotoprobe = CvROOT(cx->blk_sub.cv);
3011                     break;
3012                 }
3013                 /* FALL THROUGH */
3014             case CXt_FORMAT:
3015             case CXt_NULL:
3016                 DIE(aTHX_ "Can't \"goto\" out of a pseudo block");
3017             default:
3018                 if (ix)
3019                     DIE(aTHX_ "panic: goto, type=%u, ix=%ld",
3020                         CxTYPE(cx), (long) ix);
3021                 gotoprobe = PL_main_root;
3022                 break;
3023             }
3024             if (gotoprobe) {
3025                 retop = dofindlabel(gotoprobe, label, label_len, label_flags,
3026                                     enterops, enterops + GOTO_DEPTH);
3027                 if (retop)
3028                     break;
3029                 if (gotoprobe->op_sibling &&
3030                         gotoprobe->op_sibling->op_type == OP_UNSTACK &&
3031                         gotoprobe->op_sibling->op_sibling) {
3032                     retop = dofindlabel(gotoprobe->op_sibling->op_sibling,
3033                                         label, label_len, label_flags, enterops,
3034                                         enterops + GOTO_DEPTH);
3035                     if (retop)
3036                         break;
3037                 }
3038             }
3039             PL_lastgotoprobe = gotoprobe;
3040         }
3041         if (!retop)
3042             DIE(aTHX_ "Can't find label %"SVf,
3043                             SVfARG(newSVpvn_flags(label, label_len,
3044                                         SVs_TEMP | label_flags)));
3045
3046         /* if we're leaving an eval, check before we pop any frames
3047            that we're not going to punt, otherwise the error
3048            won't be caught */
3049
3050         if (leaving_eval && *enterops && enterops[1]) {
3051             I32 i;
3052             for (i = 1; enterops[i]; i++)
3053                 if (enterops[i]->op_type == OP_ENTERITER)
3054                     DIE(aTHX_ "Can't \"goto\" into the middle of a foreach loop");
3055         }
3056
3057         if (*enterops && enterops[1]) {
3058             I32 i = enterops[1]->op_type == OP_ENTER && in_block ? 2 : 1;
3059             if (enterops[i])
3060                 deprecate("\"goto\" to jump into a construct");
3061         }
3062
3063         /* pop unwanted frames */
3064
3065         if (ix < cxstack_ix) {
3066             I32 oldsave;
3067
3068             if (ix < 0)
3069                 ix = 0;
3070             dounwind(ix);
3071             TOPBLOCK(cx);
3072             oldsave = PL_scopestack[PL_scopestack_ix];
3073             LEAVE_SCOPE(oldsave);
3074         }
3075
3076         /* push wanted frames */
3077
3078         if (*enterops && enterops[1]) {
3079             OP * const oldop = PL_op;
3080             ix = enterops[1]->op_type == OP_ENTER && in_block ? 2 : 1;
3081             for (; enterops[ix]; ix++) {
3082                 PL_op = enterops[ix];
3083                 /* Eventually we may want to stack the needed arguments
3084                  * for each op.  For now, we punt on the hard ones. */
3085                 if (PL_op->op_type == OP_ENTERITER)
3086                     DIE(aTHX_ "Can't \"goto\" into the middle of a foreach loop");
3087                 PL_op->op_ppaddr(aTHX);
3088             }
3089             PL_op = oldop;
3090         }
3091     }
3092
3093     if (do_dump) {
3094 #ifdef VMS
3095         if (!retop) retop = PL_main_start;
3096 #endif
3097         PL_restartop = retop;
3098         PL_do_undump = TRUE;
3099
3100         my_unexec();
3101
3102         PL_restartop = 0;               /* hmm, must be GNU unexec().. */
3103         PL_do_undump = FALSE;
3104     }
3105
3106     RETURNOP(retop);
3107 }
3108
3109 PP(pp_exit)
3110 {
3111     dVAR;
3112     dSP;
3113     I32 anum;
3114
3115     if (MAXARG < 1)
3116         anum = 0;
3117     else if (!TOPs) {
3118         anum = 0; (void)POPs;
3119     }
3120     else {
3121         anum = SvIVx(POPs);
3122 #ifdef VMS
3123         if (anum == 1 && (PL_op->op_private & OPpEXIT_VMSISH))
3124             anum = 0;
3125         VMSISH_HUSHED  = VMSISH_HUSHED || (PL_op->op_private & OPpHUSH_VMSISH);
3126 #endif
3127     }
3128     PL_exit_flags |= PERL_EXIT_EXPECTED;
3129 #ifdef PERL_MAD
3130     /* KLUDGE: disable exit 0 in BEGIN blocks when we're just compiling */
3131     if (anum || !(PL_minus_c && PL_madskills))
3132         my_exit(anum);
3133 #else
3134     my_exit(anum);
3135 #endif
3136     PUSHs(&PL_sv_undef);
3137     RETURN;
3138 }
3139
3140 /* Eval. */
3141
3142 STATIC void
3143 S_save_lines(pTHX_ AV *array, SV *sv)
3144 {
3145     const char *s = SvPVX_const(sv);
3146     const char * const send = SvPVX_const(sv) + SvCUR(sv);
3147     I32 line = 1;
3148
3149     PERL_ARGS_ASSERT_SAVE_LINES;
3150
3151     while (s && s < send) {
3152         const char *t;
3153         SV * const tmpstr = newSV_type(SVt_PVMG);
3154
3155         t = (const char *)memchr(s, '\n', send - s);
3156         if (t)
3157             t++;
3158         else
3159             t = send;
3160
3161         sv_setpvn(tmpstr, s, t - s);
3162         av_store(array, line++, tmpstr);
3163         s = t;
3164     }
3165 }
3166
3167 /*
3168 =for apidoc docatch
3169
3170 Check for the cases 0 or 3 of cur_env.je_ret, only used inside an eval context.
3171
3172 0 is used as continue inside eval,
3173
3174 3 is used for a die caught by an inner eval - continue inner loop
3175
3176 See cop.h: je_mustcatch, when set at any runlevel to TRUE, means eval ops must
3177 establish a local jmpenv to handle exception traps.
3178
3179 =cut
3180 */
3181 STATIC OP *
3182 S_docatch(pTHX_ OP *o)
3183 {
3184     dVAR;
3185     int ret;
3186     OP * const oldop = PL_op;
3187     dJMPENV;
3188
3189 #ifdef DEBUGGING
3190     assert(CATCH_GET == TRUE);
3191 #endif
3192     PL_op = o;
3193
3194     JMPENV_PUSH(ret);
3195     switch (ret) {
3196     case 0:
3197         assert(cxstack_ix >= 0);
3198         assert(CxTYPE(&cxstack[cxstack_ix]) == CXt_EVAL);
3199         cxstack[cxstack_ix].blk_eval.cur_top_env = PL_top_env;
3200  redo_body:
3201         CALLRUNOPS(aTHX);
3202         break;
3203     case 3:
3204         /* die caught by an inner eval - continue inner loop */
3205         if (PL_restartop && PL_restartjmpenv == PL_top_env) {
3206             PL_restartjmpenv = NULL;
3207             PL_op = PL_restartop;
3208             PL_restartop = 0;
3209             goto redo_body;
3210         }
3211         /* FALL THROUGH */
3212     default:
3213         JMPENV_POP;
3214         PL_op = oldop;
3215         JMPENV_JUMP(ret);
3216         assert(0); /* NOTREACHED */
3217     }
3218     JMPENV_POP;
3219     PL_op = oldop;
3220     return NULL;
3221 }
3222
3223
3224 /*
3225 =for apidoc find_runcv
3226
3227 Locate the CV corresponding to the currently executing sub or eval.
3228 If db_seqp is non_null, skip CVs that are in the DB package and populate
3229 *db_seqp with the cop sequence number at the point that the DB:: code was
3230 entered. (allows debuggers to eval in the scope of the breakpoint rather
3231 than in the scope of the debugger itself).
3232
3233 =cut
3234 */
3235
3236 CV*
3237 Perl_find_runcv(pTHX_ U32 *db_seqp)
3238 {
3239     return Perl_find_runcv_where(aTHX_ 0, 0, db_seqp);
3240 }
3241
3242 /* If this becomes part of the API, it might need a better name. */
3243 CV *
3244 Perl_find_runcv_where(pTHX_ U8 cond, IV arg, U32 *db_seqp)
3245 {
3246     dVAR;
3247     PERL_SI      *si;
3248     int          level = 0;
3249
3250     if (db_seqp)
3251         *db_seqp = PL_curcop->cop_seq;
3252     for (si = PL_curstackinfo; si; si = si->si_prev) {
3253         I32 ix;
3254         for (ix = si->si_cxix; ix >= 0; ix--) {
3255             const PERL_CONTEXT *cx = &(si->si_cxstack[ix]);
3256             CV *cv = NULL;
3257             if (CxTYPE(cx) == CXt_SUB || CxTYPE(cx) == CXt_FORMAT) {
3258                 cv = cx->blk_sub.cv;
3259                 /* skip DB:: code */
3260                 if (db_seqp && PL_debstash && CvSTASH(cv) == PL_debstash) {
3261                     *db_seqp = cx->blk_oldcop->cop_seq;
3262                     continue;
3263                 }
3264             }
3265             else if (CxTYPE(cx) == CXt_EVAL && !CxTRYBLOCK(cx))
3266                 cv = cx->blk_eval.cv;
3267             if (cv) {
3268                 switch (cond) {
3269                 case FIND_RUNCV_padid_eq:
3270                     if (!CvPADLIST(cv)
3271                      || PadlistNAMES(CvPADLIST(cv)) != INT2PTR(PADNAMELIST *, arg))
3272                         continue;
3273                     return cv;
3274                 case FIND_RUNCV_level_eq:
3275                     if (level++ != arg) continue;
3276                     /* GERONIMO! */
3277                 default:
3278                     return cv;
3279                 }
3280             }
3281         }
3282     }
3283     return cond == FIND_RUNCV_padid_eq ? NULL : PL_main_cv;
3284 }
3285
3286
3287 /* Run yyparse() in a setjmp wrapper. Returns:
3288  *   0: yyparse() successful
3289  *   1: yyparse() failed
3290  *   3: yyparse() died
3291  */
3292 STATIC int
3293 S_try_yyparse(pTHX_ int gramtype)
3294 {
3295     int ret;
3296     dJMPENV;
3297
3298     assert(CxTYPE(&cxstack[cxstack_ix]) == CXt_EVAL);
3299     JMPENV_PUSH(ret);
3300     switch (ret) {
3301     case 0:
3302         ret = yyparse(gramtype) ? 1 : 0;
3303         break;
3304     case 3:
3305         break;
3306     default:
3307         JMPENV_POP;
3308         JMPENV_JUMP(ret);
3309         assert(0); /* NOTREACHED */
3310     }
3311     JMPENV_POP;
3312     return ret;
3313 }
3314
3315
3316 /* Compile a require/do or an eval ''.
3317  *
3318  * outside is the lexically enclosing CV (if any) that invoked us.
3319  * seq     is the current COP scope value.
3320  * hh      is the saved hints hash, if any.
3321  *
3322  * Returns a bool indicating whether the compile was successful; if so,
3323  * PL_eval_start contains the first op of the compiled code; otherwise,
3324  * pushes undef.
3325  *
3326  * This function is called from two places: pp_require and pp_entereval.
3327  * These can be distinguished by whether PL_op is entereval.
3328  */
3329
3330 STATIC bool
3331 S_doeval(pTHX_ int gimme, CV* outside, U32 seq, HV *hh)
3332 {
3333     dVAR; dSP;
3334     OP * const saveop = PL_op;
3335     bool clear_hints = saveop->op_type != OP_ENTEREVAL;
3336     COP * const oldcurcop = PL_curcop;
3337     bool in_require = (saveop->op_type == OP_REQUIRE);
3338     int yystatus;
3339     CV *evalcv;
3340
3341     PL_in_eval = (in_require
3342                   ? (EVAL_INREQUIRE | (PL_in_eval & EVAL_INEVAL))
3343                   : EVAL_INEVAL);
3344
3345     PUSHMARK(SP);
3346
3347     evalcv = MUTABLE_CV(newSV_type(SVt_PVCV));
3348     CvEVAL_on(evalcv);
3349     assert(CxTYPE(&cxstack[cxstack_ix]) == CXt_EVAL);
3350     cxstack[cxstack_ix].blk_eval.cv = evalcv;
3351     cxstack[cxstack_ix].blk_gimme = gimme;
3352
3353     CvOUTSIDE_SEQ(evalcv) = seq;
3354     CvOUTSIDE(evalcv) = MUTABLE_CV(SvREFCNT_inc_simple(outside));
3355
3356     /* set up a scratch pad */
3357
3358     CvPADLIST(evalcv) = pad_new(padnew_SAVE);
3359     PL_op = NULL; /* avoid PL_op and PL_curpad referring to different CVs */
3360
3361
3362     if (!PL_madskills)
3363         SAVEMORTALIZESV(evalcv);        /* must remain until end of current statement */
3364
3365     /* make sure we compile in the right package */
3366
3367     if (CopSTASH_ne(PL_curcop, PL_curstash)) {
3368         SAVEGENERICSV(PL_curstash);
3369         PL_curstash = (HV *)SvREFCNT_inc_simple(CopSTASH(PL_curcop));
3370     }
3371     /* XXX:ajgo do we really need to alloc an AV for begin/checkunit */
3372     SAVESPTR(PL_beginav);
3373     PL_beginav = newAV();
3374     SAVEFREESV(PL_beginav);
3375     SAVESPTR(PL_unitcheckav);
3376     PL_unitcheckav = newAV();
3377     SAVEFREESV(PL_unitcheckav);
3378
3379 #ifdef PERL_MAD
3380     SAVEBOOL(PL_madskills);
3381     PL_madskills = 0;
3382 #endif
3383
3384     ENTER_with_name("evalcomp");
3385     SAVESPTR(PL_compcv);
3386     PL_compcv = evalcv;
3387
3388     /* try to compile it */
3389
3390     PL_eval_root = NULL;
3391     PL_curcop = &PL_compiling;
3392     if ((saveop->op_type != OP_REQUIRE) && (saveop->op_flags & OPf_SPECIAL))
3393         PL_in_eval |= EVAL_KEEPERR;
3394     else
3395         CLEAR_ERRSV();
3396
3397     SAVEHINTS();
3398     if (clear_hints) {
3399         PL_hints = 0;
3400         hv_clear(GvHV(PL_hintgv));
3401     }
3402     else {
3403         PL_hints = saveop->op_private & OPpEVAL_COPHH
3404                      ? oldcurcop->cop_hints : saveop->op_targ;
3405         if (hh) {
3406             /* SAVEHINTS created a new HV in PL_hintgv, which we need to GC */
3407             SvREFCNT_dec(GvHV(PL_hintgv));
3408             GvHV(PL_hintgv) = hh;
3409         }
3410     }
3411     SAVECOMPILEWARNINGS();
3412     if (clear_hints) {
3413         if (PL_dowarn & G_WARN_ALL_ON)
3414             PL_compiling.cop_warnings = pWARN_ALL ;
3415         else if (PL_dowarn & G_WARN_ALL_OFF)
3416             PL_compiling.cop_warnings = pWARN_NONE ;
3417         else
3418             PL_compiling.cop_warnings = pWARN_STD ;
3419     }
3420     else {
3421         PL_compiling.cop_warnings =
3422             DUP_WARNINGS(oldcurcop->cop_warnings);
3423         cophh_free(CopHINTHASH_get(&PL_compiling));
3424         if (Perl_cop_fetch_label(aTHX_ oldcurcop, NULL, NULL)) {
3425             /* The label, if present, is the first entry on the chain. So rather
3426                than writing a blank label in front of it (which involves an
3427                allocation), just use the next entry in the chain.  */
3428             PL_compiling.cop_hints_hash
3429                 = cophh_copy(oldcurcop->cop_hints_hash->refcounted_he_next);
3430             /* Check the assumption that this removed the label.  */
3431             assert(Perl_cop_fetch_label(aTHX_ &PL_compiling, NULL, NULL) == NULL);
3432         }
3433         else
3434             PL_compiling.cop_hints_hash = cophh_copy(oldcurcop->cop_hints_hash);
3435     }
3436
3437     CALL_BLOCK_HOOKS(bhk_eval, saveop);
3438
3439     /* note that yyparse() may raise an exception, e.g. C<BEGIN{die}>,
3440      * so honour CATCH_GET and trap it here if necessary */
3441
3442     yystatus = (!in_require && CATCH_GET) ? S_try_yyparse(aTHX_ GRAMPROG) : yyparse(GRAMPROG);
3443
3444     if (yystatus || PL_parser->error_count || !PL_eval_root) {
3445         SV **newsp;                     /* Used by POPBLOCK. */
3446         PERL_CONTEXT *cx;
3447         I32 optype;                     /* Used by POPEVAL. */
3448         SV *namesv;
3449         SV *errsv = NULL;
3450
3451         cx = NULL;
3452         namesv = NULL;
3453         PERL_UNUSED_VAR(newsp);
3454         PERL_UNUSED_VAR(optype);
3455
3456         /* note that if yystatus == 3, then the EVAL CX block has already
3457          * been popped, and various vars restored */
3458         PL_op = saveop;
3459         if (yystatus != 3) {
3460             if (PL_eval_root) {
3461                 op_free(PL_eval_root);
3462                 PL_eval_root = NULL;
3463             }
3464             SP = PL_stack_base + POPMARK;       /* pop original mark */
3465             POPBLOCK(cx,PL_curpm);
3466             POPEVAL(cx);
3467             namesv = cx->blk_eval.old_namesv;
3468             /* POPBLOCK renders LEAVE_with_name("evalcomp") unnecessary. */
3469             LEAVE_with_name("eval"); /* pp_entereval knows about this LEAVE.  */
3470         }
3471
3472         errsv = ERRSV;
3473         if (in_require) {
3474             if (!cx) {
3475                 /* If cx is still NULL, it means that we didn't go in the
3476                  * POPEVAL branch. */
3477                 cx = &cxstack[cxstack_ix];
3478                 assert(CxTYPE(cx) == CXt_EVAL);
3479                 namesv = cx->blk_eval.old_namesv;
3480             }
3481             (void)hv_store(GvHVn(PL_incgv),
3482                            SvPVX_const(namesv),
3483                            SvUTF8(namesv) ? -(I32)SvCUR(namesv) : (I32)SvCUR(namesv),
3484                            &PL_sv_undef, 0);
3485             Perl_croak(aTHX_ "%"SVf"Compilation failed in require",
3486                        SVfARG(errsv
3487                                 ? errsv
3488                                 : newSVpvs_flags("Unknown error\n", SVs_TEMP)));
3489         }
3490         else {
3491             if (!*(SvPV_nolen_const(errsv))) {
3492                 sv_setpvs(errsv, "Compilation error");
3493             }
3494         }
3495         if (gimme != G_ARRAY) PUSHs(&PL_sv_undef);
3496         PUTBACK;
3497         return FALSE;
3498     }
3499     else
3500         LEAVE_with_name("evalcomp");
3501
3502     CopLINE_set(&PL_compiling, 0);
3503     SAVEFREEOP(PL_eval_root);
3504     cv_forget_slab(evalcv);
3505
3506     DEBUG_x(dump_eval());
3507
3508     /* Register with debugger: */
3509     if (PERLDB_INTER && saveop->op_type == OP_REQUIRE) {
3510         CV * const cv = get_cvs("DB::postponed", 0);
3511         if (cv) {
3512             dSP;
3513             PUSHMARK(SP);
3514             XPUSHs(MUTABLE_SV(CopFILEGV(&PL_compiling)));
3515             PUTBACK;
3516             call_sv(MUTABLE_SV(cv), G_DISCARD);
3517         }
3518     }
3519
3520     if (PL_unitcheckav) {
3521         OP *es = PL_eval_start;
3522         call_list(PL_scopestack_ix, PL_unitcheckav);
3523         PL_eval_start = es;
3524     }
3525
3526     /* compiled okay, so do it */
3527
3528     CvDEPTH(evalcv) = 1;
3529     SP = PL_stack_base + POPMARK;               /* pop original mark */
3530     PL_op = saveop;                     /* The caller may need it. */
3531     PL_parser->lex_state = LEX_NOTPARSING;      /* $^S needs this. */
3532
3533     PUTBACK;
3534     return TRUE;
3535 }
3536
3537 STATIC PerlIO *
3538 S_check_type_and_open(pTHX_ SV *name)
3539 {
3540     Stat_t st;
3541     const char *p = SvPV_nolen_const(name);
3542     const int st_rc = PerlLIO_stat(p, &st);
3543
3544     PERL_ARGS_ASSERT_CHECK_TYPE_AND_OPEN;
3545
3546     if (st_rc < 0 || S_ISDIR(st.st_mode) || S_ISBLK(st.st_mode)) {
3547         return NULL;
3548     }
3549
3550 #if !defined(PERLIO_IS_STDIO) && !defined(USE_SFIO)
3551     return PerlIO_openn(aTHX_ ":", PERL_SCRIPT_MODE, -1, 0, 0, NULL, 1, &name);
3552 #else
3553     return PerlIO_open(p, PERL_SCRIPT_MODE);
3554 #endif
3555 }
3556
3557 #ifndef PERL_DISABLE_PMC
3558 STATIC PerlIO *
3559 S_doopen_pm(pTHX_ SV *name)
3560 {
3561     STRLEN namelen;
3562     const char *p = SvPV_const(name, namelen);
3563
3564     PERL_ARGS_ASSERT_DOOPEN_PM;
3565
3566     if (namelen > 3 && memEQs(p + namelen - 3, 3, ".pm")) {
3567         SV *const pmcsv = sv_newmortal();
3568         Stat_t pmcstat;
3569
3570         SvSetSV_nosteal(pmcsv,name);
3571         sv_catpvn(pmcsv, "c", 1);
3572
3573         if (PerlLIO_stat(SvPV_nolen_const(pmcsv), &pmcstat) >= 0)
3574             return check_type_and_open(pmcsv);
3575     }
3576     return check_type_and_open(name);
3577 }
3578 #else
3579 #  define doopen_pm(name) check_type_and_open(name)
3580 #endif /* !PERL_DISABLE_PMC */
3581
3582 PP(pp_require)
3583 {
3584     dVAR; dSP;
3585     PERL_CONTEXT *cx;
3586     SV *sv;
3587     const char *name;
3588     STRLEN len;
3589     char * unixname;
3590     STRLEN unixlen;
3591 #ifdef VMS
3592     int vms_unixname = 0;
3593     char *unixnamebuf;
3594     char *unixdir;
3595     char *unixdirbuf;
3596 #endif
3597     const char *tryname = NULL;
3598     SV *namesv = NULL;
3599     const I32 gimme = GIMME_V;
3600     int filter_has_file = 0;
3601     PerlIO *tryrsfp = NULL;
3602     SV *filter_cache = NULL;
3603     SV *filter_state = NULL;
3604     SV *filter_sub = NULL;
3605     SV *hook_sv = NULL;
3606     SV *encoding;
3607     OP *op;
3608     int saved_errno;
3609
3610     sv = POPs;
3611     if ( (SvNIOKp(sv) || SvVOK(sv)) && PL_op->op_type != OP_DOFILE) {
3612         sv = sv_2mortal(new_version(sv));
3613         if (!Perl_sv_derived_from_pvn(aTHX_ PL_patchlevel, STR_WITH_LEN("version"), 0))
3614             upg_version(PL_patchlevel, TRUE);
3615         if (cUNOP->op_first->op_type == OP_CONST && cUNOP->op_first->op_private & OPpCONST_NOVER) {
3616             if ( vcmp(sv,PL_patchlevel) <= 0 )
3617                 DIE(aTHX_ "Perls since %"SVf" too modern--this is %"SVf", stopped",
3618                     SVfARG(sv_2mortal(vnormal(sv))),
3619                     SVfARG(sv_2mortal(vnormal(PL_patchlevel)))
3620                 );
3621         }
3622         else {
3623             if ( vcmp(sv,PL_patchlevel) > 0 ) {
3624                 I32 first = 0;
3625                 AV *lav;
3626                 SV * const req = SvRV(sv);
3627                 SV * const pv = *hv_fetchs(MUTABLE_HV(req), "original", FALSE);
3628
3629                 /* get the left hand term */
3630                 lav = MUTABLE_AV(SvRV(*hv_fetchs(MUTABLE_HV(req), "version", FALSE)));
3631
3632                 first  = SvIV(*av_fetch(lav,0,0));
3633                 if (   first > (int)PERL_REVISION    /* probably 'use 6.0' */
3634                     || hv_exists(MUTABLE_HV(req), "qv", 2 ) /* qv style */
3635                     || av_len(lav) > 1               /* FP with > 3 digits */
3636                     || strstr(SvPVX(pv),".0")        /* FP with leading 0 */
3637                    ) {
3638                     DIE(aTHX_ "Perl %"SVf" required--this is only "
3639                         "%"SVf", stopped",
3640                         SVfARG(sv_2mortal(vnormal(req))),
3641                         SVfARG(sv_2mortal(vnormal(PL_patchlevel)))
3642                     );
3643                 }
3644                 else { /* probably 'use 5.10' or 'use 5.8' */
3645                     SV *hintsv;
3646                     I32 second = 0;
3647
3648                     if (av_len(lav)>=1)
3649                         second = SvIV(*av_fetch(lav,1,0));
3650
3651                     second /= second >= 600  ? 100 : 10;
3652                     hintsv = Perl_newSVpvf(aTHX_ "v%d.%d.0",
3653                                            (int)first, (int)second);
3654                     upg_version(hintsv, TRUE);
3655
3656                     DIE(aTHX_ "Perl %"SVf" required (did you mean %"SVf"?)"
3657                         "--this is only %"SVf", stopped",
3658                         SVfARG(sv_2mortal(vnormal(req))),
3659                         SVfARG(sv_2mortal(vnormal(sv_2mortal(hintsv)))),
3660                         SVfARG(sv_2mortal(vnormal(PL_patchlevel)))
3661                     );
3662                 }
3663             }
3664         }
3665
3666         RETPUSHYES;
3667     }
3668     name = SvPV_const(sv, len);
3669     if (!(name && len > 0 && *name))
3670         DIE(aTHX_ "Null filename used");
3671     TAINT_PROPER("require");
3672
3673
3674 #ifdef VMS
3675     /* The key in the %ENV hash is in the syntax of file passed as the argument
3676      * usually this is in UNIX format, but sometimes in VMS format, which
3677      * can result in a module being pulled in more than once.
3678      * To prevent this, the key must be stored in UNIX format if the VMS
3679      * name can be translated to UNIX.
3680      */
3681
3682     if ((unixnamebuf = SvPVX(sv_2mortal(newSVpv("", VMS_MAXRSS-1))))
3683         && (unixname = tounixspec(name, unixnamebuf)) != NULL) {
3684         unixlen = strlen(unixname);
3685         vms_unixname = 1;
3686     }
3687     else
3688 #endif
3689     {
3690         /* if not VMS or VMS name can not be translated to UNIX, pass it
3691          * through.
3692          */
3693         unixname = (char *) name;
3694         unixlen = len;
3695     }
3696     if (PL_op->op_type == OP_REQUIRE) {
3697         SV * const * const svp = hv_fetch(GvHVn(PL_incgv),
3698                                           unixname, unixlen, 0);
3699         if ( svp ) {
3700             if (*svp != &PL_sv_undef)
3701                 RETPUSHYES;
3702             else
3703                 DIE(aTHX_ "Attempt to reload %s aborted.\n"
3704                             "Compilation failed in require", unixname);
3705         }
3706     }
3707
3708     LOADING_FILE_PROBE(unixname);
3709
3710     /* prepare to compile file */
3711
3712     if (path_is_absolute(name)) {
3713         /* At this point, name is SvPVX(sv)  */
3714         tryname = name;
3715         tryrsfp = doopen_pm(sv);
3716     }
3717     if (!tryrsfp && !(errno == EACCES && path_is_absolute(name))) {
3718         AV * const ar = GvAVn(PL_incgv);
3719         I32 i;
3720 #ifdef VMS
3721         if (vms_unixname)
3722 #endif
3723         {
3724             namesv = newSV_type(SVt_PV);
3725             for (i = 0; i <= AvFILL(ar); i++) {
3726                 SV * const dirsv = *av_fetch(ar, i, TRUE);
3727
3728                 if (SvTIED_mg((const SV *)ar, PERL_MAGIC_tied))
3729                     mg_get(dirsv);
3730                 if (SvROK(dirsv)) {
3731                     int count;
3732                     SV **svp;
3733                     SV *loader = dirsv;
3734
3735                     if (SvTYPE(SvRV(loader)) == SVt_PVAV
3736                         && !sv_isobject(loader))
3737                     {
3738                         loader = *av_fetch(MUTABLE_AV(SvRV(loader)), 0, TRUE);
3739                     }
3740
3741                     Perl_sv_setpvf(aTHX_ namesv, "/loader/0x%"UVxf"/%s",
3742                                    PTR2UV(SvRV(dirsv)), name);
3743                     tryname = SvPVX_const(namesv);
3744                     tryrsfp = NULL;
3745
3746                     ENTER_with_name("call_INC");
3747                     SAVETMPS;
3748                     EXTEND(SP, 2);
3749
3750                     PUSHMARK(SP);
3751                     PUSHs(dirsv);
3752                     PUSHs(sv);
3753                     PUTBACK;
3754                     if (sv_isobject(loader))
3755                         count = call_method("INC", G_ARRAY);
3756                     else
3757                         count = call_sv(loader, G_ARRAY);
3758                     SPAGAIN;
3759
3760                     if (count > 0) {
3761                         int i = 0;
3762                         SV *arg;
3763
3764                         SP -= count - 1;
3765                         arg = SP[i++];
3766
3767                         if (SvROK(arg) && (SvTYPE(SvRV(arg)) <= SVt_PVLV)
3768                             && !isGV_with_GP(SvRV(arg))) {
3769                             filter_cache = SvRV(arg);
3770                             SvREFCNT_inc_simple_void_NN(filter_cache);
3771
3772                             if (i < count) {
3773                                 arg = SP[i++];
3774                             }
3775                         }
3776
3777                         if (SvROK(arg) && isGV_with_GP(SvRV(arg))) {
3778                             arg = SvRV(arg);
3779                         }
3780
3781                         if (isGV_with_GP(arg)) {
3782                             IO * const io = GvIO((const GV *)arg);
3783
3784                             ++filter_has_file;
3785
3786                             if (io) {
3787                                 tryrsfp = IoIFP(io);
3788                                 if (IoOFP(io) && IoOFP(io) != IoIFP(io)) {
3789                                     PerlIO_close(IoOFP(io));
3790                                 }
3791                                 IoIFP(io) = NULL;
3792                                 IoOFP(io) = NULL;
3793                             }
3794
3795                             if (i < count) {
3796                                 arg = SP[i++];
3797                             }
3798                         }
3799
3800                         if (SvROK(arg) && SvTYPE(SvRV(arg)) == SVt_PVCV) {
3801                             filter_sub = arg;
3802                             SvREFCNT_inc_simple_void_NN(filter_sub);
3803
3804                             if (i < count) {
3805                                 filter_state = SP[i];
3806                                 SvREFCNT_inc_simple_void(filter_state);
3807                             }
3808                         }
3809
3810                         if (!tryrsfp && (filter_cache || filter_sub)) {
3811                             tryrsfp = PerlIO_open(BIT_BUCKET,
3812                                                   PERL_SCRIPT_MODE);
3813                         }
3814                         SP--;
3815                     }
3816
3817                     PUTBACK;
3818                     FREETMPS;
3819                     LEAVE_with_name("call_INC");
3820
3821                     /* Adjust file name if the hook has set an %INC entry.
3822                        This needs to happen after the FREETMPS above.  */
3823                     svp = hv_fetch(GvHVn(PL_incgv), name, len, 0);
3824                     if (svp)
3825                         tryname = SvPV_nolen_const(*svp);
3826
3827                     if (tryrsfp) {
3828                         hook_sv = dirsv;
3829                         break;
3830                     }
3831
3832                     filter_has_file = 0;
3833                     if (filter_cache) {
3834                         SvREFCNT_dec(filter_cache);
3835                         filter_cache = NULL;
3836                     }
3837                     if (filter_state) {
3838                         SvREFCNT_dec(filter_state);
3839                         filter_state = NULL;
3840                     }
3841                     if (filter_sub) {
3842                         SvREFCNT_dec(filter_sub);
3843                         filter_sub = NULL;
3844                     }
3845                 }
3846                 else {
3847                   if (!path_is_absolute(name)
3848                   ) {
3849                     const char *dir;
3850                     STRLEN dirlen;
3851
3852                     if (SvOK(dirsv)) {
3853                         dir = SvPV_const(dirsv, dirlen);
3854                     } else {
3855                         dir = "";
3856                         dirlen = 0;
3857                     }
3858
3859 #ifdef VMS
3860                     if (((unixdirbuf = SvPVX(sv_2mortal(newSVpv("", VMS_MAXRSS-1)))) == NULL)
3861                         || ((unixdir = tounixpath(dir, unixdirbuf)) == NULL))
3862                         continue;
3863                     sv_setpv(namesv, unixdir);
3864                     sv_catpv(namesv, unixname);
3865 #else
3866 #  ifdef __SYMBIAN32__
3867                     if (PL_origfilename[0] &&
3868                         PL_origfilename[1] == ':' &&
3869                         !(dir[0] && dir[1] == ':'))
3870                         Perl_sv_setpvf(aTHX_ namesv,
3871                                        "%c:%s\\%s",
3872                                        PL_origfilename[0],
3873                                        dir, name);
3874                     else
3875                         Perl_sv_setpvf(aTHX_ namesv,
3876                                        "%s\\%s",
3877                                        dir, name);
3878 #  else
3879                     /* The equivalent of
3880                        Perl_sv_setpvf(aTHX_ namesv, "%s/%s", dir, name);
3881                        but without the need to parse the format string, or
3882                        call strlen on either pointer, and with the correct
3883                        allocation up front.  */
3884                     {
3885                         char *tmp = SvGROW(namesv, dirlen + len + 2);
3886
3887                         memcpy(tmp, dir, dirlen);
3888                         tmp +=dirlen;
3889                         *tmp++ = '/';
3890                         /* name came from an SV, so it will have a '\0' at the
3891                            end that we can copy as part of this memcpy().  */
3892                         memcpy(tmp, name, len + 1);
3893
3894                         SvCUR_set(namesv, dirlen + len + 1);
3895                         SvPOK_on(namesv);
3896                     }
3897 #  endif
3898 #endif
3899                     TAINT_PROPER("require");
3900                     tryname = SvPVX_const(namesv);
3901                     tryrsfp = doopen_pm(namesv);
3902                     if (tryrsfp) {
3903                         if (tryname[0] == '.' && tryname[1] == '/') {
3904                             ++tryname;
3905                             while (*++tryname == '/');
3906                         }
3907                         break;
3908                     }
3909                     else if (errno == EMFILE || errno == EACCES) {
3910                         /* no point in trying other paths if out of handles;
3911                          * on the other hand, if we couldn't open one of the
3912                          * files, then going on with the search could lead to
3913                          * unexpected results; see perl #113422
3914                          */
3915                         break;
3916                     }
3917                   }
3918                 }
3919             }
3920         }
3921     }
3922     saved_errno = errno; /* sv_2mortal can realloc things */
3923     sv_2mortal(namesv);
3924     if (!tryrsfp) {
3925         if (PL_op->op_type == OP_REQUIRE) {
3926             if(saved_errno == EMFILE || saved_errno == EACCES) {
3927                 /* diag_listed_as: Can't locate %s */
3928                 DIE(aTHX_ "Can't locate %s:   %s", name, Strerror(saved_errno));
3929             } else {
3930                 if (namesv) {                   /* did we lookup @INC? */
3931                     AV * const ar = GvAVn(PL_incgv);
3932                     I32 i;
3933                     SV *const msg = newSVpvs_flags("", SVs_TEMP);
3934                     SV *const inc = newSVpvs_flags("", SVs_TEMP);
3935                     for (i = 0; i <= AvFILL(ar); i++) {
3936                         sv_catpvs(inc, " ");
3937                         sv_catsv(inc, *av_fetch(ar, i, TRUE));
3938                     }
3939                     if (len >= 4 && memEQ(name + len - 3, ".pm", 4)) {
3940                         const char *c, *e = name + len - 3;
3941                         sv_catpv(msg, " (you may need to install the ");
3942                         for (c = name; c < e; c++) {
3943                             if (*c == '/') {
3944                                 sv_catpvn(msg, "::", 2);
3945                             }
3946                             else {
3947                                 sv_catpvn(msg, c, 1);
3948                             }
3949                         }
3950                         sv_catpv(msg, " module)");
3951                     }
3952                     else if (len >= 2 && memEQ(name + len - 2, ".h", 3)) {
3953                         sv_catpv(msg, " (change .h to .ph maybe?) (did you run h2ph?)");
3954                     }
3955                     else if (len >= 3 && memEQ(name + len - 3, ".ph", 4)) {
3956                         sv_catpv(msg, " (did you run h2ph?)");
3957                     }
3958
3959                     /* diag_listed_as: Can't locate %s */
3960                     DIE(aTHX_
3961                         "Can't locate %s in @INC%" SVf " (@INC contains:%" SVf ")",
3962                         name, msg, inc);
3963                 }
3964             }
3965             DIE(aTHX_ "Can't locate %s", name);
3966         }
3967
3968         CLEAR_ERRSV();
3969         RETPUSHUNDEF;
3970     }
3971     else
3972         SETERRNO(0, SS_NORMAL);
3973
3974     /* Assume success here to prevent recursive requirement. */
3975     /* name is never assigned to again, so len is still strlen(name)  */
3976     /* Check whether a hook in @INC has already filled %INC */
3977     if (!hook_sv) {
3978         (void)hv_store(GvHVn(PL_incgv),
3979                        unixname, unixlen, newSVpv(tryname,0),0);
3980     } else {
3981         SV** const svp = hv_fetch(GvHVn(PL_incgv), unixname, unixlen, 0);
3982         if (!svp)
3983             (void)hv_store(GvHVn(PL_incgv),
3984                            unixname, unixlen, SvREFCNT_inc_simple(hook_sv), 0 );
3985     }
3986
3987     ENTER_with_name("eval");
3988     SAVETMPS;
3989     SAVECOPFILE_FREE(&PL_compiling);
3990     CopFILE_set(&PL_compiling, tryname);
3991     lex_start(NULL, tryrsfp, 0);
3992
3993     if (filter_sub || filter_cache) {
3994         /* We can use the SvPV of the filter PVIO itself as our cache, rather
3995            than hanging another SV from it. In turn, filter_add() optionally
3996            takes the SV to use as the filter (or creates a new SV if passed
3997            NULL), so simply pass in whatever value filter_cache has.  */
3998         SV * const datasv = filter_add(S_run_user_filter, filter_cache);
3999         IoLINES(datasv) = filter_has_file;
4000         IoTOP_GV(datasv) = MUTABLE_GV(filter_state);
4001         IoBOTTOM_GV(datasv) = MUTABLE_GV(filter_sub);
4002     }
4003
4004     /* switch to eval mode */
4005     PUSHBLOCK(cx, CXt_EVAL, SP);
4006     PUSHEVAL(cx, name);
4007     cx->blk_eval.retop = PL_op->op_next;
4008
4009     SAVECOPLINE(&PL_compiling);
4010     CopLINE_set(&PL_compiling, 0);
4011
4012     PUTBACK;
4013
4014     /* Store and reset encoding. */
4015     encoding = PL_encoding;
4016     PL_encoding = NULL;
4017
4018     if (doeval(gimme, NULL, PL_curcop->cop_seq, NULL))
4019         op = DOCATCH(PL_eval_start);
4020     else
4021         op = PL_op->op_next;
4022
4023     /* Restore encoding. */
4024     PL_encoding = encoding;
4025
4026     LOADED_FILE_PROBE(unixname);
4027
4028     return op;
4029 }
4030
4031 /* This is a op added to hold the hints hash for
4032    pp_entereval. The hash can be modified by the code
4033    being eval'ed, so we return a copy instead. */
4034
4035 PP(pp_hintseval)
4036 {
4037     dVAR;
4038     dSP;
4039     mXPUSHs(MUTABLE_SV(hv_copy_hints_hv(MUTABLE_HV(cSVOP_sv))));
4040     RETURN;
4041 }
4042
4043
4044 PP(pp_entereval)
4045 {
4046     dVAR; dSP;
4047     PERL_CONTEXT *cx;
4048     SV *sv;
4049     const I32 gimme = GIMME_V;
4050     const U32 was = PL_breakable_sub_gen;
4051     char tbuf[TYPE_DIGITS(long) + 12];
4052     bool saved_delete = FALSE;
4053     char *tmpbuf = tbuf;
4054     STRLEN len;
4055     CV* runcv;
4056     U32 seq, lex_flags = 0;
4057     HV *saved_hh = NULL;
4058     const bool bytes = PL_op->op_private & OPpEVAL_BYTES;
4059
4060     if (PL_op->op_private & OPpEVAL_HAS_HH) {
4061         saved_hh = MUTABLE_HV(SvREFCNT_inc(POPs));
4062     }
4063     else if (PL_hints & HINT_LOCALIZE_HH || (
4064                 PL_op->op_private & OPpEVAL_COPHH
4065              && PL_curcop->cop_hints & HINT_LOCALIZE_HH
4066             )) {
4067         saved_hh = cop_hints_2hv(PL_curcop, 0);
4068         hv_magic(saved_hh, NULL, PERL_MAGIC_hints);
4069     }
4070     sv = POPs;
4071     if (!SvPOK(sv)) {
4072         /* make sure we've got a plain PV (no overload etc) before testing
4073          * for taint. Making a copy here is probably overkill, but better
4074          * safe than sorry */
4075         STRLEN len;
4076         const char * const p = SvPV_const(sv, len);
4077
4078         sv = newSVpvn_flags(p, len, SVs_TEMP | SvUTF8(sv));
4079         lex_flags |= LEX_START_COPIED;
4080
4081         if (bytes && SvUTF8(sv))
4082             SvPVbyte_force(sv, len);
4083     }
4084     else if (bytes && SvUTF8(sv)) {
4085         /* Don't modify someone else's scalar */
4086         STRLEN len;
4087         sv = newSVsv(sv);
4088         (void)sv_2mortal(sv);
4089         SvPVbyte_force(sv,len);
4090         lex_flags |= LEX_START_COPIED;
4091     }
4092
4093     TAINT_IF(SvTAINTED(sv));
4094     TAINT_PROPER("eval");
4095
4096     ENTER_with_name("eval");
4097     lex_start(sv, NULL, lex_flags | (PL_op->op_private & OPpEVAL_UNICODE
4098                            ? LEX_IGNORE_UTF8_HINTS
4099                            : bytes ? LEX_EVALBYTES : LEX_START_SAME_FILTER
4100                         )
4101              );
4102     SAVETMPS;
4103
4104     /* switch to eval mode */
4105
4106     if (PERLDB_NAMEEVAL && CopLINE(PL_curcop)) {
4107         SV * const temp_sv = sv_newmortal();
4108         Perl_sv_setpvf(aTHX_ temp_sv, "_<(eval %lu)[%s:%"IVdf"]",
4109                        (unsigned long)++PL_evalseq,
4110                        CopFILE(PL_curcop), (IV)CopLINE(PL_curcop));
4111         tmpbuf = SvPVX(temp_sv);
4112         len = SvCUR(temp_sv);
4113     }
4114     else
4115         len = my_snprintf(tmpbuf, sizeof(tbuf), "_<(eval %lu)", (unsigned long)++PL_evalseq);
4116     SAVECOPFILE_FREE(&PL_compiling);
4117     CopFILE_set(&PL_compiling, tmpbuf+2);
4118     SAVECOPLINE(&PL_compiling);
4119     CopLINE_set(&PL_compiling, 1);
4120     /* special case: an eval '' executed within the DB package gets lexically
4121      * placed in the first non-DB CV rather than the current CV - this
4122      * allows the debugger to execute code, find lexicals etc, in the
4123      * scope of the code being debugged. Passing &seq gets find_runcv
4124      * to do the dirty work for us */
4125     runcv = find_runcv(&seq);
4126
4127     PUSHBLOCK(cx, (CXt_EVAL|CXp_REAL), SP);
4128     PUSHEVAL(cx, 0);
4129     cx->blk_eval.retop = PL_op->op_next;
4130
4131     /* prepare to compile string */
4132
4133     if ((PERLDB_LINE || PERLDB_SAVESRC) && PL_curstash != PL_debstash)
4134         save_lines(CopFILEAV(&PL_compiling), PL_parser->linestr);
4135     else {
4136         /* XXX For C<eval "...">s within BEGIN {} blocks, this ends up
4137            deleting the eval's FILEGV from the stash before gv_check() runs
4138            (i.e. before run-time proper). To work around the coredump that
4139            ensues, we always turn GvMULTI_on for any globals that were
4140            introduced within evals. See force_ident(). GSAR 96-10-12 */
4141         char *const safestr = savepvn(tmpbuf, len);
4142         SAVEDELETE(PL_defstash, safestr, len);
4143         saved_delete = TRUE;
4144     }
4145
4146     PUTBACK;
4147
4148     if (doeval(gimme, runcv, seq, saved_hh)) {
4149         if (was != PL_breakable_sub_gen /* Some subs defined here. */
4150             ? (PERLDB_LINE || PERLDB_SAVESRC)
4151             :  PERLDB_SAVESRC_NOSUBS) {
4152             /* Retain the filegv we created.  */
4153         } else if (!saved_delete) {
4154             char *const safestr = savepvn(tmpbuf, len);
4155             SAVEDELETE(PL_defstash, safestr, len);
4156         }
4157         return DOCATCH(PL_eval_start);
4158     } else {
4159         /* We have already left the scope set up earlier thanks to the LEAVE
4160            in doeval().  */
4161         if (was != PL_breakable_sub_gen /* Some subs defined here. */
4162             ? (PERLDB_LINE || PERLDB_SAVESRC)
4163             :  PERLDB_SAVESRC_INVALID) {
4164             /* Retain the filegv we created.  */
4165         } else if (!saved_delete) {
4166             (void)hv_delete(PL_defstash, tmpbuf, len, G_DISCARD);
4167         }
4168         return PL_op->op_next;
4169     }
4170 }
4171
4172 PP(pp_leaveeval)
4173 {
4174     dVAR; dSP;
4175     SV **newsp;
4176     PMOP *newpm;
4177     I32 gimme;
4178     PERL_CONTEXT *cx;
4179     OP *retop;
4180     const U8 save_flags = PL_op -> op_flags;
4181     I32 optype;
4182     SV *namesv;
4183     CV *evalcv;
4184
4185     PERL_ASYNC_CHECK();
4186     POPBLOCK(cx,newpm);
4187     POPEVAL(cx);
4188     namesv = cx->blk_eval.old_namesv;
4189     retop = cx->blk_eval.retop;
4190     evalcv = cx->blk_eval.cv;
4191
4192     TAINT_NOT;
4193     SP = adjust_stack_on_leave((gimme == G_VOID) ? SP : newsp, SP, newsp,
4194                                 gimme, SVs_TEMP);
4195     PL_curpm = newpm;   /* Don't pop $1 et al till now */
4196
4197 #ifdef DEBUGGING
4198     assert(CvDEPTH(evalcv) == 1);
4199 #endif
4200     CvDEPTH(evalcv) = 0;
4201
4202     if (optype == OP_REQUIRE &&
4203         !(gimme == G_SCALAR ? SvTRUE(*SP) : SP > newsp))
4204     {
4205         /* Unassume the success we assumed earlier. */
4206         (void)hv_delete(GvHVn(PL_incgv),
4207                         SvPVX_const(namesv),
4208                         SvUTF8(namesv) ? -(I32)SvCUR(namesv) : (I32)SvCUR(namesv),
4209                         G_DISCARD);
4210         retop = Perl_die(aTHX_ "%"SVf" did not return a true value",
4211                                SVfARG(namesv));
4212         /* die_unwind() did LEAVE, or we won't be here */
4213     }
4214     else {
4215         LEAVE_with_name("eval");
4216         if (!(save_flags & OPf_SPECIAL)) {
4217             CLEAR_ERRSV();
4218         }
4219     }
4220
4221     RETURNOP(retop);
4222 }
4223
4224 /* Common code for Perl_call_sv and Perl_fold_constants, put here to keep it
4225    close to the related Perl_create_eval_scope.  */
4226 void
4227 Perl_delete_eval_scope(pTHX)
4228 {
4229     SV **newsp;
4230     PMOP *newpm;
4231     I32 gimme;
4232     PERL_CONTEXT *cx;
4233     I32 optype;
4234
4235     POPBLOCK(cx,newpm);
4236     POPEVAL(cx);
4237     PL_curpm = newpm;
4238     LEAVE_with_name("eval_scope");
4239     PERL_UNUSED_VAR(newsp);
4240     PERL_UNUSED_VAR(gimme);
4241     PERL_UNUSED_VAR(optype);
4242 }
4243
4244 /* Common-ish code salvaged from Perl_call_sv and pp_entertry, because it was
4245    also needed by Perl_fold_constants.  */
4246 PERL_CONTEXT *
4247 Perl_create_eval_scope(pTHX_ U32 flags)
4248 {
4249     PERL_CONTEXT *cx;
4250     const I32 gimme = GIMME_V;
4251
4252     ENTER_with_name("eval_scope");
4253     SAVETMPS;
4254
4255     PUSHBLOCK(cx, (CXt_EVAL|CXp_TRYBLOCK), PL_stack_sp);
4256     PUSHEVAL(cx, 0);
4257
4258     PL_in_eval = EVAL_INEVAL;
4259     if (flags & G_KEEPERR)
4260         PL_in_eval |= EVAL_KEEPERR;
4261     else
4262         CLEAR_ERRSV();
4263     if (flags & G_FAKINGEVAL) {
4264         PL_eval_root = PL_op; /* Only needed so that goto works right. */
4265     }
4266     return cx;
4267 }
4268
4269 PP(pp_entertry)
4270 {
4271     dVAR;
4272     PERL_CONTEXT * const cx = create_eval_scope(0);
4273     cx->blk_eval.retop = cLOGOP->op_other->op_next;
4274     return DOCATCH(PL_op->op_next);
4275 }
4276
4277 PP(pp_leavetry)
4278 {
4279     dVAR; dSP;
4280     SV **newsp;
4281     PMOP *newpm;
4282     I32 gimme;
4283     PERL_CONTEXT *cx;
4284     I32 optype;
4285
4286     PERL_ASYNC_CHECK();
4287     POPBLOCK(cx,newpm);
4288     POPEVAL(cx);
4289     PERL_UNUSED_VAR(optype);
4290
4291     TAINT_NOT;
4292     SP = adjust_stack_on_leave(newsp, SP, newsp, gimme, SVs_PADTMP|SVs_TEMP);
4293     PL_curpm = newpm;   /* Don't pop $1 et al till now */
4294
4295     LEAVE_with_name("eval_scope");
4296     CLEAR_ERRSV();
4297     RETURN;
4298 }
4299
4300 PP(pp_entergiven)
4301 {
4302     dVAR; dSP;
4303     PERL_CONTEXT *cx;
4304     const I32 gimme = GIMME_V;
4305
4306     ENTER_with_name("given");
4307     SAVETMPS;
4308
4309     if (PL_op->op_targ) {
4310         SAVEPADSVANDMORTALIZE(PL_op->op_targ);
4311         SvREFCNT_dec(PAD_SVl(PL_op->op_targ));
4312         PAD_SVl(PL_op->op_targ) = SvREFCNT_inc_NN(POPs);
4313     }
4314     else {
4315         SAVE_DEFSV;
4316         DEFSV_set(POPs);
4317     }
4318
4319     PUSHBLOCK(cx, CXt_GIVEN, SP);
4320     PUSHGIVEN(cx);
4321
4322     RETURN;
4323 }
4324
4325 PP(pp_leavegiven)
4326 {
4327     dVAR; dSP;
4328     PERL_CONTEXT *cx;
4329     I32 gimme;
4330     SV **newsp;
4331     PMOP *newpm;
4332     PERL_UNUSED_CONTEXT;
4333
4334     POPBLOCK(cx,newpm);
4335     assert(CxTYPE(cx) == CXt_GIVEN);
4336
4337     TAINT_NOT;
4338     SP = adjust_stack_on_leave(newsp, SP, newsp, gimme, SVs_PADTMP|SVs_TEMP);
4339     PL_curpm = newpm;   /* Don't pop $1 et al till now */
4340
4341     LEAVE_with_name("given");
4342     RETURN;
4343 }
4344
4345 /* Helper routines used by pp_smartmatch */
4346 STATIC PMOP *
4347 S_make_matcher(pTHX_ REGEXP *re)
4348 {
4349     dVAR;
4350     PMOP *matcher = (PMOP *) newPMOP(OP_MATCH, OPf_WANT_SCALAR | OPf_STACKED);
4351
4352     PERL_ARGS_ASSERT_MAKE_MATCHER;
4353
4354     PM_SETRE(matcher, ReREFCNT_inc(re));
4355
4356     SAVEFREEOP((OP *) matcher);
4357     ENTER_with_name("matcher"); SAVETMPS;
4358     SAVEOP();
4359     return matcher;
4360 }
4361
4362 STATIC bool
4363 S_matcher_matches_sv(pTHX_ PMOP *matcher, SV *sv)
4364 {
4365     dVAR;
4366     dSP;
4367
4368     PERL_ARGS_ASSERT_MATCHER_MATCHES_SV;
4369
4370     PL_op = (OP *) matcher;
4371     XPUSHs(sv);
4372     PUTBACK;
4373     (void) Perl_pp_match(aTHX);
4374     SPAGAIN;
4375     return (SvTRUEx(POPs));
4376 }
4377
4378 STATIC void
4379 S_destroy_matcher(pTHX_ PMOP *matcher)
4380 {
4381     dVAR;
4382
4383     PERL_ARGS_ASSERT_DESTROY_MATCHER;
4384     PERL_UNUSED_ARG(matcher);
4385
4386     FREETMPS;
4387     LEAVE_with_name("matcher");
4388 }
4389
4390 /* Do a smart match */
4391 PP(pp_smartmatch)
4392 {
4393     DEBUG_M(Perl_deb(aTHX_ "Starting smart match resolution\n"));
4394     return do_smartmatch(NULL, NULL, 0);
4395 }
4396
4397 /* This version of do_smartmatch() implements the
4398  * table of smart matches that is found in perlsyn.
4399  */
4400 STATIC OP *
4401 S_do_smartmatch(pTHX_ HV *seen_this, HV *seen_other, const bool copied)
4402 {
4403     dVAR;
4404     dSP;
4405
4406     bool object_on_left = FALSE;
4407     SV *e = TOPs;       /* e is for 'expression' */
4408     SV *d = TOPm1s;     /* d is for 'default', as in PL_defgv */
4409
4410     /* Take care only to invoke mg_get() once for each argument.
4411      * Currently we do this by copying the SV if it's magical. */
4412     if (d) {
4413         if (!copied && SvGMAGICAL(d))
4414             d = sv_mortalcopy(d);
4415     }
4416     else
4417         d = &PL_sv_undef;
4418
4419     assert(e);
4420     if (SvGMAGICAL(e))
4421         e = sv_mortalcopy(e);
4422
4423     /* First of all, handle overload magic of the rightmost argument */
4424     if (SvAMAGIC(e)) {
4425         SV * tmpsv;
4426         DEBUG_M(Perl_deb(aTHX_ "    applying rule Any-Object\n"));
4427         DEBUG_M(Perl_deb(aTHX_ "        attempting overload\n"));
4428
4429         tmpsv = amagic_call(d, e, smart_amg, AMGf_noleft);
4430         if (tmpsv) {
4431             SPAGAIN;
4432             (void)POPs;
4433             SETs(tmpsv);
4434             RETURN;
4435         }
4436         DEBUG_M(Perl_deb(aTHX_ "        failed to run overload method; continuing...\n"));
4437     }
4438
4439     SP -= 2;    /* Pop the values */
4440
4441
4442     /* ~~ undef */
4443     if (!SvOK(e)) {
4444         DEBUG_M(Perl_deb(aTHX_ "    applying rule Any-undef\n"));
4445         if (SvOK(d))
4446             RETPUSHNO;
4447         else
4448             RETPUSHYES;
4449     }
4450
4451     if (sv_isobject(e) && (SvTYPE(SvRV(e)) != SVt_REGEXP)) {
4452         DEBUG_M(Perl_deb(aTHX_ "    applying rule Any-Object\n"));
4453         Perl_croak(aTHX_ "Smart matching a non-overloaded object breaks encapsulation");
4454     }
4455     if (sv_isobject(d) && (SvTYPE(SvRV(d)) != SVt_REGEXP))
4456         object_on_left = TRUE;
4457
4458     /* ~~ sub */
4459     if (SvROK(e) && SvTYPE(SvRV(e)) == SVt_PVCV) {
4460         I32 c;
4461         if (object_on_left) {
4462             goto sm_any_sub; /* Treat objects like scalars */
4463         }
4464         else if (SvROK(d) && SvTYPE(SvRV(d)) == SVt_PVHV) {
4465             /* Test sub truth for each key */
4466             HE *he;
4467             bool andedresults = TRUE;
4468             HV *hv = (HV*) SvRV(d);
4469             I32 numkeys = hv_iterinit(hv);
4470             DEBUG_M(Perl_deb(aTHX_ "    applying rule Hash-CodeRef\n"));
4471             if (numkeys == 0)
4472                 RETPUSHYES;
4473             while ( (he = hv_iternext(hv)) ) {
4474                 DEBUG_M(Perl_deb(aTHX_ "        testing hash key...\n"));
4475                 ENTER_with_name("smartmatch_hash_key_test");
4476                 SAVETMPS;
4477                 PUSHMARK(SP);
4478                 PUSHs(hv_iterkeysv(he));
4479                 PUTBACK;
4480                 c = call_sv(e, G_SCALAR);
4481                 SPAGAIN;
4482                 if (c == 0)
4483                     andedresults = FALSE;
4484                 else
4485                     andedresults = SvTRUEx(POPs) && andedresults;
4486                 FREETMPS;
4487                 LEAVE_with_name("smartmatch_hash_key_test");
4488             }
4489             if (andedresults)
4490                 RETPUSHYES;
4491             else
4492                 RETPUSHNO;
4493         }
4494         else if (SvROK(d) && SvTYPE(SvRV(d)) == SVt_PVAV) {
4495             /* Test sub truth for each element */
4496             I32 i;
4497             bool andedresults = TRUE;
4498             AV *av = (AV*) SvRV(d);
4499             const I32 len = av_len(av);
4500             DEBUG_M(Perl_deb(aTHX_ "    applying rule Array-CodeRef\n"));
4501             if (len == -1)
4502                 RETPUSHYES;
4503             for (i = 0; i <= len; ++i) {
4504                 SV * const * const svp = av_fetch(av, i, FALSE);
4505                 DEBUG_M(Perl_deb(aTHX_ "        testing array element...\n"));
4506                 ENTER_with_name("smartmatch_array_elem_test");
4507                 SAVETMPS;
4508                 PUSHMARK(SP);
4509                 if (svp)
4510                     PUSHs(*svp);
4511                 PUTBACK;
4512                 c = call_sv(e, G_SCALAR);
4513                 SPAGAIN;
4514                 if (c == 0)
4515                     andedresults = FALSE;
4516                 else
4517                     andedresults = SvTRUEx(POPs) && andedresults;
4518                 FREETMPS;
4519                 LEAVE_with_name("smartmatch_array_elem_test");
4520             }
4521             if (andedresults)
4522                 RETPUSHYES;
4523             else
4524                 RETPUSHNO;
4525         }
4526         else {
4527           sm_any_sub:
4528             DEBUG_M(Perl_deb(aTHX_ "    applying rule Any-CodeRef\n"));
4529             ENTER_with_name("smartmatch_coderef");
4530             SAVETMPS;
4531             PUSHMARK(SP);
4532             PUSHs(d);
4533             PUTBACK;
4534             c = call_sv(e, G_SCALAR);
4535             SPAGAIN;
4536             if (c == 0)
4537                 PUSHs(&PL_sv_no);
4538             else if (SvTEMP(TOPs))
4539                 SvREFCNT_inc_void(TOPs);
4540             FREETMPS;
4541             LEAVE_with_name("smartmatch_coderef");
4542             RETURN;
4543         }
4544     }
4545     /* ~~ %hash */
4546     else if (SvROK(e) && SvTYPE(SvRV(e)) == SVt_PVHV) {
4547         if (object_on_left) {
4548             goto sm_any_hash; /* Treat objects like scalars */
4549         }
4550         else if (!SvOK(d)) {
4551             DEBUG_M(Perl_deb(aTHX_ "    applying rule Any-Hash ($a undef)\n"));
4552             RETPUSHNO;
4553         }
4554         else if (SvROK(d) && SvTYPE(SvRV(d)) == SVt_PVHV) {
4555             /* Check that the key-sets are identical */
4556             HE *he;
4557             HV *other_hv = MUTABLE_HV(SvRV(d));
4558             bool tied = FALSE;
4559             bool other_tied = FALSE;
4560             U32 this_key_count  = 0,
4561                 other_key_count = 0;
4562             HV *hv = MUTABLE_HV(SvRV(e));
4563
4564             DEBUG_M(Perl_deb(aTHX_ "    applying rule Hash-Hash\n"));
4565             /* Tied hashes don't know how many keys they have. */
4566             if (SvTIED_mg((SV*)hv, PERL_MAGIC_tied)) {
4567                 tied = TRUE;
4568             }
4569             else if (SvTIED_mg((const SV *)other_hv, PERL_MAGIC_tied)) {
4570                 HV * const temp = other_hv;
4571                 other_hv = hv;
4572                 hv = temp;
4573                 tied = TRUE;
4574             }
4575             if (SvTIED_mg((const SV *)other_hv, PERL_MAGIC_tied))
4576                 other_tied = TRUE;
4577
4578             if (!tied && HvUSEDKEYS((const HV *) hv) != HvUSEDKEYS(other_hv))
4579                 RETPUSHNO;
4580
4581             /* The hashes have the same number of keys, so it suffices
4582                to check that one is a subset of the other. */
4583             (void) hv_iterinit(hv);
4584             while ( (he = hv_iternext(hv)) ) {
4585                 SV *key = hv_iterkeysv(he);
4586
4587                 DEBUG_M(Perl_deb(aTHX_ "        comparing hash key...\n"));
4588                 ++ this_key_count;
4589
4590                 if(!hv_exists_ent(other_hv, key, 0)) {
4591                     (void) hv_iterinit(hv);     /* reset iterator */
4592                     RETPUSHNO;
4593                 }
4594             }
4595
4596             if (other_tied) {
4597                 (void) hv_iterinit(other_hv);
4598                 while ( hv_iternext(other_hv) )
4599                     ++other_key_count;
4600             }
4601             else
4602                 other_key_count = HvUSEDKEYS(other_hv);
4603
4604             if (this_key_count != other_key_count)
4605                 RETPUSHNO;
4606             else
4607                 RETPUSHYES;
4608         }
4609         else if (SvROK(d) && SvTYPE(SvRV(d)) == SVt_PVAV) {
4610             AV * const other_av = MUTABLE_AV(SvRV(d));
4611             const I32 other_len = av_len(other_av) + 1;
4612             I32 i;
4613             HV *hv = MUTABLE_HV(SvRV(e));
4614
4615             DEBUG_M(Perl_deb(aTHX_ "    applying rule Array-Hash\n"));
4616             for (i = 0; i < other_len; ++i) {
4617                 SV ** const svp = av_fetch(other_av, i, FALSE);
4618                 DEBUG_M(Perl_deb(aTHX_ "        checking for key existence...\n"));
4619                 if (svp) {      /* ??? When can this not happen? */
4620                     if (hv_exists_ent(hv, *svp, 0))
4621                         RETPUSHYES;
4622                 }
4623             }
4624             RETPUSHNO;
4625         }
4626         else if (SvROK(d) && SvTYPE(SvRV(d)) == SVt_REGEXP) {
4627             DEBUG_M(Perl_deb(aTHX_ "    applying rule Regex-Hash\n"));
4628           sm_regex_hash:
4629             {
4630                 PMOP * const matcher = make_matcher((REGEXP*) SvRV(d));
4631                 HE *he;
4632                 HV *hv = MUTABLE_HV(SvRV(e));
4633
4634                 (void) hv_iterinit(hv);
4635                 while ( (he = hv_iternext(hv)) ) {
4636                     DEBUG_M(Perl_deb(aTHX_ "        testing key against pattern...\n"));
4637                     if (matcher_matches_sv(matcher, hv_iterkeysv(he))) {
4638                         (void) hv_iterinit(hv);
4639                         destroy_matcher(matcher);
4640                         RETPUSHYES;
4641                     }
4642                 }
4643                 destroy_matcher(matcher);
4644                 RETPUSHNO;
4645             }
4646         }
4647         else {
4648           sm_any_hash:
4649             DEBUG_M(Perl_deb(aTHX_ "    applying rule Any-Hash\n"));
4650             if (hv_exists_ent(MUTABLE_HV(SvRV(e)), d, 0))
4651                 RETPUSHYES;
4652             else
4653                 RETPUSHNO;
4654         }
4655     }
4656     /* ~~ @array */
4657     else if (SvROK(e) && SvTYPE(SvRV(e)) == SVt_PVAV) {
4658         if (object_on_left) {
4659             goto sm_any_array; /* Treat objects like scalars */
4660         }
4661         else if (SvROK(d) && SvTYPE(SvRV(d)) == SVt_PVHV) {
4662             AV * const other_av = MUTABLE_AV(SvRV(e));
4663             const I32 other_len = av_len(other_av) + 1;
4664             I32 i;
4665
4666             DEBUG_M(Perl_deb(aTHX_ "    applying rule Hash-Array\n"));
4667             for (i = 0; i < other_len; ++i) {
4668                 SV ** const svp = av_fetch(other_av, i, FALSE);
4669
4670                 DEBUG_M(Perl_deb(aTHX_ "        testing for key existence...\n"));
4671                 if (svp) {      /* ??? When can this not happen? */
4672                     if (hv_exists_ent(MUTABLE_HV(SvRV(d)), *svp, 0))
4673                         RETPUSHYES;
4674                 }
4675             }
4676             RETPUSHNO;
4677         }
4678         if (SvROK(d) && SvTYPE(SvRV(d)) == SVt_PVAV) {
4679             AV *other_av = MUTABLE_AV(SvRV(d));
4680             DEBUG_M(Perl_deb(aTHX_ "    applying rule Array-Array\n"));
4681             if (av_len(MUTABLE_AV(SvRV(e))) != av_len(other_av))
4682                 RETPUSHNO;
4683             else {
4684                 I32 i;
4685                 const I32 other_len = av_len(other_av);
4686
4687                 if (NULL == seen_this) {
4688                     seen_this = newHV();
4689                     (void) sv_2mortal(MUTABLE_SV(seen_this));
4690                 }
4691                 if (NULL == seen_other) {
4692                     seen_other = newHV();
4693                     (void) sv_2mortal(MUTABLE_SV(seen_other));
4694                 }
4695                 for(i = 0; i <= other_len; ++i) {
4696                     SV * const * const this_elem = av_fetch(MUTABLE_AV(SvRV(e)), i, FALSE);
4697                     SV * const * const other_elem = av_fetch(other_av, i, FALSE);
4698
4699                     if (!this_elem || !other_elem) {
4700                         if ((this_elem && SvOK(*this_elem))
4701                                 || (other_elem && SvOK(*other_elem)))
4702                             RETPUSHNO;
4703                     }
4704                     else if (hv_exists_ent(seen_this,
4705                                 sv_2mortal(newSViv(PTR2IV(*this_elem))), 0) ||
4706                             hv_exists_ent(seen_other,
4707                                 sv_2mortal(newSViv(PTR2IV(*other_elem))), 0))
4708                     {
4709                         if (*this_elem != *other_elem)
4710                             RETPUSHNO;
4711                     }
4712                     else {
4713                         (void)hv_store_ent(seen_this,
4714                                 sv_2mortal(newSViv(PTR2IV(*this_elem))),
4715                                 &PL_sv_undef, 0);
4716                         (void)hv_store_ent(seen_other,
4717                                 sv_2mortal(newSViv(PTR2IV(*other_elem))),
4718                                 &PL_sv_undef, 0);
4719                         PUSHs(*other_elem);
4720                         PUSHs(*this_elem);
4721
4722                         PUTBACK;
4723                         DEBUG_M(Perl_deb(aTHX_ "        recursively comparing array element...\n"));
4724                         (void) do_smartmatch(seen_this, seen_other, 0);
4725                         SPAGAIN;
4726                         DEBUG_M(Perl_deb(aTHX_ "        recursion finished\n"));
4727
4728                         if (!SvTRUEx(POPs))
4729                             RETPUSHNO;
4730                     }
4731                 }
4732                 RETPUSHYES;
4733             }
4734         }
4735         else if (SvROK(d) && SvTYPE(SvRV(d)) == SVt_REGEXP) {
4736             DEBUG_M(Perl_deb(aTHX_ "    applying rule Regex-Array\n"));
4737           sm_regex_array:
4738             {
4739                 PMOP * const matcher = make_matcher((REGEXP*) SvRV(d));
4740                 const I32 this_len = av_len(MUTABLE_AV(SvRV(e)));
4741                 I32 i;
4742
4743                 for(i = 0; i <= this_len; ++i) {
4744                     SV * const * const svp = av_fetch(MUTABLE_AV(SvRV(e)), i, FALSE);
4745                     DEBUG_M(Perl_deb(aTHX_ "        testing element against pattern...\n"));
4746                     if (svp && matcher_matches_sv(matcher, *svp)) {
4747                         destroy_matcher(matcher);
4748                         RETPUSHYES;
4749                     }
4750                 }
4751                 destroy_matcher(matcher);
4752                 RETPUSHNO;
4753             }
4754         }
4755         else if (!SvOK(d)) {
4756             /* undef ~~ array */
4757             const I32 this_len = av_len(MUTABLE_AV(SvRV(e)));
4758             I32 i;
4759
4760             DEBUG_M(Perl_deb(aTHX_ "    applying rule Undef-Array\n"));
4761             for (i = 0; i <= this_len; ++i) {
4762                 SV * const * const svp = av_fetch(MUTABLE_AV(SvRV(e)), i, FALSE);
4763                 DEBUG_M(Perl_deb(aTHX_ "        testing for undef element...\n"));
4764                 if (!svp || !SvOK(*svp))
4765                     RETPUSHYES;
4766             }
4767             RETPUSHNO;
4768         }
4769         else {
4770           sm_any_array:
4771             {
4772                 I32 i;
4773                 const I32 this_len = av_len(MUTABLE_AV(SvRV(e)));
4774
4775                 DEBUG_M(Perl_deb(aTHX_ "    applying rule Any-Array\n"));
4776                 for (i = 0; i <= this_len; ++i) {
4777                     SV * const * const svp = av_fetch(MUTABLE_AV(SvRV(e)), i, FALSE);
4778                     if (!svp)
4779                         continue;
4780
4781                     PUSHs(d);
4782                     PUSHs(*svp);
4783                     PUTBACK;
4784                     /* infinite recursion isn't supposed to happen here */
4785                     DEBUG_M(Perl_deb(aTHX_ "        recursively testing array element...\n"));
4786                     (void) do_smartmatch(NULL, NULL, 1);
4787                     SPAGAIN;
4788                     DEBUG_M(Perl_deb(aTHX_ "        recursion finished\n"));
4789                     if (SvTRUEx(POPs))
4790                         RETPUSHYES;
4791                 }
4792                 RETPUSHNO;
4793             }
4794         }
4795     }
4796     /* ~~ qr// */
4797     else if (SvROK(e) && SvTYPE(SvRV(e)) == SVt_REGEXP) {
4798         if (!object_on_left && SvROK(d) && SvTYPE(SvRV(d)) == SVt_PVHV) {
4799             SV *t = d; d = e; e = t;
4800             DEBUG_M(Perl_deb(aTHX_ "    applying rule Hash-Regex\n"));
4801             goto sm_regex_hash;
4802         }
4803         else if (!object_on_left && SvROK(d) && SvTYPE(SvRV(d)) == SVt_PVAV) {
4804             SV *t = d; d = e; e = t;
4805             DEBUG_M(Perl_deb(aTHX_ "    applying rule Array-Regex\n"));
4806             goto sm_regex_array;
4807         }
4808         else {
4809             PMOP * const matcher = make_matcher((REGEXP*) SvRV(e));
4810
4811             DEBUG_M(Perl_deb(aTHX_ "    applying rule Any-Regex\n"));
4812             PUTBACK;
4813             PUSHs(matcher_matches_sv(matcher, d)
4814                     ? &PL_sv_yes
4815                     : &PL_sv_no);
4816             destroy_matcher(matcher);
4817             RETURN;
4818         }
4819     }
4820     /* ~~ scalar */
4821     /* See if there is overload magic on left */
4822     else if (object_on_left && SvAMAGIC(d)) {
4823         SV *tmpsv;
4824         DEBUG_M(Perl_deb(aTHX_ "    applying rule Object-Any\n"));
4825         DEBUG_M(Perl_deb(aTHX_ "        attempting overload\n"));
4826         PUSHs(d); PUSHs(e);
4827         PUTBACK;
4828         tmpsv = amagic_call(d, e, smart_amg, AMGf_noright);
4829         if (tmpsv) {
4830             SPAGAIN;
4831             (void)POPs;
4832             SETs(tmpsv);
4833             RETURN;
4834         }
4835         SP -= 2;
4836         DEBUG_M(Perl_deb(aTHX_ "        failed to run overload method; falling back...\n"));
4837         goto sm_any_scalar;
4838     }
4839     else if (!SvOK(d)) {
4840         /* undef ~~ scalar ; we already know that the scalar is SvOK */
4841         DEBUG_M(Perl_deb(aTHX_ "    applying rule undef-Any\n"));
4842         RETPUSHNO;
4843     }
4844     else
4845   sm_any_scalar:
4846     if (SvNIOK(e) || (SvPOK(e) && looks_like_number(e) && SvNIOK(d))) {
4847         DEBUG_M(if (SvNIOK(e))
4848                     Perl_deb(aTHX_ "    applying rule Any-Num\n");
4849                 else
4850                     Perl_deb(aTHX_ "    applying rule Num-numish\n");
4851         );
4852         /* numeric comparison */
4853         PUSHs(d); PUSHs(e);
4854         PUTBACK;
4855         if (CopHINTS_get(PL_curcop) & HINT_INTEGER)
4856             (void) Perl_pp_i_eq(aTHX);
4857         else
4858             (void) Perl_pp_eq(aTHX);
4859         SPAGAIN;
4860         if (SvTRUEx(POPs))
4861             RETPUSHYES;
4862         else
4863             RETPUSHNO;
4864     }
4865
4866     /* As a last resort, use string comparison */
4867     DEBUG_M(Perl_deb(aTHX_ "    applying rule Any-Any\n"));
4868     PUSHs(d); PUSHs(e);
4869     PUTBACK;
4870     return Perl_pp_seq(aTHX);
4871 }
4872
4873 PP(pp_enterwhen)
4874 {
4875     dVAR; dSP;
4876     PERL_CONTEXT *cx;
4877     const I32 gimme = GIMME_V;
4878
4879     /* This is essentially an optimization: if the match
4880        fails, we don't want to push a context and then
4881        pop it again right away, so we skip straight
4882        to the op that follows the leavewhen.
4883        RETURNOP calls PUTBACK which restores the stack pointer after the POPs.
4884     */
4885     if ((0 == (PL_op->op_flags & OPf_SPECIAL)) && !SvTRUEx(POPs))
4886         RETURNOP(cLOGOP->op_other->op_next);
4887
4888     ENTER_with_name("when");
4889     SAVETMPS;
4890
4891     PUSHBLOCK(cx, CXt_WHEN, SP);
4892     PUSHWHEN(cx);
4893
4894     RETURN;
4895 }
4896
4897 PP(pp_leavewhen)
4898 {
4899     dVAR; dSP;
4900     I32 cxix;
4901     PERL_CONTEXT *cx;
4902     I32 gimme;
4903     SV **newsp;
4904     PMOP *newpm;
4905
4906     cxix = dopoptogiven(cxstack_ix);
4907     if (cxix < 0)
4908         /* diag_listed_as: Can't "when" outside a topicalizer */
4909         DIE(aTHX_ "Can't \"%s\" outside a topicalizer",
4910                    PL_op->op_flags & OPf_SPECIAL ? "default" : "when");
4911
4912     POPBLOCK(cx,newpm);
4913     assert(CxTYPE(cx) == CXt_WHEN);
4914
4915     TAINT_NOT;
4916     SP = adjust_stack_on_leave(newsp, SP, newsp, gimme, SVs_PADTMP|SVs_TEMP);
4917     PL_curpm = newpm;   /* pop $1 et al */
4918
4919     LEAVE_with_name("when");
4920
4921     if (cxix < cxstack_ix)
4922         dounwind(cxix);
4923
4924     cx = &cxstack[cxix];
4925
4926     if (CxFOREACH(cx)) {
4927         /* clear off anything above the scope we're re-entering */
4928         I32 inner = PL_scopestack_ix;
4929
4930         TOPBLOCK(cx);
4931         if (PL_scopestack_ix < inner)
4932             leave_scope(PL_scopestack[PL_scopestack_ix]);
4933         PL_curcop = cx->blk_oldcop;
4934
4935         return cx->blk_loop.my_op->op_nextop;
4936     }
4937     else
4938         RETURNOP(cx->blk_givwhen.leave_op);
4939 }
4940
4941 PP(pp_continue)
4942 {
4943     dVAR; dSP;
4944     I32 cxix;
4945     PERL_CONTEXT *cx;
4946     I32 gimme;
4947     SV **newsp;
4948     PMOP *newpm;
4949
4950     PERL_UNUSED_VAR(gimme);
4951
4952     cxix = dopoptowhen(cxstack_ix);
4953     if (cxix < 0)
4954         DIE(aTHX_ "Can't \"continue\" outside a when block");
4955
4956     if (cxix < cxstack_ix)
4957         dounwind(cxix);
4958
4959     POPBLOCK(cx,newpm);
4960     assert(CxTYPE(cx) == CXt_WHEN);
4961
4962     SP = newsp;
4963     PL_curpm = newpm;   /* pop $1 et al */
4964
4965     LEAVE_with_name("when");
4966     RETURNOP(cx->blk_givwhen.leave_op->op_next);
4967 }
4968
4969 PP(pp_break)
4970 {
4971     dVAR;
4972     I32 cxix;
4973     PERL_CONTEXT *cx;
4974
4975     cxix = dopoptogiven(cxstack_ix);
4976     if (cxix < 0)
4977         DIE(aTHX_ "Can't \"break\" outside a given block");
4978
4979     cx = &cxstack[cxix];
4980     if (CxFOREACH(cx))
4981         DIE(aTHX_ "Can't \"break\" in a loop topicalizer");
4982
4983     if (cxix < cxstack_ix)
4984         dounwind(cxix);
4985
4986     /* Restore the sp at the time we entered the given block */
4987     TOPBLOCK(cx);
4988
4989     return cx->blk_givwhen.leave_op;
4990 }
4991
4992 static MAGIC *
4993 S_doparseform(pTHX_ SV *sv)
4994 {
4995     STRLEN len;
4996     char *s = SvPV(sv, len);
4997     char *send;
4998     char *base = NULL; /* start of current field */
4999     I32 skipspaces = 0; /* number of contiguous spaces seen */
5000     bool noblank   = FALSE; /* ~ or ~~ seen on this line */
5001     bool repeat    = FALSE; /* ~~ seen on this line */
5002     bool postspace = FALSE; /* a text field may need right padding */
5003     U32 *fops;
5004     U32 *fpc;
5005     U32 *linepc = NULL;     /* position of last FF_LINEMARK */
5006     I32 arg;
5007     bool ischop;            /* it's a ^ rather than a @ */
5008     bool unchopnum = FALSE; /* at least one @ (i.e. non-chop) num field seen */
5009     int maxops = 12; /* FF_LINEMARK + FF_END + 10 (\0 without preceding \n) */
5010     MAGIC *mg = NULL;
5011     SV *sv_copy;
5012
5013     PERL_ARGS_ASSERT_DOPARSEFORM;
5014
5015     if (len == 0)
5016         Perl_croak(aTHX_ "Null picture in formline");
5017
5018     if (SvTYPE(sv) >= SVt_PVMG) {
5019         /* This might, of course, still return NULL.  */
5020         mg = mg_find(sv, PERL_MAGIC_fm);
5021     } else {
5022         sv_upgrade(sv, SVt_PVMG);
5023     }
5024
5025     if (mg) {
5026         /* still the same as previously-compiled string? */
5027         SV *old = mg->mg_obj;
5028         if ( !(!!SvUTF8(old) ^ !!SvUTF8(sv))
5029               && len == SvCUR(old)
5030               && strnEQ(SvPVX(old), SvPVX(sv), len)
5031         ) {
5032             DEBUG_f(PerlIO_printf(Perl_debug_log,"Re-using compiled format\n"));
5033             return mg;
5034         }
5035
5036         DEBUG_f(PerlIO_printf(Perl_debug_log, "Re-compiling format\n"));
5037         Safefree(mg->mg_ptr);
5038         mg->mg_ptr = NULL;
5039         SvREFCNT_dec(old);
5040         mg->mg_obj = NULL;
5041     }
5042     else {
5043         DEBUG_f(PerlIO_printf(Perl_debug_log, "Compiling format\n"));
5044         mg = sv_magicext(sv, NULL, PERL_MAGIC_fm, &PL_vtbl_fm, NULL, 0);
5045     }
5046
5047     sv_copy = newSVpvn_utf8(s, len, SvUTF8(sv));
5048     s = SvPV(sv_copy, len); /* work on the copy, not the original */
5049     send = s + len;
5050
5051
5052     /* estimate the buffer size needed */
5053     for (base = s; s <= send; s++) {
5054         if (*s == '\n' || *s == '@' || *s == '^')
5055             maxops += 10;
5056     }
5057     s = base;
5058     base = NULL;
5059
5060     Newx(fops, maxops, U32);
5061     fpc = fops;
5062
5063     if (s < send) {
5064         linepc = fpc;
5065         *fpc++ = FF_LINEMARK;
5066         noblank = repeat = FALSE;
5067         base = s;
5068     }
5069
5070     while (s <= send) {
5071         switch (*s++) {
5072         default:
5073             skipspaces = 0;
5074             continue;
5075
5076         case '~':
5077             if (*s == '~') {
5078                 repeat = TRUE;
5079                 skipspaces++;
5080                 s++;
5081             }
5082             noblank = TRUE;
5083             /* FALL THROUGH */
5084         case ' ': case '\t':
5085             skipspaces++;
5086             continue;
5087         case 0:
5088             if (s < send) {
5089                 skipspaces = 0;
5090                 continue;
5091             } /* else FALL THROUGH */
5092         case '\n':
5093             arg = s - base;
5094             skipspaces++;
5095             arg -= skipspaces;
5096             if (arg) {
5097                 if (postspace)
5098                     *fpc++ = FF_SPACE;
5099                 *fpc++ = FF_LITERAL;
5100                 *fpc++ = (U32)arg;
5101             }
5102             postspace = FALSE;
5103             if (s <= send)
5104                 skipspaces--;
5105             if (skipspaces) {
5106                 *fpc++ = FF_SKIP;
5107                 *fpc++ = (U32)skipspaces;
5108             }
5109             skipspaces = 0;
5110             if (s <= send)
5111                 *fpc++ = FF_NEWLINE;
5112             if (noblank) {
5113                 *fpc++ = FF_BLANK;
5114                 if (repeat)
5115                     arg = fpc - linepc + 1;
5116                 else
5117                     arg = 0;
5118                 *fpc++ = (U32)arg;
5119             }
5120             if (s < send) {
5121                 linepc = fpc;
5122                 *fpc++ = FF_LINEMARK;
5123                 noblank = repeat = FALSE;
5124                 base = s;
5125             }
5126             else
5127                 s++;
5128             continue;
5129
5130         case '@':
5131         case '^':
5132             ischop = s[-1] == '^';
5133
5134             if (postspace) {
5135                 *fpc++ = FF_SPACE;
5136                 postspace = FALSE;
5137             }
5138             arg = (s - base) - 1;
5139             if (arg) {
5140                 *fpc++ = FF_LITERAL;
5141                 *fpc++ = (U32)arg;
5142             }
5143
5144             base = s - 1;
5145             *fpc++ = FF_FETCH;
5146             if (*s == '*') { /*  @* or ^*  */
5147                 s++;
5148                 *fpc++ = 2;  /* skip the @* or ^* */
5149                 if (ischop) {
5150                     *fpc++ = FF_LINESNGL;
5151                     *fpc++ = FF_CHOP;
5152                 } else
5153                     *fpc++ = FF_LINEGLOB;
5154             }
5155             else if (*s == '#' || (*s == '.' && s[1] == '#')) { /* @###, ^### */
5156                 arg = ischop ? FORM_NUM_BLANK : 0;
5157                 base = s - 1;
5158                 while (*s == '#')
5159                     s++;
5160                 if (*s == '.') {
5161                     const char * const f = ++s;
5162                     while (*s == '#')
5163                         s++;
5164                     arg |= FORM_NUM_POINT + (s - f);
5165                 }
5166                 *fpc++ = s - base;              /* fieldsize for FETCH */
5167                 *fpc++ = FF_DECIMAL;
5168                 *fpc++ = (U32)arg;
5169                 unchopnum |= ! ischop;
5170             }
5171             else if (*s == '0' && s[1] == '#') {  /* Zero padded decimals */
5172                 arg = ischop ? FORM_NUM_BLANK : 0;
5173                 base = s - 1;
5174                 s++;                                /* skip the '0' first */
5175                 while (*s == '#')
5176                     s++;
5177                 if (*s == '.') {
5178                     const char * const f = ++s;
5179                     while (*s == '#')
5180                         s++;
5181                     arg |= FORM_NUM_POINT + (s - f);
5182                 }
5183                 *fpc++ = s - base;                /* fieldsize for FETCH */
5184                 *fpc++ = FF_0DECIMAL;
5185                 *fpc++ = (U32)arg;
5186                 unchopnum |= ! ischop;
5187             }
5188             else {                              /* text field */
5189                 I32 prespace = 0;
5190                 bool ismore = FALSE;
5191
5192                 if (*s == '>') {
5193                     while (*++s == '>') ;
5194                     prespace = FF_SPACE;
5195                 }
5196                 else if (*s == '|') {
5197                     while (*++s == '|') ;
5198                     prespace = FF_HALFSPACE;
5199                     postspace = TRUE;
5200                 }
5201                 else {
5202                     if (*s == '<')
5203                         while (*++s == '<') ;
5204                     postspace = TRUE;
5205                 }
5206                 if (*s == '.' && s[1] == '.' && s[2] == '.') {
5207                     s += 3;
5208                     ismore = TRUE;
5209                 }
5210                 *fpc++ = s - base;              /* fieldsize for FETCH */
5211
5212                 *fpc++ = ischop ? FF_CHECKCHOP : FF_CHECKNL;
5213
5214                 if (prespace)
5215                     *fpc++ = (U32)prespace; /* add SPACE or HALFSPACE */
5216                 *fpc++ = FF_ITEM;
5217                 if (ismore)
5218                     *fpc++ = FF_MORE;
5219                 if (ischop)
5220                     *fpc++ = FF_CHOP;
5221             }
5222             base = s;
5223             skipspaces = 0;
5224             continue;
5225         }
5226     }
5227     *fpc++ = FF_END;
5228
5229     assert (fpc <= fops + maxops); /* ensure our buffer estimate was valid */
5230     arg = fpc - fops;
5231
5232     mg->mg_ptr = (char *) fops;
5233     mg->mg_len = arg * sizeof(U32);
5234     mg->mg_obj = sv_copy;
5235     mg->mg_flags |= MGf_REFCOUNTED;
5236
5237     if (unchopnum && repeat)
5238         Perl_die(aTHX_ "Repeated format line will never terminate (~~ and @#)");
5239
5240     return mg;
5241 }
5242
5243
5244 STATIC bool
5245 S_num_overflow(NV value, I32 fldsize, I32 frcsize)
5246 {
5247     /* Can value be printed in fldsize chars, using %*.*f ? */
5248     NV pwr = 1;
5249     NV eps = 0.5;
5250     bool res = FALSE;
5251     int intsize = fldsize - (value < 0 ? 1 : 0);
5252
5253     if (frcsize & FORM_NUM_POINT)
5254         intsize--;
5255     frcsize &= ~(FORM_NUM_POINT|FORM_NUM_BLANK);
5256     intsize -= frcsize;
5257
5258     while (intsize--) pwr *= 10.0;
5259     while (frcsize--) eps /= 10.0;
5260
5261     if( value >= 0 ){
5262         if (value + eps >= pwr)
5263             res = TRUE;
5264     } else {
5265         if (value - eps <= -pwr)
5266             res = TRUE;
5267     }
5268     return res;
5269 }
5270
5271 static I32
5272 S_run_user_filter(pTHX_ int idx, SV *buf_sv, int maxlen)
5273 {
5274     dVAR;
5275     SV * const datasv = FILTER_DATA(idx);
5276     const int filter_has_file = IoLINES(datasv);
5277     SV * const filter_state = MUTABLE_SV(IoTOP_GV(datasv));
5278     SV * const filter_sub = MUTABLE_SV(IoBOTTOM_GV(datasv));
5279     int status = 0;
5280     SV *upstream;
5281     STRLEN got_len;
5282     char *got_p = NULL;
5283     char *prune_from = NULL;
5284     bool read_from_cache = FALSE;
5285     STRLEN umaxlen;
5286     SV *err = NULL;
5287
5288     PERL_ARGS_ASSERT_RUN_USER_FILTER;
5289
5290     assert(maxlen >= 0);
5291     umaxlen = maxlen;
5292
5293     /* I was having segfault trouble under Linux 2.2.5 after a
5294        parse error occured.  (Had to hack around it with a test
5295        for PL_parser->error_count == 0.)  Solaris doesn't segfault --
5296        not sure where the trouble is yet.  XXX */
5297
5298     {
5299         SV *const cache = datasv;
5300         if (SvOK(cache)) {
5301             STRLEN cache_len;
5302             const char *cache_p = SvPV(cache, cache_len);
5303             STRLEN take = 0;
5304
5305             if (umaxlen) {
5306                 /* Running in block mode and we have some cached data already.
5307                  */
5308                 if (cache_len >= umaxlen) {
5309                     /* In fact, so much data we don't even need to call
5310                        filter_read.  */
5311                     take = umaxlen;
5312                 }
5313             } else {
5314                 const char *const first_nl =
5315                     (const char *)memchr(cache_p, '\n', cache_len);
5316                 if (first_nl) {
5317                     take = first_nl + 1 - cache_p;
5318                 }
5319             }
5320             if (take) {
5321                 sv_catpvn(buf_sv, cache_p, take);
5322                 sv_chop(cache, cache_p + take);
5323                 /* Definitely not EOF  */
5324                 return 1;
5325             }
5326
5327             sv_catsv(buf_sv, cache);
5328             if (umaxlen) {
5329                 umaxlen -= cache_len;
5330             }
5331             SvOK_off(cache);
5332             read_from_cache = TRUE;
5333         }
5334     }
5335
5336     /* Filter API says that the filter appends to the contents of the buffer.
5337        Usually the buffer is "", so the details don't matter. But if it's not,
5338        then clearly what it contains is already filtered by this filter, so we
5339        don't want to pass it in a second time.
5340        I'm going to use a mortal in case the upstream filter croaks.  */
5341     upstream = ((SvOK(buf_sv) && sv_len(buf_sv)) || SvGMAGICAL(buf_sv))
5342         ? sv_newmortal() : buf_sv;
5343     SvUPGRADE(upstream, SVt_PV);
5344
5345     if (filter_has_file) {
5346         status = FILTER_READ(idx+1, upstream, 0);
5347     }
5348
5349     if (filter_sub && status >= 0) {
5350         dSP;
5351         int count;
5352
5353         ENTER_with_name("call_filter_sub");
5354         SAVE_DEFSV;
5355         SAVETMPS;
5356         EXTEND(SP, 2);
5357
5358         DEFSV_set(upstream);
5359         PUSHMARK(SP);
5360         mPUSHi(0);
5361         if (filter_state) {
5362             PUSHs(filter_state);
5363         }
5364         PUTBACK;
5365         count = call_sv(filter_sub, G_SCALAR|G_EVAL);
5366         SPAGAIN;
5367
5368         if (count > 0) {
5369             SV *out = POPs;
5370             if (SvOK(out)) {
5371                 status = SvIV(out);
5372             }
5373             else {
5374                 SV * const errsv = ERRSV;
5375                 if (SvTRUE_NN(errsv))
5376                     err = newSVsv(errsv);
5377             }
5378         }
5379
5380         PUTBACK;
5381         FREETMPS;
5382         LEAVE_with_name("call_filter_sub");
5383     }
5384
5385     if (SvIsCOW(upstream)) sv_force_normal(upstream);
5386     if(!err && SvOK(upstream)) {
5387         got_p = SvPV(upstream, got_len);
5388         if (umaxlen) {
5389             if (got_len > umaxlen) {
5390                 prune_from = got_p + umaxlen;
5391             }
5392         } else {
5393             char *const first_nl = (char *)memchr(got_p, '\n', got_len);
5394             if (first_nl && first_nl + 1 < got_p + got_len) {
5395                 /* There's a second line here... */
5396                 prune_from = first_nl + 1;
5397             }
5398         }
5399     }
5400     if (!err && prune_from) {
5401         /* Oh. Too long. Stuff some in our cache.  */
5402         STRLEN cached_len = got_p + got_len - prune_from;
5403         SV *const cache = datasv;
5404
5405         if (SvOK(cache)) {
5406             /* Cache should be empty.  */
5407             assert(!SvCUR(cache));
5408         }
5409
5410         sv_setpvn(cache, prune_from, cached_len);
5411         /* If you ask for block mode, you may well split UTF-8 characters.
5412            "If it breaks, you get to keep both parts"
5413            (Your code is broken if you  don't put them back together again
5414            before something notices.) */
5415         if (SvUTF8(upstream)) {
5416             SvUTF8_on(cache);
5417         }
5418         SvCUR_set(upstream, got_len - cached_len);
5419         *prune_from = 0;
5420         /* Can't yet be EOF  */
5421         if (status == 0)
5422             status = 1;
5423     }
5424
5425     /* If they are at EOF but buf_sv has something in it, then they may never
5426        have touched the SV upstream, so it may be undefined.  If we naively
5427        concatenate it then we get a warning about use of uninitialised value.
5428     */
5429     if (!err && upstream != buf_sv &&
5430         (SvOK(upstream) || SvGMAGICAL(upstream))) {
5431         sv_catsv(buf_sv, upstream);
5432     }
5433
5434     if (status <= 0) {
5435         IoLINES(datasv) = 0;
5436         if (filter_state) {
5437             SvREFCNT_dec(filter_state);
5438             IoTOP_GV(datasv) = NULL;
5439         }
5440         if (filter_sub) {
5441             SvREFCNT_dec(filter_sub);
5442             IoBOTTOM_GV(datasv) = NULL;
5443         }
5444         filter_del(S_run_user_filter);
5445     }
5446
5447     if (err)
5448         croak_sv(err);
5449
5450     if (status == 0 && read_from_cache) {
5451         /* If we read some data from the cache (and by getting here it implies
5452            that we emptied the cache) then we aren't yet at EOF, and mustn't
5453            report that to our caller.  */
5454         return 1;
5455     }
5456     return status;
5457 }
5458
5459 /* perhaps someone can come up with a better name for
5460    this?  it is not really "absolute", per se ... */
5461 static bool
5462 S_path_is_absolute(const char *name)
5463 {
5464     PERL_ARGS_ASSERT_PATH_IS_ABSOLUTE;
5465
5466     if (PERL_FILE_IS_ABSOLUTE(name)
5467 #ifdef WIN32
5468         || (*name == '.' && ((name[1] == '/' ||
5469                              (name[1] == '.' && name[2] == '/'))
5470                          || (name[1] == '\\' ||
5471                              ( name[1] == '.' && name[2] == '\\')))
5472             )
5473 #else
5474         || (*name == '.' && (name[1] == '/' ||
5475                              (name[1] == '.' && name[2] == '/')))
5476 #endif
5477          )
5478     {
5479         return TRUE;
5480     }
5481     else
5482         return FALSE;
5483 }
5484
5485 /*
5486  * Local variables:
5487  * c-indentation-style: bsd
5488  * c-basic-offset: 4
5489  * indent-tabs-mode: nil
5490  * End:
5491  *
5492  * ex: set ts=8 sts=4 sw=4 et:
5493  */