pp_ctl.c

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