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