pp_ctl.c

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