pp_ctl.c

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