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