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 =
3278             PL_curcop == &PL_compiling
3279                 ? PL_cop_seqmax
3280                 : PL_curcop->cop_seq;
3281
3282     for (si = PL_curstackinfo; si; si = si->si_prev) {
3283         I32 ix;
3284         for (ix = si->si_cxix; ix >= 0; ix--) {
3285             const PERL_CONTEXT *cx = &(si->si_cxstack[ix]);
3286             CV *cv = NULL;
3287             if (CxTYPE(cx) == CXt_SUB || CxTYPE(cx) == CXt_FORMAT) {
3288                 cv = cx->blk_sub.cv;
3289                 /* skip DB:: code */
3290                 if (db_seqp && PL_debstash && CvSTASH(cv) == PL_debstash) {
3291                     *db_seqp = cx->blk_oldcop->cop_seq;
3292                     continue;
3293                 }
3294                 if (cx->cx_type & CXp_SUB_RE)
3295                     continue;
3296             }
3297             else if (CxTYPE(cx) == CXt_EVAL && !CxTRYBLOCK(cx))
3298                 cv = cx->blk_eval.cv;
3299             if (cv) {
3300                 switch (cond) {
3301                 case FIND_RUNCV_padid_eq:
3302                     if (!CvPADLIST(cv)
3303                      || PadlistNAMES(CvPADLIST(cv)) != INT2PTR(PADNAMELIST *, arg))
3304                         continue;
3305                     return cv;
3306                 case FIND_RUNCV_level_eq:
3307                     if (level++ != arg) continue;
3308                     /* GERONIMO! */
3309                 default:
3310                     return cv;
3311                 }
3312             }
3313         }
3314     }
3315     return cond == FIND_RUNCV_padid_eq ? NULL : PL_main_cv;
3316 }
3317
3318
3319 /* Run yyparse() in a setjmp wrapper. Returns:
3320  *   0: yyparse() successful
3321  *   1: yyparse() failed
3322  *   3: yyparse() died
3323  */
3324 STATIC int
3325 S_try_yyparse(pTHX_ int gramtype)
3326 {
3327     int ret;
3328     dJMPENV;
3329
3330     assert(CxTYPE(&cxstack[cxstack_ix]) == CXt_EVAL);
3331     JMPENV_PUSH(ret);
3332     switch (ret) {
3333     case 0:
3334         ret = yyparse(gramtype) ? 1 : 0;
3335         break;
3336     case 3:
3337         break;
3338     default:
3339         JMPENV_POP;
3340         JMPENV_JUMP(ret);
3341         assert(0); /* NOTREACHED */
3342     }
3343     JMPENV_POP;
3344     return ret;
3345 }
3346
3347
3348 /* Compile a require/do or an eval ''.
3349  *
3350  * outside is the lexically enclosing CV (if any) that invoked us.
3351  * seq     is the current COP scope value.
3352  * hh      is the saved hints hash, if any.
3353  *
3354  * Returns a bool indicating whether the compile was successful; if so,
3355  * PL_eval_start contains the first op of the compiled code; otherwise,
3356  * pushes undef.
3357  *
3358  * This function is called from two places: pp_require and pp_entereval.
3359  * These can be distinguished by whether PL_op is entereval.
3360  */
3361
3362 STATIC bool
3363 S_doeval(pTHX_ int gimme, CV* outside, U32 seq, HV *hh)
3364 {
3365     dVAR; dSP;
3366     OP * const saveop = PL_op;
3367     bool clear_hints = saveop->op_type != OP_ENTEREVAL;
3368     COP * const oldcurcop = PL_curcop;
3369     bool in_require = (saveop->op_type == OP_REQUIRE);
3370     int yystatus;
3371     CV *evalcv;
3372
3373     PL_in_eval = (in_require
3374                   ? (EVAL_INREQUIRE | (PL_in_eval & EVAL_INEVAL))
3375                   : (EVAL_INEVAL |
3376                         ((PL_op->op_private & OPpEVAL_RE_REPARSING)
3377                             ? EVAL_RE_REPARSING : 0)));
3378
3379     PUSHMARK(SP);
3380
3381     evalcv = MUTABLE_CV(newSV_type(SVt_PVCV));
3382     CvEVAL_on(evalcv);
3383     assert(CxTYPE(&cxstack[cxstack_ix]) == CXt_EVAL);
3384     cxstack[cxstack_ix].blk_eval.cv = evalcv;
3385     cxstack[cxstack_ix].blk_gimme = gimme;
3386
3387     CvOUTSIDE_SEQ(evalcv) = seq;
3388     CvOUTSIDE(evalcv) = MUTABLE_CV(SvREFCNT_inc_simple(outside));
3389
3390     /* set up a scratch pad */
3391
3392     CvPADLIST(evalcv) = pad_new(padnew_SAVE);
3393     PL_op = NULL; /* avoid PL_op and PL_curpad referring to different CVs */
3394
3395
3396     if (!PL_madskills)
3397         SAVEMORTALIZESV(evalcv);        /* must remain until end of current statement */
3398
3399     /* make sure we compile in the right package */
3400
3401     if (CopSTASH_ne(PL_curcop, PL_curstash)) {
3402         SAVEGENERICSV(PL_curstash);
3403         PL_curstash = (HV *)CopSTASH(PL_curcop);
3404         if (SvTYPE(PL_curstash) != SVt_PVHV) PL_curstash = NULL;
3405         else SvREFCNT_inc_simple_void(PL_curstash);
3406     }
3407     /* XXX:ajgo do we really need to alloc an AV for begin/checkunit */
3408     SAVESPTR(PL_beginav);
3409     PL_beginav = newAV();
3410     SAVEFREESV(PL_beginav);
3411     SAVESPTR(PL_unitcheckav);
3412     PL_unitcheckav = newAV();
3413     SAVEFREESV(PL_unitcheckav);
3414
3415 #ifdef PERL_MAD
3416     SAVEBOOL(PL_madskills);
3417     PL_madskills = 0;
3418 #endif
3419
3420     ENTER_with_name("evalcomp");
3421     SAVESPTR(PL_compcv);
3422     PL_compcv = evalcv;
3423
3424     /* try to compile it */
3425
3426     PL_eval_root = NULL;
3427     PL_curcop = &PL_compiling;
3428     if ((saveop->op_type != OP_REQUIRE) && (saveop->op_flags & OPf_SPECIAL))
3429         PL_in_eval |= EVAL_KEEPERR;
3430     else
3431         CLEAR_ERRSV();
3432
3433     SAVEHINTS();
3434     if (clear_hints) {
3435         PL_hints = 0;
3436         hv_clear(GvHV(PL_hintgv));
3437     }
3438     else {
3439         PL_hints = saveop->op_private & OPpEVAL_COPHH
3440                      ? oldcurcop->cop_hints : saveop->op_targ;
3441
3442         /* making 'use re eval' not be in scope when compiling the
3443          * qr/mabye_has_runtime_code_block/ ensures that we don't get
3444          * infinite recursion when S_has_runtime_code() gives a false
3445          * positive: the second time round, HINT_RE_EVAL isn't set so we
3446          * don't bother calling S_has_runtime_code() */
3447         if (PL_in_eval & EVAL_RE_REPARSING)
3448             PL_hints &= ~HINT_RE_EVAL;
3449
3450         if (hh) {
3451             /* SAVEHINTS created a new HV in PL_hintgv, which we need to GC */
3452             SvREFCNT_dec(GvHV(PL_hintgv));
3453             GvHV(PL_hintgv) = hh;
3454         }
3455     }
3456     SAVECOMPILEWARNINGS();
3457     if (clear_hints) {
3458         if (PL_dowarn & G_WARN_ALL_ON)
3459             PL_compiling.cop_warnings = pWARN_ALL ;
3460         else if (PL_dowarn & G_WARN_ALL_OFF)
3461             PL_compiling.cop_warnings = pWARN_NONE ;
3462         else
3463             PL_compiling.cop_warnings = pWARN_STD ;
3464     }
3465     else {
3466         PL_compiling.cop_warnings =
3467             DUP_WARNINGS(oldcurcop->cop_warnings);
3468         cophh_free(CopHINTHASH_get(&PL_compiling));
3469         if (Perl_cop_fetch_label(aTHX_ oldcurcop, NULL, NULL)) {
3470             /* The label, if present, is the first entry on the chain. So rather
3471                than writing a blank label in front of it (which involves an
3472                allocation), just use the next entry in the chain.  */
3473             PL_compiling.cop_hints_hash
3474                 = cophh_copy(oldcurcop->cop_hints_hash->refcounted_he_next);
3475             /* Check the assumption that this removed the label.  */
3476             assert(Perl_cop_fetch_label(aTHX_ &PL_compiling, NULL, NULL) == NULL);
3477         }
3478         else
3479             PL_compiling.cop_hints_hash = cophh_copy(oldcurcop->cop_hints_hash);
3480     }
3481
3482     CALL_BLOCK_HOOKS(bhk_eval, saveop);
3483
3484     /* note that yyparse() may raise an exception, e.g. C<BEGIN{die}>,
3485      * so honour CATCH_GET and trap it here if necessary */
3486
3487     yystatus = (!in_require && CATCH_GET) ? S_try_yyparse(aTHX_ GRAMPROG) : yyparse(GRAMPROG);
3488
3489     if (yystatus || PL_parser->error_count || !PL_eval_root) {
3490         SV **newsp;                     /* Used by POPBLOCK. */
3491         PERL_CONTEXT *cx;
3492         I32 optype;                     /* Used by POPEVAL. */
3493         SV *namesv;
3494         SV *errsv = NULL;
3495
3496         cx = NULL;
3497         namesv = NULL;
3498         PERL_UNUSED_VAR(newsp);
3499         PERL_UNUSED_VAR(optype);
3500
3501         /* note that if yystatus == 3, then the EVAL CX block has already
3502          * been popped, and various vars restored */
3503         PL_op = saveop;
3504         if (yystatus != 3) {
3505             if (PL_eval_root) {
3506                 op_free(PL_eval_root);
3507                 PL_eval_root = NULL;
3508             }
3509             SP = PL_stack_base + POPMARK;       /* pop original mark */
3510             POPBLOCK(cx,PL_curpm);
3511             POPEVAL(cx);
3512             namesv = cx->blk_eval.old_namesv;
3513             /* POPBLOCK renders LEAVE_with_name("evalcomp") unnecessary. */
3514             LEAVE_with_name("eval"); /* pp_entereval knows about this LEAVE.  */
3515         }
3516
3517         errsv = ERRSV;
3518         if (in_require) {
3519             if (!cx) {
3520                 /* If cx is still NULL, it means that we didn't go in the
3521                  * POPEVAL branch. */
3522                 cx = &cxstack[cxstack_ix];
3523                 assert(CxTYPE(cx) == CXt_EVAL);
3524                 namesv = cx->blk_eval.old_namesv;
3525             }
3526             (void)hv_store(GvHVn(PL_incgv),
3527                            SvPVX_const(namesv),
3528                            SvUTF8(namesv) ? -(I32)SvCUR(namesv) : (I32)SvCUR(namesv),
3529                            &PL_sv_undef, 0);
3530             Perl_croak(aTHX_ "%"SVf"Compilation failed in require",
3531                        SVfARG(errsv
3532                                 ? errsv
3533                                 : newSVpvs_flags("Unknown error\n", SVs_TEMP)));
3534         }
3535         else {
3536             if (!*(SvPV_nolen_const(errsv))) {
3537                 sv_setpvs(errsv, "Compilation error");
3538             }
3539         }
3540         if (gimme != G_ARRAY) PUSHs(&PL_sv_undef);
3541         PUTBACK;
3542         return FALSE;
3543     }
3544     else
3545         LEAVE_with_name("evalcomp");
3546
3547     CopLINE_set(&PL_compiling, 0);
3548     SAVEFREEOP(PL_eval_root);
3549     cv_forget_slab(evalcv);
3550
3551     DEBUG_x(dump_eval());
3552
3553     /* Register with debugger: */
3554     if (PERLDB_INTER && saveop->op_type == OP_REQUIRE) {
3555         CV * const cv = get_cvs("DB::postponed", 0);
3556         if (cv) {
3557             dSP;
3558             PUSHMARK(SP);
3559             XPUSHs(MUTABLE_SV(CopFILEGV(&PL_compiling)));
3560             PUTBACK;
3561             call_sv(MUTABLE_SV(cv), G_DISCARD);
3562         }
3563     }
3564
3565     if (PL_unitcheckav) {
3566         OP *es = PL_eval_start;
3567         call_list(PL_scopestack_ix, PL_unitcheckav);
3568         PL_eval_start = es;
3569     }
3570
3571     /* compiled okay, so do it */
3572
3573     CvDEPTH(evalcv) = 1;
3574     SP = PL_stack_base + POPMARK;               /* pop original mark */
3575     PL_op = saveop;                     /* The caller may need it. */
3576     PL_parser->lex_state = LEX_NOTPARSING;      /* $^S needs this. */
3577
3578     PUTBACK;
3579     return TRUE;
3580 }
3581
3582 STATIC PerlIO *
3583 S_check_type_and_open(pTHX_ SV *name)
3584 {
3585     Stat_t st;
3586     const char *p = SvPV_nolen_const(name);
3587     const int st_rc = PerlLIO_stat(p, &st);
3588
3589     PERL_ARGS_ASSERT_CHECK_TYPE_AND_OPEN;
3590
3591     if (st_rc < 0 || S_ISDIR(st.st_mode) || S_ISBLK(st.st_mode)) {
3592         return NULL;
3593     }
3594
3595 #if !defined(PERLIO_IS_STDIO) && !defined(USE_SFIO)
3596     return PerlIO_openn(aTHX_ ":", PERL_SCRIPT_MODE, -1, 0, 0, NULL, 1, &name);
3597 #else
3598     return PerlIO_open(p, PERL_SCRIPT_MODE);
3599 #endif
3600 }
3601
3602 #ifndef PERL_DISABLE_PMC
3603 STATIC PerlIO *
3604 S_doopen_pm(pTHX_ SV *name)
3605 {
3606     STRLEN namelen;
3607     const char *p = SvPV_const(name, namelen);
3608
3609     PERL_ARGS_ASSERT_DOOPEN_PM;
3610
3611     if (namelen > 3 && memEQs(p + namelen - 3, 3, ".pm")) {
3612         SV *const pmcsv = sv_newmortal();
3613         Stat_t pmcstat;
3614
3615         SvSetSV_nosteal(pmcsv,name);
3616         sv_catpvn(pmcsv, "c", 1);
3617
3618         if (PerlLIO_stat(SvPV_nolen_const(pmcsv), &pmcstat) >= 0)
3619             return check_type_and_open(pmcsv);
3620     }
3621     return check_type_and_open(name);
3622 }
3623 #else
3624 #  define doopen_pm(name) check_type_and_open(name)
3625 #endif /* !PERL_DISABLE_PMC */
3626
3627 /* require doesn't search for absolute names, or when the name is
3628    explicity relative the current directory */
3629 PERL_STATIC_INLINE bool
3630 S_path_is_searchable(const char *name)
3631 {
3632     PERL_ARGS_ASSERT_PATH_IS_SEARCHABLE;
3633
3634     if (PERL_FILE_IS_ABSOLUTE(name)
3635 #ifdef WIN32
3636         || (*name == '.' && ((name[1] == '/' ||
3637                              (name[1] == '.' && name[2] == '/'))
3638                          || (name[1] == '\\' ||
3639                              ( name[1] == '.' && name[2] == '\\')))
3640             )
3641 #else
3642         || (*name == '.' && (name[1] == '/' ||
3643                              (name[1] == '.' && name[2] == '/')))
3644 #endif
3645          )
3646     {
3647         return FALSE;
3648     }
3649     else
3650         return TRUE;
3651 }
3652
3653 PP(pp_require)
3654 {
3655     dVAR; dSP;
3656     PERL_CONTEXT *cx;
3657     SV *sv;
3658     const char *name;
3659     STRLEN len;
3660     char * unixname;
3661     STRLEN unixlen;
3662 #ifdef VMS
3663     int vms_unixname = 0;
3664     char *unixnamebuf;
3665     char *unixdir;
3666     char *unixdirbuf;
3667 #endif
3668     const char *tryname = NULL;
3669     SV *namesv = NULL;
3670     const I32 gimme = GIMME_V;
3671     int filter_has_file = 0;
3672     PerlIO *tryrsfp = NULL;
3673     SV *filter_cache = NULL;
3674     SV *filter_state = NULL;
3675     SV *filter_sub = NULL;
3676     SV *hook_sv = NULL;
3677     SV *encoding;
3678     OP *op;
3679     int saved_errno;
3680     bool path_searchable;
3681
3682     sv = POPs;
3683     if ( (SvNIOKp(sv) || SvVOK(sv)) && PL_op->op_type != OP_DOFILE) {
3684         sv = sv_2mortal(new_version(sv));
3685         if (!Perl_sv_derived_from_pvn(aTHX_ PL_patchlevel, STR_WITH_LEN("version"), 0))
3686             upg_version(PL_patchlevel, TRUE);
3687         if (cUNOP->op_first->op_type == OP_CONST && cUNOP->op_first->op_private & OPpCONST_NOVER) {
3688             if ( vcmp(sv,PL_patchlevel) <= 0 )
3689                 DIE(aTHX_ "Perls since %"SVf" too modern--this is %"SVf", stopped",
3690                     SVfARG(sv_2mortal(vnormal(sv))),
3691                     SVfARG(sv_2mortal(vnormal(PL_patchlevel)))
3692                 );
3693         }
3694         else {
3695             if ( vcmp(sv,PL_patchlevel) > 0 ) {
3696                 I32 first = 0;
3697                 AV *lav;
3698                 SV * const req = SvRV(sv);
3699                 SV * const pv = *hv_fetchs(MUTABLE_HV(req), "original", FALSE);
3700
3701                 /* get the left hand term */
3702                 lav = MUTABLE_AV(SvRV(*hv_fetchs(MUTABLE_HV(req), "version", FALSE)));
3703
3704                 first  = SvIV(*av_fetch(lav,0,0));
3705                 if (   first > (int)PERL_REVISION    /* probably 'use 6.0' */
3706                     || hv_exists(MUTABLE_HV(req), "qv", 2 ) /* qv style */
3707                     || av_len(lav) > 1               /* FP with > 3 digits */
3708                     || strstr(SvPVX(pv),".0")        /* FP with leading 0 */
3709                    ) {
3710                     DIE(aTHX_ "Perl %"SVf" required--this is only "
3711                         "%"SVf", stopped",
3712                         SVfARG(sv_2mortal(vnormal(req))),
3713                         SVfARG(sv_2mortal(vnormal(PL_patchlevel)))
3714                     );
3715                 }
3716                 else { /* probably 'use 5.10' or 'use 5.8' */
3717                     SV *hintsv;
3718                     I32 second = 0;
3719
3720                     if (av_len(lav)>=1)
3721                         second = SvIV(*av_fetch(lav,1,0));
3722
3723                     second /= second >= 600  ? 100 : 10;
3724                     hintsv = Perl_newSVpvf(aTHX_ "v%d.%d.0",
3725                                            (int)first, (int)second);
3726                     upg_version(hintsv, TRUE);
3727
3728                     DIE(aTHX_ "Perl %"SVf" required (did you mean %"SVf"?)"
3729                         "--this is only %"SVf", stopped",
3730                         SVfARG(sv_2mortal(vnormal(req))),
3731                         SVfARG(sv_2mortal(vnormal(sv_2mortal(hintsv)))),
3732                         SVfARG(sv_2mortal(vnormal(PL_patchlevel)))
3733                     );
3734                 }
3735             }
3736         }
3737
3738         RETPUSHYES;
3739     }
3740     name = SvPV_const(sv, len);
3741     if (!(name && len > 0 && *name))
3742         DIE(aTHX_ "Null filename used");
3743     TAINT_PROPER("require");
3744
3745     path_searchable = path_is_searchable(name);
3746
3747 #ifdef VMS
3748     /* The key in the %ENV hash is in the syntax of file passed as the argument
3749      * usually this is in UNIX format, but sometimes in VMS format, which
3750      * can result in a module being pulled in more than once.
3751      * To prevent this, the key must be stored in UNIX format if the VMS
3752      * name can be translated to UNIX.
3753      */
3754
3755     if ((unixnamebuf = SvPVX(sv_2mortal(newSVpv("", VMS_MAXRSS-1))))
3756         && (unixname = tounixspec(name, unixnamebuf)) != NULL) {
3757         unixlen = strlen(unixname);
3758         vms_unixname = 1;
3759     }
3760     else
3761 #endif
3762     {
3763         /* if not VMS or VMS name can not be translated to UNIX, pass it
3764          * through.
3765          */
3766         unixname = (char *) name;
3767         unixlen = len;
3768     }
3769     if (PL_op->op_type == OP_REQUIRE) {
3770         SV * const * const svp = hv_fetch(GvHVn(PL_incgv),
3771                                           unixname, unixlen, 0);
3772         if ( svp ) {
3773             if (*svp != &PL_sv_undef)
3774                 RETPUSHYES;
3775             else
3776                 DIE(aTHX_ "Attempt to reload %s aborted.\n"
3777                             "Compilation failed in require", unixname);
3778         }
3779     }
3780
3781     LOADING_FILE_PROBE(unixname);
3782
3783     /* prepare to compile file */
3784
3785     if (!path_searchable) {
3786         /* At this point, name is SvPVX(sv)  */
3787         tryname = name;
3788         tryrsfp = doopen_pm(sv);
3789     }
3790     if (!tryrsfp && !(errno == EACCES && !path_searchable)) {
3791         AV * const ar = GvAVn(PL_incgv);
3792         I32 i;
3793 #ifdef VMS
3794         if (vms_unixname)
3795 #endif
3796         {
3797             namesv = newSV_type(SVt_PV);
3798             for (i = 0; i <= AvFILL(ar); i++) {
3799                 SV * const dirsv = *av_fetch(ar, i, TRUE);
3800
3801                 if (SvTIED_mg((const SV *)ar, PERL_MAGIC_tied))
3802                     mg_get(dirsv);
3803                 if (SvROK(dirsv)) {
3804                     int count;
3805                     SV **svp;
3806                     SV *loader = dirsv;
3807
3808                     if (SvTYPE(SvRV(loader)) == SVt_PVAV
3809                         && !sv_isobject(loader))
3810                     {
3811                         loader = *av_fetch(MUTABLE_AV(SvRV(loader)), 0, TRUE);
3812                     }
3813
3814                     Perl_sv_setpvf(aTHX_ namesv, "/loader/0x%"UVxf"/%s",
3815                                    PTR2UV(SvRV(dirsv)), name);
3816                     tryname = SvPVX_const(namesv);
3817                     tryrsfp = NULL;
3818
3819                     ENTER_with_name("call_INC");
3820                     SAVETMPS;
3821                     EXTEND(SP, 2);
3822
3823                     PUSHMARK(SP);
3824                     PUSHs(dirsv);
3825                     PUSHs(sv);
3826                     PUTBACK;
3827                     if (sv_isobject(loader))
3828                         count = call_method("INC", G_ARRAY);
3829                     else
3830                         count = call_sv(loader, G_ARRAY);
3831                     SPAGAIN;
3832
3833                     if (count > 0) {
3834                         int i = 0;
3835                         SV *arg;
3836
3837                         SP -= count - 1;
3838                         arg = SP[i++];
3839
3840                         if (SvROK(arg) && (SvTYPE(SvRV(arg)) <= SVt_PVLV)
3841                             && !isGV_with_GP(SvRV(arg))) {
3842                             filter_cache = SvRV(arg);
3843
3844                             if (i < count) {
3845                                 arg = SP[i++];
3846                             }
3847                         }
3848
3849                         if (SvROK(arg) && isGV_with_GP(SvRV(arg))) {
3850                             arg = SvRV(arg);
3851                         }
3852
3853                         if (isGV_with_GP(arg)) {
3854                             IO * const io = GvIO((const GV *)arg);
3855
3856                             ++filter_has_file;
3857
3858                             if (io) {
3859                                 tryrsfp = IoIFP(io);
3860                                 if (IoOFP(io) && IoOFP(io) != IoIFP(io)) {
3861                                     PerlIO_close(IoOFP(io));
3862                                 }
3863                                 IoIFP(io) = NULL;
3864                                 IoOFP(io) = NULL;
3865                             }
3866
3867                             if (i < count) {
3868                                 arg = SP[i++];
3869                             }
3870                         }
3871
3872                         if (SvROK(arg) && SvTYPE(SvRV(arg)) == SVt_PVCV) {
3873                             filter_sub = arg;
3874                             SvREFCNT_inc_simple_void_NN(filter_sub);
3875
3876                             if (i < count) {
3877                                 filter_state = SP[i];
3878                                 SvREFCNT_inc_simple_void(filter_state);
3879                             }
3880                         }
3881
3882                         if (!tryrsfp && (filter_cache || filter_sub)) {
3883                             tryrsfp = PerlIO_open(BIT_BUCKET,
3884                                                   PERL_SCRIPT_MODE);
3885                         }
3886                         SP--;
3887                     }
3888
3889                     PUTBACK;
3890                     FREETMPS;
3891                     LEAVE_with_name("call_INC");
3892
3893                     /* Adjust file name if the hook has set an %INC entry.
3894                        This needs to happen after the FREETMPS above.  */
3895                     svp = hv_fetch(GvHVn(PL_incgv), name, len, 0);
3896                     if (svp)
3897                         tryname = SvPV_nolen_const(*svp);
3898
3899                     if (tryrsfp) {
3900                         hook_sv = dirsv;
3901                         break;
3902                     }
3903
3904                     filter_has_file = 0;
3905                     filter_cache = NULL;
3906                     if (filter_state) {
3907                         SvREFCNT_dec(filter_state);
3908                         filter_state = NULL;
3909                     }
3910                     if (filter_sub) {
3911                         SvREFCNT_dec(filter_sub);
3912                         filter_sub = NULL;
3913                     }
3914                 }
3915                 else {
3916                   if (path_searchable) {
3917                     const char *dir;
3918                     STRLEN dirlen;
3919
3920                     if (SvOK(dirsv)) {
3921                         dir = SvPV_const(dirsv, dirlen);
3922                     } else {
3923                         dir = "";
3924                         dirlen = 0;
3925                     }
3926
3927 #ifdef VMS
3928                     if (((unixdirbuf = SvPVX(sv_2mortal(newSVpv("", VMS_MAXRSS-1)))) == NULL)
3929                         || ((unixdir = tounixpath(dir, unixdirbuf)) == NULL))
3930                         continue;
3931                     sv_setpv(namesv, unixdir);
3932                     sv_catpv(namesv, unixname);
3933 #else
3934 #  ifdef __SYMBIAN32__
3935                     if (PL_origfilename[0] &&
3936                         PL_origfilename[1] == ':' &&
3937                         !(dir[0] && dir[1] == ':'))
3938                         Perl_sv_setpvf(aTHX_ namesv,
3939                                        "%c:%s\\%s",
3940                                        PL_origfilename[0],
3941                                        dir, name);
3942                     else
3943                         Perl_sv_setpvf(aTHX_ namesv,
3944                                        "%s\\%s",
3945                                        dir, name);
3946 #  else
3947                     /* The equivalent of
3948                        Perl_sv_setpvf(aTHX_ namesv, "%s/%s", dir, name);
3949                        but without the need to parse the format string, or
3950                        call strlen on either pointer, and with the correct
3951                        allocation up front.  */
3952                     {
3953                         char *tmp = SvGROW(namesv, dirlen + len + 2);
3954
3955                         memcpy(tmp, dir, dirlen);
3956                         tmp +=dirlen;
3957
3958                         /* Avoid '<dir>//<file>' */
3959                         if (!dirlen || *(tmp-1) != '/') {
3960                             *tmp++ = '/';
3961                         }
3962
3963                         /* name came from an SV, so it will have a '\0' at the
3964                            end that we can copy as part of this memcpy().  */
3965                         memcpy(tmp, name, len + 1);
3966
3967                         SvCUR_set(namesv, dirlen + len + 1);
3968                         SvPOK_on(namesv);
3969                     }
3970 #  endif
3971 #endif
3972                     TAINT_PROPER("require");
3973                     tryname = SvPVX_const(namesv);
3974                     tryrsfp = doopen_pm(namesv);
3975                     if (tryrsfp) {
3976                         if (tryname[0] == '.' && tryname[1] == '/') {
3977                             ++tryname;
3978                             while (*++tryname == '/') {}
3979                         }
3980                         break;
3981                     }
3982                     else if (errno == EMFILE || errno == EACCES) {
3983                         /* no point in trying other paths if out of handles;
3984                          * on the other hand, if we couldn't open one of the
3985                          * files, then going on with the search could lead to
3986                          * unexpected results; see perl #113422
3987                          */
3988                         break;
3989                     }
3990                   }
3991                 }
3992             }
3993         }
3994     }
3995     saved_errno = errno; /* sv_2mortal can realloc things */
3996     sv_2mortal(namesv);
3997     if (!tryrsfp) {
3998         if (PL_op->op_type == OP_REQUIRE) {
3999             if(saved_errno == EMFILE || saved_errno == EACCES) {
4000                 /* diag_listed_as: Can't locate %s */
4001                 DIE(aTHX_ "Can't locate %s:   %s", name, Strerror(saved_errno));
4002             } else {
4003                 if (namesv) {                   /* did we lookup @INC? */
4004                     AV * const ar = GvAVn(PL_incgv);
4005                     I32 i;
4006                     SV *const msg = newSVpvs_flags("", SVs_TEMP);
4007                     SV *const inc = newSVpvs_flags("", SVs_TEMP);
4008                     for (i = 0; i <= AvFILL(ar); i++) {
4009                         sv_catpvs(inc, " ");
4010                         sv_catsv(inc, *av_fetch(ar, i, TRUE));
4011                     }
4012                     if (len >= 4 && memEQ(name + len - 3, ".pm", 4)) {
4013                         const char *c, *e = name + len - 3;
4014                         sv_catpv(msg, " (you may need to install the ");
4015                         for (c = name; c < e; c++) {
4016                             if (*c == '/') {
4017                                 sv_catpvn(msg, "::", 2);
4018                             }
4019                             else {
4020                                 sv_catpvn(msg, c, 1);
4021                             }
4022                         }
4023                         sv_catpv(msg, " module)");
4024                     }
4025                     else if (len >= 2 && memEQ(name + len - 2, ".h", 3)) {
4026                         sv_catpv(msg, " (change .h to .ph maybe?) (did you run h2ph?)");
4027                     }
4028                     else if (len >= 3 && memEQ(name + len - 3, ".ph", 4)) {
4029                         sv_catpv(msg, " (did you run h2ph?)");
4030                     }
4031
4032                     /* diag_listed_as: Can't locate %s */
4033                     DIE(aTHX_
4034                         "Can't locate %s in @INC%" SVf " (@INC contains:%" SVf ")",
4035                         name, msg, inc);
4036                 }
4037             }
4038             DIE(aTHX_ "Can't locate %s", name);
4039         }
4040
4041         CLEAR_ERRSV();
4042         RETPUSHUNDEF;
4043     }
4044     else
4045         SETERRNO(0, SS_NORMAL);
4046
4047     /* Assume success here to prevent recursive requirement. */
4048     /* name is never assigned to again, so len is still strlen(name)  */
4049     /* Check whether a hook in @INC has already filled %INC */
4050     if (!hook_sv) {
4051         (void)hv_store(GvHVn(PL_incgv),
4052                        unixname, unixlen, newSVpv(tryname,0),0);
4053     } else {
4054         SV** const svp = hv_fetch(GvHVn(PL_incgv), unixname, unixlen, 0);
4055         if (!svp)
4056             (void)hv_store(GvHVn(PL_incgv),
4057                            unixname, unixlen, SvREFCNT_inc_simple(hook_sv), 0 );
4058     }
4059
4060     ENTER_with_name("eval");
4061     SAVETMPS;
4062     SAVECOPFILE_FREE(&PL_compiling);
4063     CopFILE_set(&PL_compiling, tryname);
4064     lex_start(NULL, tryrsfp, 0);
4065
4066     if (filter_sub || filter_cache) {
4067         /* We can use the SvPV of the filter PVIO itself as our cache, rather
4068            than hanging another SV from it. In turn, filter_add() optionally
4069            takes the SV to use as the filter (or creates a new SV if passed
4070            NULL), so simply pass in whatever value filter_cache has.  */
4071         SV * const fc = filter_cache ? newSV(0) : NULL;
4072         SV *datasv;
4073         if (fc) sv_copypv(fc, filter_cache);
4074         datasv = filter_add(S_run_user_filter, fc);
4075         IoLINES(datasv) = filter_has_file;
4076         IoTOP_GV(datasv) = MUTABLE_GV(filter_state);
4077         IoBOTTOM_GV(datasv) = MUTABLE_GV(filter_sub);
4078     }
4079
4080     /* switch to eval mode */
4081     PUSHBLOCK(cx, CXt_EVAL, SP);
4082     PUSHEVAL(cx, name);
4083     cx->blk_eval.retop = PL_op->op_next;
4084
4085     SAVECOPLINE(&PL_compiling);
4086     CopLINE_set(&PL_compiling, 0);
4087
4088     PUTBACK;
4089
4090     /* Store and reset encoding. */
4091     encoding = PL_encoding;
4092     PL_encoding = NULL;
4093
4094     if (doeval(gimme, NULL, PL_curcop->cop_seq, NULL))
4095         op = DOCATCH(PL_eval_start);
4096     else
4097         op = PL_op->op_next;
4098
4099     /* Restore encoding. */
4100     PL_encoding = encoding;
4101
4102     LOADED_FILE_PROBE(unixname);
4103
4104     return op;
4105 }
4106
4107 /* This is a op added to hold the hints hash for
4108    pp_entereval. The hash can be modified by the code
4109    being eval'ed, so we return a copy instead. */
4110
4111 PP(pp_hintseval)
4112 {
4113     dVAR;
4114     dSP;
4115     mXPUSHs(MUTABLE_SV(hv_copy_hints_hv(MUTABLE_HV(cSVOP_sv))));
4116     RETURN;
4117 }
4118
4119
4120 PP(pp_entereval)
4121 {
4122     dVAR; dSP;
4123     PERL_CONTEXT *cx;
4124     SV *sv;
4125     const I32 gimme = GIMME_V;
4126     const U32 was = PL_breakable_sub_gen;
4127     char tbuf[TYPE_DIGITS(long) + 12];
4128     bool saved_delete = FALSE;
4129     char *tmpbuf = tbuf;
4130     STRLEN len;
4131     CV* runcv;
4132     U32 seq, lex_flags = 0;
4133     HV *saved_hh = NULL;
4134     const bool bytes = PL_op->op_private & OPpEVAL_BYTES;
4135
4136     if (PL_op->op_private & OPpEVAL_HAS_HH) {
4137         saved_hh = MUTABLE_HV(SvREFCNT_inc(POPs));
4138     }
4139     else if (PL_hints & HINT_LOCALIZE_HH || (
4140                 PL_op->op_private & OPpEVAL_COPHH
4141              && PL_curcop->cop_hints & HINT_LOCALIZE_HH
4142             )) {
4143         saved_hh = cop_hints_2hv(PL_curcop, 0);
4144         hv_magic(saved_hh, NULL, PERL_MAGIC_hints);
4145     }
4146     sv = POPs;
4147     if (!SvPOK(sv)) {
4148         /* make sure we've got a plain PV (no overload etc) before testing
4149          * for taint. Making a copy here is probably overkill, but better
4150          * safe than sorry */
4151         STRLEN len;
4152         const char * const p = SvPV_const(sv, len);
4153
4154         sv = newSVpvn_flags(p, len, SVs_TEMP | SvUTF8(sv));
4155         lex_flags |= LEX_START_COPIED;
4156
4157         if (bytes && SvUTF8(sv))
4158             SvPVbyte_force(sv, len);
4159     }
4160     else if (bytes && SvUTF8(sv)) {
4161         /* Don't modify someone else's scalar */
4162         STRLEN len;
4163         sv = newSVsv(sv);
4164         (void)sv_2mortal(sv);
4165         SvPVbyte_force(sv,len);
4166         lex_flags |= LEX_START_COPIED;
4167     }
4168
4169     TAINT_IF(SvTAINTED(sv));
4170     TAINT_PROPER("eval");
4171
4172     ENTER_with_name("eval");
4173     lex_start(sv, NULL, lex_flags | (PL_op->op_private & OPpEVAL_UNICODE
4174                            ? LEX_IGNORE_UTF8_HINTS
4175                            : bytes ? LEX_EVALBYTES : LEX_START_SAME_FILTER
4176                         )
4177              );
4178     SAVETMPS;
4179
4180     /* switch to eval mode */
4181
4182     if (PERLDB_NAMEEVAL && CopLINE(PL_curcop)) {
4183         SV * const temp_sv = sv_newmortal();
4184         Perl_sv_setpvf(aTHX_ temp_sv, "_<(eval %lu)[%s:%"IVdf"]",
4185                        (unsigned long)++PL_evalseq,
4186                        CopFILE(PL_curcop), (IV)CopLINE(PL_curcop));
4187         tmpbuf = SvPVX(temp_sv);
4188         len = SvCUR(temp_sv);
4189     }
4190     else
4191         len = my_snprintf(tmpbuf, sizeof(tbuf), "_<(eval %lu)", (unsigned long)++PL_evalseq);
4192     SAVECOPFILE_FREE(&PL_compiling);
4193     CopFILE_set(&PL_compiling, tmpbuf+2);
4194     SAVECOPLINE(&PL_compiling);
4195     CopLINE_set(&PL_compiling, 1);
4196     /* special case: an eval '' executed within the DB package gets lexically
4197      * placed in the first non-DB CV rather than the current CV - this
4198      * allows the debugger to execute code, find lexicals etc, in the
4199      * scope of the code being debugged. Passing &seq gets find_runcv
4200      * to do the dirty work for us */
4201     runcv = find_runcv(&seq);
4202
4203     PUSHBLOCK(cx, (CXt_EVAL|CXp_REAL), SP);
4204     PUSHEVAL(cx, 0);
4205     cx->blk_eval.retop = PL_op->op_next;
4206
4207     /* prepare to compile string */
4208
4209     if ((PERLDB_LINE || PERLDB_SAVESRC) && PL_curstash != PL_debstash)
4210         save_lines(CopFILEAV(&PL_compiling), PL_parser->linestr);
4211     else {
4212         /* XXX For C<eval "...">s within BEGIN {} blocks, this ends up
4213            deleting the eval's FILEGV from the stash before gv_check() runs
4214            (i.e. before run-time proper). To work around the coredump that
4215            ensues, we always turn GvMULTI_on for any globals that were
4216            introduced within evals. See force_ident(). GSAR 96-10-12 */
4217         char *const safestr = savepvn(tmpbuf, len);
4218         SAVEDELETE(PL_defstash, safestr, len);
4219         saved_delete = TRUE;
4220     }
4221
4222     PUTBACK;
4223
4224     if (doeval(gimme, runcv, seq, saved_hh)) {
4225         if (was != PL_breakable_sub_gen /* Some subs defined here. */
4226             ? (PERLDB_LINE || PERLDB_SAVESRC)
4227             :  PERLDB_SAVESRC_NOSUBS) {
4228             /* Retain the filegv we created.  */
4229         } else if (!saved_delete) {
4230             char *const safestr = savepvn(tmpbuf, len);
4231             SAVEDELETE(PL_defstash, safestr, len);
4232         }
4233         return DOCATCH(PL_eval_start);
4234     } else {
4235         /* We have already left the scope set up earlier thanks to the LEAVE
4236            in doeval().  */
4237         if (was != PL_breakable_sub_gen /* Some subs defined here. */
4238             ? (PERLDB_LINE || PERLDB_SAVESRC)
4239             :  PERLDB_SAVESRC_INVALID) {
4240             /* Retain the filegv we created.  */
4241         } else if (!saved_delete) {
4242             (void)hv_delete(PL_defstash, tmpbuf, len, G_DISCARD);
4243         }
4244         return PL_op->op_next;
4245     }
4246 }
4247
4248 PP(pp_leaveeval)
4249 {
4250     dVAR; dSP;
4251     SV **newsp;
4252     PMOP *newpm;
4253     I32 gimme;
4254     PERL_CONTEXT *cx;
4255     OP *retop;
4256     const U8 save_flags = PL_op -> op_flags;
4257     I32 optype;
4258     SV *namesv;
4259     CV *evalcv;
4260
4261     PERL_ASYNC_CHECK();
4262     POPBLOCK(cx,newpm);
4263     POPEVAL(cx);
4264     namesv = cx->blk_eval.old_namesv;
4265     retop = cx->blk_eval.retop;
4266     evalcv = cx->blk_eval.cv;
4267
4268     TAINT_NOT;
4269     SP = adjust_stack_on_leave((gimme == G_VOID) ? SP : newsp, SP, newsp,
4270                                 gimme, SVs_TEMP);
4271     PL_curpm = newpm;   /* Don't pop $1 et al till now */
4272
4273 #ifdef DEBUGGING
4274     assert(CvDEPTH(evalcv) == 1);
4275 #endif
4276     CvDEPTH(evalcv) = 0;
4277
4278     if (optype == OP_REQUIRE &&
4279         !(gimme == G_SCALAR ? SvTRUE(*SP) : SP > newsp))
4280     {
4281         /* Unassume the success we assumed earlier. */
4282         (void)hv_delete(GvHVn(PL_incgv),
4283                         SvPVX_const(namesv),
4284                         SvUTF8(namesv) ? -(I32)SvCUR(namesv) : (I32)SvCUR(namesv),
4285                         G_DISCARD);
4286         retop = Perl_die(aTHX_ "%"SVf" did not return a true value",
4287                                SVfARG(namesv));
4288         /* die_unwind() did LEAVE, or we won't be here */
4289     }
4290     else {
4291         LEAVE_with_name("eval");
4292         if (!(save_flags & OPf_SPECIAL)) {
4293             CLEAR_ERRSV();
4294         }
4295     }
4296
4297     RETURNOP(retop);
4298 }
4299
4300 /* Common code for Perl_call_sv and Perl_fold_constants, put here to keep it
4301    close to the related Perl_create_eval_scope.  */
4302 void
4303 Perl_delete_eval_scope(pTHX)
4304 {
4305     SV **newsp;
4306     PMOP *newpm;
4307     I32 gimme;
4308     PERL_CONTEXT *cx;
4309     I32 optype;
4310
4311     POPBLOCK(cx,newpm);
4312     POPEVAL(cx);
4313     PL_curpm = newpm;
4314     LEAVE_with_name("eval_scope");
4315     PERL_UNUSED_VAR(newsp);
4316     PERL_UNUSED_VAR(gimme);
4317     PERL_UNUSED_VAR(optype);
4318 }
4319
4320 /* Common-ish code salvaged from Perl_call_sv and pp_entertry, because it was
4321    also needed by Perl_fold_constants.  */
4322 PERL_CONTEXT *
4323 Perl_create_eval_scope(pTHX_ U32 flags)
4324 {
4325     PERL_CONTEXT *cx;
4326     const I32 gimme = GIMME_V;
4327
4328     ENTER_with_name("eval_scope");
4329     SAVETMPS;
4330
4331     PUSHBLOCK(cx, (CXt_EVAL|CXp_TRYBLOCK), PL_stack_sp);
4332     PUSHEVAL(cx, 0);
4333
4334     PL_in_eval = EVAL_INEVAL;
4335     if (flags & G_KEEPERR)
4336         PL_in_eval |= EVAL_KEEPERR;
4337     else
4338         CLEAR_ERRSV();
4339     if (flags & G_FAKINGEVAL) {
4340         PL_eval_root = PL_op; /* Only needed so that goto works right. */
4341     }
4342     return cx;
4343 }
4344
4345 PP(pp_entertry)
4346 {
4347     dVAR;
4348     PERL_CONTEXT * const cx = create_eval_scope(0);
4349     cx->blk_eval.retop = cLOGOP->op_other->op_next;
4350     return DOCATCH(PL_op->op_next);
4351 }
4352
4353 PP(pp_leavetry)
4354 {
4355     dVAR; dSP;
4356     SV **newsp;
4357     PMOP *newpm;
4358     I32 gimme;
4359     PERL_CONTEXT *cx;
4360     I32 optype;
4361
4362     PERL_ASYNC_CHECK();
4363     POPBLOCK(cx,newpm);
4364     POPEVAL(cx);
4365     PERL_UNUSED_VAR(optype);
4366
4367     TAINT_NOT;
4368     SP = adjust_stack_on_leave(newsp, SP, newsp, gimme, SVs_PADTMP|SVs_TEMP);
4369     PL_curpm = newpm;   /* Don't pop $1 et al till now */
4370
4371     LEAVE_with_name("eval_scope");
4372     CLEAR_ERRSV();
4373     RETURN;
4374 }
4375
4376 PP(pp_entergiven)
4377 {
4378     dVAR; dSP;
4379     PERL_CONTEXT *cx;
4380     const I32 gimme = GIMME_V;
4381
4382     ENTER_with_name("given");
4383     SAVETMPS;
4384
4385     if (PL_op->op_targ) {
4386         SAVEPADSVANDMORTALIZE(PL_op->op_targ);
4387         SvREFCNT_dec(PAD_SVl(PL_op->op_targ));
4388         PAD_SVl(PL_op->op_targ) = SvREFCNT_inc_NN(POPs);
4389     }
4390     else {
4391         SAVE_DEFSV;
4392         DEFSV_set(POPs);
4393     }
4394
4395     PUSHBLOCK(cx, CXt_GIVEN, SP);
4396     PUSHGIVEN(cx);
4397
4398     RETURN;
4399 }
4400
4401 PP(pp_leavegiven)
4402 {
4403     dVAR; dSP;
4404     PERL_CONTEXT *cx;
4405     I32 gimme;
4406     SV **newsp;
4407     PMOP *newpm;
4408     PERL_UNUSED_CONTEXT;
4409
4410     POPBLOCK(cx,newpm);
4411     assert(CxTYPE(cx) == CXt_GIVEN);
4412
4413     TAINT_NOT;
4414     SP = adjust_stack_on_leave(newsp, SP, newsp, gimme, SVs_PADTMP|SVs_TEMP);
4415     PL_curpm = newpm;   /* Don't pop $1 et al till now */
4416
4417     LEAVE_with_name("given");
4418     RETURN;
4419 }
4420
4421 /* Helper routines used by pp_smartmatch */
4422 STATIC PMOP *
4423 S_make_matcher(pTHX_ REGEXP *re)
4424 {
4425     dVAR;
4426     PMOP *matcher = (PMOP *) newPMOP(OP_MATCH, OPf_WANT_SCALAR | OPf_STACKED);
4427
4428     PERL_ARGS_ASSERT_MAKE_MATCHER;
4429
4430     PM_SETRE(matcher, ReREFCNT_inc(re));
4431
4432     SAVEFREEOP((OP *) matcher);
4433     ENTER_with_name("matcher"); SAVETMPS;
4434     SAVEOP();
4435     return matcher;
4436 }
4437
4438 STATIC bool
4439 S_matcher_matches_sv(pTHX_ PMOP *matcher, SV *sv)
4440 {
4441     dVAR;
4442     dSP;
4443
4444     PERL_ARGS_ASSERT_MATCHER_MATCHES_SV;
4445
4446     PL_op = (OP *) matcher;
4447     XPUSHs(sv);
4448     PUTBACK;
4449     (void) Perl_pp_match(aTHX);
4450     SPAGAIN;
4451     return (SvTRUEx(POPs));
4452 }
4453
4454 STATIC void
4455 S_destroy_matcher(pTHX_ PMOP *matcher)
4456 {
4457     dVAR;
4458
4459     PERL_ARGS_ASSERT_DESTROY_MATCHER;
4460     PERL_UNUSED_ARG(matcher);
4461
4462     FREETMPS;
4463     LEAVE_with_name("matcher");
4464 }
4465
4466 /* Do a smart match */
4467 PP(pp_smartmatch)
4468 {
4469     DEBUG_M(Perl_deb(aTHX_ "Starting smart match resolution\n"));
4470     return do_smartmatch(NULL, NULL, 0);
4471 }
4472
4473 /* This version of do_smartmatch() implements the
4474  * table of smart matches that is found in perlsyn.
4475  */
4476 STATIC OP *
4477 S_do_smartmatch(pTHX_ HV *seen_this, HV *seen_other, const bool copied)
4478 {
4479     dVAR;
4480     dSP;
4481
4482     bool object_on_left = FALSE;
4483     SV *e = TOPs;       /* e is for 'expression' */
4484     SV *d = TOPm1s;     /* d is for 'default', as in PL_defgv */
4485
4486     /* Take care only to invoke mg_get() once for each argument.
4487      * Currently we do this by copying the SV if it's magical. */
4488     if (d) {
4489         if (!copied && SvGMAGICAL(d))
4490             d = sv_mortalcopy(d);
4491     }
4492     else
4493         d = &PL_sv_undef;
4494
4495     assert(e);
4496     if (SvGMAGICAL(e))
4497         e = sv_mortalcopy(e);
4498
4499     /* First of all, handle overload magic of the rightmost argument */
4500     if (SvAMAGIC(e)) {
4501         SV * tmpsv;
4502         DEBUG_M(Perl_deb(aTHX_ "    applying rule Any-Object\n"));
4503         DEBUG_M(Perl_deb(aTHX_ "        attempting overload\n"));
4504
4505         tmpsv = amagic_call(d, e, smart_amg, AMGf_noleft);
4506         if (tmpsv) {
4507             SPAGAIN;
4508             (void)POPs;
4509             SETs(tmpsv);
4510             RETURN;
4511         }
4512         DEBUG_M(Perl_deb(aTHX_ "        failed to run overload method; continuing...\n"));
4513     }
4514
4515     SP -= 2;    /* Pop the values */
4516
4517
4518     /* ~~ undef */
4519     if (!SvOK(e)) {
4520         DEBUG_M(Perl_deb(aTHX_ "    applying rule Any-undef\n"));
4521         if (SvOK(d))
4522             RETPUSHNO;
4523         else
4524             RETPUSHYES;
4525     }
4526
4527     if (sv_isobject(e) && (SvTYPE(SvRV(e)) != SVt_REGEXP)) {
4528         DEBUG_M(Perl_deb(aTHX_ "    applying rule Any-Object\n"));
4529         Perl_croak(aTHX_ "Smart matching a non-overloaded object breaks encapsulation");
4530     }
4531     if (sv_isobject(d) && (SvTYPE(SvRV(d)) != SVt_REGEXP))
4532         object_on_left = TRUE;
4533
4534     /* ~~ sub */
4535     if (SvROK(e) && SvTYPE(SvRV(e)) == SVt_PVCV) {
4536         I32 c;
4537         if (object_on_left) {
4538             goto sm_any_sub; /* Treat objects like scalars */
4539         }
4540         else if (SvROK(d) && SvTYPE(SvRV(d)) == SVt_PVHV) {
4541             /* Test sub truth for each key */
4542             HE *he;
4543             bool andedresults = TRUE;
4544             HV *hv = (HV*) SvRV(d);
4545             I32 numkeys = hv_iterinit(hv);
4546             DEBUG_M(Perl_deb(aTHX_ "    applying rule Hash-CodeRef\n"));
4547             if (numkeys == 0)
4548                 RETPUSHYES;
4549             while ( (he = hv_iternext(hv)) ) {
4550                 DEBUG_M(Perl_deb(aTHX_ "        testing hash key...\n"));
4551                 ENTER_with_name("smartmatch_hash_key_test");
4552                 SAVETMPS;
4553                 PUSHMARK(SP);
4554                 PUSHs(hv_iterkeysv(he));
4555                 PUTBACK;
4556                 c = call_sv(e, G_SCALAR);
4557                 SPAGAIN;
4558                 if (c == 0)
4559                     andedresults = FALSE;
4560                 else
4561                     andedresults = SvTRUEx(POPs) && andedresults;
4562                 FREETMPS;
4563                 LEAVE_with_name("smartmatch_hash_key_test");
4564             }
4565             if (andedresults)
4566                 RETPUSHYES;
4567             else
4568                 RETPUSHNO;
4569         }
4570         else if (SvROK(d) && SvTYPE(SvRV(d)) == SVt_PVAV) {
4571             /* Test sub truth for each element */
4572             I32 i;
4573             bool andedresults = TRUE;
4574             AV *av = (AV*) SvRV(d);
4575             const I32 len = av_len(av);
4576             DEBUG_M(Perl_deb(aTHX_ "    applying rule Array-CodeRef\n"));
4577             if (len == -1)
4578                 RETPUSHYES;
4579             for (i = 0; i <= len; ++i) {
4580                 SV * const * const svp = av_fetch(av, i, FALSE);
4581                 DEBUG_M(Perl_deb(aTHX_ "        testing array element...\n"));
4582                 ENTER_with_name("smartmatch_array_elem_test");
4583                 SAVETMPS;
4584                 PUSHMARK(SP);
4585                 if (svp)
4586                     PUSHs(*svp);
4587                 PUTBACK;
4588                 c = call_sv(e, G_SCALAR);
4589                 SPAGAIN;
4590                 if (c == 0)
4591                     andedresults = FALSE;
4592                 else
4593                     andedresults = SvTRUEx(POPs) && andedresults;
4594                 FREETMPS;
4595                 LEAVE_with_name("smartmatch_array_elem_test");
4596             }
4597             if (andedresults)
4598                 RETPUSHYES;
4599             else
4600                 RETPUSHNO;
4601         }
4602         else {
4603           sm_any_sub:
4604             DEBUG_M(Perl_deb(aTHX_ "    applying rule Any-CodeRef\n"));
4605             ENTER_with_name("smartmatch_coderef");
4606             SAVETMPS;
4607             PUSHMARK(SP);
4608             PUSHs(d);
4609             PUTBACK;
4610             c = call_sv(e, G_SCALAR);
4611             SPAGAIN;
4612             if (c == 0)
4613                 PUSHs(&PL_sv_no);
4614             else if (SvTEMP(TOPs))
4615                 SvREFCNT_inc_void(TOPs);
4616             FREETMPS;
4617             LEAVE_with_name("smartmatch_coderef");
4618             RETURN;
4619         }
4620     }
4621     /* ~~ %hash */
4622     else if (SvROK(e) && SvTYPE(SvRV(e)) == SVt_PVHV) {
4623         if (object_on_left) {
4624             goto sm_any_hash; /* Treat objects like scalars */
4625         }
4626         else if (!SvOK(d)) {
4627             DEBUG_M(Perl_deb(aTHX_ "    applying rule Any-Hash ($a undef)\n"));
4628             RETPUSHNO;
4629         }
4630         else if (SvROK(d) && SvTYPE(SvRV(d)) == SVt_PVHV) {
4631             /* Check that the key-sets are identical */
4632             HE *he;
4633             HV *other_hv = MUTABLE_HV(SvRV(d));
4634             bool tied = FALSE;
4635             bool other_tied = FALSE;
4636             U32 this_key_count  = 0,
4637                 other_key_count = 0;
4638             HV *hv = MUTABLE_HV(SvRV(e));
4639
4640             DEBUG_M(Perl_deb(aTHX_ "    applying rule Hash-Hash\n"));
4641             /* Tied hashes don't know how many keys they have. */
4642             if (SvTIED_mg((SV*)hv, PERL_MAGIC_tied)) {
4643                 tied = TRUE;
4644             }
4645             else if (SvTIED_mg((const SV *)other_hv, PERL_MAGIC_tied)) {
4646                 HV * const temp = other_hv;
4647                 other_hv = hv;
4648                 hv = temp;
4649                 tied = TRUE;
4650             }
4651             if (SvTIED_mg((const SV *)other_hv, PERL_MAGIC_tied))
4652                 other_tied = TRUE;
4653
4654             if (!tied && HvUSEDKEYS((const HV *) hv) != HvUSEDKEYS(other_hv))
4655                 RETPUSHNO;
4656
4657             /* The hashes have the same number of keys, so it suffices
4658                to check that one is a subset of the other. */
4659             (void) hv_iterinit(hv);
4660             while ( (he = hv_iternext(hv)) ) {
4661                 SV *key = hv_iterkeysv(he);
4662
4663                 DEBUG_M(Perl_deb(aTHX_ "        comparing hash key...\n"));
4664                 ++ this_key_count;
4665
4666                 if(!hv_exists_ent(other_hv, key, 0)) {
4667                     (void) hv_iterinit(hv);     /* reset iterator */
4668                     RETPUSHNO;
4669                 }
4670             }
4671
4672             if (other_tied) {
4673                 (void) hv_iterinit(other_hv);
4674                 while ( hv_iternext(other_hv) )
4675                     ++other_key_count;
4676             }
4677             else
4678                 other_key_count = HvUSEDKEYS(other_hv);
4679
4680             if (this_key_count != other_key_count)
4681                 RETPUSHNO;
4682             else
4683                 RETPUSHYES;
4684         }
4685         else if (SvROK(d) && SvTYPE(SvRV(d)) == SVt_PVAV) {
4686             AV * const other_av = MUTABLE_AV(SvRV(d));
4687             const I32 other_len = av_len(other_av) + 1;
4688             I32 i;
4689             HV *hv = MUTABLE_HV(SvRV(e));
4690
4691             DEBUG_M(Perl_deb(aTHX_ "    applying rule Array-Hash\n"));
4692             for (i = 0; i < other_len; ++i) {
4693                 SV ** const svp = av_fetch(other_av, i, FALSE);
4694                 DEBUG_M(Perl_deb(aTHX_ "        checking for key existence...\n"));
4695                 if (svp) {      /* ??? When can this not happen? */
4696                     if (hv_exists_ent(hv, *svp, 0))
4697                         RETPUSHYES;
4698                 }
4699             }
4700             RETPUSHNO;
4701         }
4702         else if (SvROK(d) && SvTYPE(SvRV(d)) == SVt_REGEXP) {
4703             DEBUG_M(Perl_deb(aTHX_ "    applying rule Regex-Hash\n"));
4704           sm_regex_hash:
4705             {
4706                 PMOP * const matcher = make_matcher((REGEXP*) SvRV(d));
4707                 HE *he;
4708                 HV *hv = MUTABLE_HV(SvRV(e));
4709
4710                 (void) hv_iterinit(hv);
4711                 while ( (he = hv_iternext(hv)) ) {
4712                     DEBUG_M(Perl_deb(aTHX_ "        testing key against pattern...\n"));
4713                     if (matcher_matches_sv(matcher, hv_iterkeysv(he))) {
4714                         (void) hv_iterinit(hv);
4715                         destroy_matcher(matcher);
4716                         RETPUSHYES;
4717                     }
4718                 }
4719                 destroy_matcher(matcher);
4720                 RETPUSHNO;
4721             }
4722         }
4723         else {
4724           sm_any_hash:
4725             DEBUG_M(Perl_deb(aTHX_ "    applying rule Any-Hash\n"));
4726             if (hv_exists_ent(MUTABLE_HV(SvRV(e)), d, 0))
4727                 RETPUSHYES;
4728             else
4729                 RETPUSHNO;
4730         }
4731     }
4732     /* ~~ @array */
4733     else if (SvROK(e) && SvTYPE(SvRV(e)) == SVt_PVAV) {
4734         if (object_on_left) {
4735             goto sm_any_array; /* Treat objects like scalars */
4736         }
4737         else if (SvROK(d) && SvTYPE(SvRV(d)) == SVt_PVHV) {
4738             AV * const other_av = MUTABLE_AV(SvRV(e));
4739             const I32 other_len = av_len(other_av) + 1;
4740             I32 i;
4741
4742             DEBUG_M(Perl_deb(aTHX_ "    applying rule Hash-Array\n"));
4743             for (i = 0; i < other_len; ++i) {
4744                 SV ** const svp = av_fetch(other_av, i, FALSE);
4745
4746                 DEBUG_M(Perl_deb(aTHX_ "        testing for key existence...\n"));
4747                 if (svp) {      /* ??? When can this not happen? */
4748                     if (hv_exists_ent(MUTABLE_HV(SvRV(d)), *svp, 0))
4749                         RETPUSHYES;
4750                 }
4751             }
4752             RETPUSHNO;
4753         }
4754         if (SvROK(d) && SvTYPE(SvRV(d)) == SVt_PVAV) {
4755             AV *other_av = MUTABLE_AV(SvRV(d));
4756             DEBUG_M(Perl_deb(aTHX_ "    applying rule Array-Array\n"));
4757             if (av_len(MUTABLE_AV(SvRV(e))) != av_len(other_av))
4758                 RETPUSHNO;
4759             else {
4760                 I32 i;
4761                 const I32 other_len = av_len(other_av);
4762
4763                 if (NULL == seen_this) {
4764                     seen_this = newHV();
4765                     (void) sv_2mortal(MUTABLE_SV(seen_this));
4766                 }
4767                 if (NULL == seen_other) {
4768                     seen_other = newHV();
4769                     (void) sv_2mortal(MUTABLE_SV(seen_other));
4770                 }
4771                 for(i = 0; i <= other_len; ++i) {
4772                     SV * const * const this_elem = av_fetch(MUTABLE_AV(SvRV(e)), i, FALSE);
4773                     SV * const * const other_elem = av_fetch(other_av, i, FALSE);
4774
4775                     if (!this_elem || !other_elem) {
4776                         if ((this_elem && SvOK(*this_elem))
4777                                 || (other_elem && SvOK(*other_elem)))
4778                             RETPUSHNO;
4779                     }
4780                     else if (hv_exists_ent(seen_this,
4781                                 sv_2mortal(newSViv(PTR2IV(*this_elem))), 0) ||
4782                             hv_exists_ent(seen_other,
4783                                 sv_2mortal(newSViv(PTR2IV(*other_elem))), 0))
4784                     {
4785                         if (*this_elem != *other_elem)
4786                             RETPUSHNO;
4787                     }
4788                     else {
4789                         (void)hv_store_ent(seen_this,
4790                                 sv_2mortal(newSViv(PTR2IV(*this_elem))),
4791                                 &PL_sv_undef, 0);
4792                         (void)hv_store_ent(seen_other,
4793                                 sv_2mortal(newSViv(PTR2IV(*other_elem))),
4794                                 &PL_sv_undef, 0);
4795                         PUSHs(*other_elem);
4796                         PUSHs(*this_elem);
4797
4798                         PUTBACK;
4799                         DEBUG_M(Perl_deb(aTHX_ "        recursively comparing array element...\n"));
4800                         (void) do_smartmatch(seen_this, seen_other, 0);
4801                         SPAGAIN;
4802                         DEBUG_M(Perl_deb(aTHX_ "        recursion finished\n"));
4803
4804                         if (!SvTRUEx(POPs))
4805                             RETPUSHNO;
4806                     }
4807                 }
4808                 RETPUSHYES;
4809             }
4810         }
4811         else if (SvROK(d) && SvTYPE(SvRV(d)) == SVt_REGEXP) {
4812             DEBUG_M(Perl_deb(aTHX_ "    applying rule Regex-Array\n"));
4813           sm_regex_array:
4814             {
4815                 PMOP * const matcher = make_matcher((REGEXP*) SvRV(d));
4816                 const I32 this_len = av_len(MUTABLE_AV(SvRV(e)));
4817                 I32 i;
4818
4819                 for(i = 0; i <= this_len; ++i) {
4820                     SV * const * const svp = av_fetch(MUTABLE_AV(SvRV(e)), i, FALSE);
4821                     DEBUG_M(Perl_deb(aTHX_ "        testing element against pattern...\n"));
4822                     if (svp && matcher_matches_sv(matcher, *svp)) {
4823                         destroy_matcher(matcher);
4824                         RETPUSHYES;
4825                     }
4826                 }
4827                 destroy_matcher(matcher);
4828                 RETPUSHNO;
4829             }
4830         }
4831         else if (!SvOK(d)) {
4832             /* undef ~~ array */
4833             const I32 this_len = av_len(MUTABLE_AV(SvRV(e)));
4834             I32 i;
4835
4836             DEBUG_M(Perl_deb(aTHX_ "    applying rule Undef-Array\n"));
4837             for (i = 0; i <= this_len; ++i) {
4838                 SV * const * const svp = av_fetch(MUTABLE_AV(SvRV(e)), i, FALSE);
4839                 DEBUG_M(Perl_deb(aTHX_ "        testing for undef element...\n"));
4840                 if (!svp || !SvOK(*svp))
4841                     RETPUSHYES;
4842             }
4843             RETPUSHNO;
4844         }
4845         else {
4846           sm_any_array:
4847             {
4848                 I32 i;
4849                 const I32 this_len = av_len(MUTABLE_AV(SvRV(e)));
4850
4851                 DEBUG_M(Perl_deb(aTHX_ "    applying rule Any-Array\n"));
4852                 for (i = 0; i <= this_len; ++i) {
4853                     SV * const * const svp = av_fetch(MUTABLE_AV(SvRV(e)), i, FALSE);
4854                     if (!svp)
4855                         continue;
4856
4857                     PUSHs(d);
4858                     PUSHs(*svp);
4859                     PUTBACK;
4860                     /* infinite recursion isn't supposed to happen here */
4861                     DEBUG_M(Perl_deb(aTHX_ "        recursively testing array element...\n"));
4862                     (void) do_smartmatch(NULL, NULL, 1);
4863                     SPAGAIN;
4864                     DEBUG_M(Perl_deb(aTHX_ "        recursion finished\n"));
4865                     if (SvTRUEx(POPs))
4866                         RETPUSHYES;
4867                 }
4868                 RETPUSHNO;
4869             }
4870         }
4871     }
4872     /* ~~ qr// */
4873     else if (SvROK(e) && SvTYPE(SvRV(e)) == SVt_REGEXP) {
4874         if (!object_on_left && SvROK(d) && SvTYPE(SvRV(d)) == SVt_PVHV) {
4875             SV *t = d; d = e; e = t;
4876             DEBUG_M(Perl_deb(aTHX_ "    applying rule Hash-Regex\n"));
4877             goto sm_regex_hash;
4878         }
4879         else if (!object_on_left && SvROK(d) && SvTYPE(SvRV(d)) == SVt_PVAV) {
4880             SV *t = d; d = e; e = t;
4881             DEBUG_M(Perl_deb(aTHX_ "    applying rule Array-Regex\n"));
4882             goto sm_regex_array;
4883         }
4884         else {
4885             PMOP * const matcher = make_matcher((REGEXP*) SvRV(e));
4886
4887             DEBUG_M(Perl_deb(aTHX_ "    applying rule Any-Regex\n"));
4888             PUTBACK;
4889             PUSHs(matcher_matches_sv(matcher, d)
4890                     ? &PL_sv_yes
4891                     : &PL_sv_no);
4892             destroy_matcher(matcher);
4893             RETURN;
4894         }
4895     }
4896     /* ~~ scalar */
4897     /* See if there is overload magic on left */
4898     else if (object_on_left && SvAMAGIC(d)) {
4899         SV *tmpsv;
4900         DEBUG_M(Perl_deb(aTHX_ "    applying rule Object-Any\n"));
4901         DEBUG_M(Perl_deb(aTHX_ "        attempting overload\n"));
4902         PUSHs(d); PUSHs(e);
4903         PUTBACK;
4904         tmpsv = amagic_call(d, e, smart_amg, AMGf_noright);
4905         if (tmpsv) {
4906             SPAGAIN;
4907             (void)POPs;
4908             SETs(tmpsv);
4909             RETURN;
4910         }
4911         SP -= 2;
4912         DEBUG_M(Perl_deb(aTHX_ "        failed to run overload method; falling back...\n"));
4913         goto sm_any_scalar;
4914     }
4915     else if (!SvOK(d)) {
4916         /* undef ~~ scalar ; we already know that the scalar is SvOK */
4917         DEBUG_M(Perl_deb(aTHX_ "    applying rule undef-Any\n"));
4918         RETPUSHNO;
4919     }
4920     else
4921   sm_any_scalar:
4922     if (SvNIOK(e) || (SvPOK(e) && looks_like_number(e) && SvNIOK(d))) {
4923         DEBUG_M(if (SvNIOK(e))
4924                     Perl_deb(aTHX_ "    applying rule Any-Num\n");
4925                 else
4926                     Perl_deb(aTHX_ "    applying rule Num-numish\n");
4927         );
4928         /* numeric comparison */
4929         PUSHs(d); PUSHs(e);
4930         PUTBACK;
4931         if (CopHINTS_get(PL_curcop) & HINT_INTEGER)
4932             (void) Perl_pp_i_eq(aTHX);
4933         else
4934             (void) Perl_pp_eq(aTHX);
4935         SPAGAIN;
4936         if (SvTRUEx(POPs))
4937             RETPUSHYES;
4938         else
4939             RETPUSHNO;
4940     }
4941
4942     /* As a last resort, use string comparison */
4943     DEBUG_M(Perl_deb(aTHX_ "    applying rule Any-Any\n"));
4944     PUSHs(d); PUSHs(e);
4945     PUTBACK;
4946     return Perl_pp_seq(aTHX);
4947 }
4948
4949 PP(pp_enterwhen)
4950 {
4951     dVAR; dSP;
4952     PERL_CONTEXT *cx;
4953     const I32 gimme = GIMME_V;
4954
4955     /* This is essentially an optimization: if the match
4956        fails, we don't want to push a context and then
4957        pop it again right away, so we skip straight
4958        to the op that follows the leavewhen.
4959        RETURNOP calls PUTBACK which restores the stack pointer after the POPs.
4960     */
4961     if ((0 == (PL_op->op_flags & OPf_SPECIAL)) && !SvTRUEx(POPs))
4962         RETURNOP(cLOGOP->op_other->op_next);
4963
4964     ENTER_with_name("when");
4965     SAVETMPS;
4966
4967     PUSHBLOCK(cx, CXt_WHEN, SP);
4968     PUSHWHEN(cx);
4969
4970     RETURN;
4971 }
4972
4973 PP(pp_leavewhen)
4974 {
4975     dVAR; dSP;
4976     I32 cxix;
4977     PERL_CONTEXT *cx;
4978     I32 gimme;
4979     SV **newsp;
4980     PMOP *newpm;
4981
4982     cxix = dopoptogiven(cxstack_ix);
4983     if (cxix < 0)
4984         /* diag_listed_as: Can't "when" outside a topicalizer */
4985         DIE(aTHX_ "Can't \"%s\" outside a topicalizer",
4986                    PL_op->op_flags & OPf_SPECIAL ? "default" : "when");
4987
4988     POPBLOCK(cx,newpm);
4989     assert(CxTYPE(cx) == CXt_WHEN);
4990
4991     TAINT_NOT;
4992     SP = adjust_stack_on_leave(newsp, SP, newsp, gimme, SVs_PADTMP|SVs_TEMP);
4993     PL_curpm = newpm;   /* pop $1 et al */
4994
4995     LEAVE_with_name("when");
4996
4997     if (cxix < cxstack_ix)
4998         dounwind(cxix);
4999
5000     cx = &cxstack[cxix];
5001
5002     if (CxFOREACH(cx)) {
5003         /* clear off anything above the scope we're re-entering */
5004         I32 inner = PL_scopestack_ix;
5005
5006         TOPBLOCK(cx);
5007         if (PL_scopestack_ix < inner)
5008             leave_scope(PL_scopestack[PL_scopestack_ix]);
5009         PL_curcop = cx->blk_oldcop;
5010
5011         PERL_ASYNC_CHECK();
5012         return cx->blk_loop.my_op->op_nextop;
5013     }
5014     else {
5015         PERL_ASYNC_CHECK();
5016         RETURNOP(cx->blk_givwhen.leave_op);
5017     }
5018 }
5019
5020 PP(pp_continue)
5021 {
5022     dVAR; dSP;
5023     I32 cxix;
5024     PERL_CONTEXT *cx;
5025     I32 gimme;
5026     SV **newsp;
5027     PMOP *newpm;
5028
5029     PERL_UNUSED_VAR(gimme);
5030
5031     cxix = dopoptowhen(cxstack_ix);
5032     if (cxix < 0)
5033         DIE(aTHX_ "Can't \"continue\" outside a when block");
5034
5035     if (cxix < cxstack_ix)
5036         dounwind(cxix);
5037
5038     POPBLOCK(cx,newpm);
5039     assert(CxTYPE(cx) == CXt_WHEN);
5040
5041     SP = newsp;
5042     PL_curpm = newpm;   /* pop $1 et al */
5043
5044     LEAVE_with_name("when");
5045     RETURNOP(cx->blk_givwhen.leave_op->op_next);
5046 }
5047
5048 PP(pp_break)
5049 {
5050     dVAR;
5051     I32 cxix;
5052     PERL_CONTEXT *cx;
5053
5054     cxix = dopoptogiven(cxstack_ix);
5055     if (cxix < 0)
5056         DIE(aTHX_ "Can't \"break\" outside a given block");
5057
5058     cx = &cxstack[cxix];
5059     if (CxFOREACH(cx))
5060         DIE(aTHX_ "Can't \"break\" in a loop topicalizer");
5061
5062     if (cxix < cxstack_ix)
5063         dounwind(cxix);
5064
5065     /* Restore the sp at the time we entered the given block */
5066     TOPBLOCK(cx);
5067
5068     return cx->blk_givwhen.leave_op;
5069 }
5070
5071 static MAGIC *
5072 S_doparseform(pTHX_ SV *sv)
5073 {
5074     STRLEN len;
5075     char *s = SvPV(sv, len);
5076     char *send;
5077     char *base = NULL; /* start of current field */
5078     I32 skipspaces = 0; /* number of contiguous spaces seen */
5079     bool noblank   = FALSE; /* ~ or ~~ seen on this line */
5080     bool repeat    = FALSE; /* ~~ seen on this line */
5081     bool postspace = FALSE; /* a text field may need right padding */
5082     U32 *fops;
5083     U32 *fpc;
5084     U32 *linepc = NULL;     /* position of last FF_LINEMARK */
5085     I32 arg;
5086     bool ischop;            /* it's a ^ rather than a @ */
5087     bool unchopnum = FALSE; /* at least one @ (i.e. non-chop) num field seen */
5088     int maxops = 12; /* FF_LINEMARK + FF_END + 10 (\0 without preceding \n) */
5089     MAGIC *mg = NULL;
5090     SV *sv_copy;
5091
5092     PERL_ARGS_ASSERT_DOPARSEFORM;
5093
5094     if (len == 0)
5095         Perl_croak(aTHX_ "Null picture in formline");
5096
5097     if (SvTYPE(sv) >= SVt_PVMG) {
5098         /* This might, of course, still return NULL.  */
5099         mg = mg_find(sv, PERL_MAGIC_fm);
5100     } else {
5101         sv_upgrade(sv, SVt_PVMG);
5102     }
5103
5104     if (mg) {
5105         /* still the same as previously-compiled string? */
5106         SV *old = mg->mg_obj;
5107         if ( !(!!SvUTF8(old) ^ !!SvUTF8(sv))
5108               && len == SvCUR(old)
5109               && strnEQ(SvPVX(old), SvPVX(sv), len)
5110         ) {
5111             DEBUG_f(PerlIO_printf(Perl_debug_log,"Re-using compiled format\n"));
5112             return mg;
5113         }
5114
5115         DEBUG_f(PerlIO_printf(Perl_debug_log, "Re-compiling format\n"));
5116         Safefree(mg->mg_ptr);
5117         mg->mg_ptr = NULL;
5118         SvREFCNT_dec(old);
5119         mg->mg_obj = NULL;
5120     }
5121     else {
5122         DEBUG_f(PerlIO_printf(Perl_debug_log, "Compiling format\n"));
5123         mg = sv_magicext(sv, NULL, PERL_MAGIC_fm, &PL_vtbl_fm, NULL, 0);
5124     }
5125
5126     sv_copy = newSVpvn_utf8(s, len, SvUTF8(sv));
5127     s = SvPV(sv_copy, len); /* work on the copy, not the original */
5128     send = s + len;
5129
5130
5131     /* estimate the buffer size needed */
5132     for (base = s; s <= send; s++) {
5133         if (*s == '\n' || *s == '@' || *s == '^')
5134             maxops += 10;
5135     }
5136     s = base;
5137     base = NULL;
5138
5139     Newx(fops, maxops, U32);
5140     fpc = fops;
5141
5142     if (s < send) {
5143         linepc = fpc;
5144         *fpc++ = FF_LINEMARK;
5145         noblank = repeat = FALSE;
5146         base = s;
5147     }
5148
5149     while (s <= send) {
5150         switch (*s++) {
5151         default:
5152             skipspaces = 0;
5153             continue;
5154
5155         case '~':
5156             if (*s == '~') {
5157                 repeat = TRUE;
5158                 skipspaces++;
5159                 s++;
5160             }
5161             noblank = TRUE;
5162             /* FALL THROUGH */
5163         case ' ': case '\t':
5164             skipspaces++;
5165             continue;
5166         case 0:
5167             if (s < send) {
5168                 skipspaces = 0;
5169                 continue;
5170             } /* else FALL THROUGH */
5171         case '\n':
5172             arg = s - base;
5173             skipspaces++;
5174             arg -= skipspaces;
5175             if (arg) {
5176                 if (postspace)
5177                     *fpc++ = FF_SPACE;
5178                 *fpc++ = FF_LITERAL;
5179                 *fpc++ = (U32)arg;
5180             }
5181             postspace = FALSE;
5182             if (s <= send)
5183                 skipspaces--;
5184             if (skipspaces) {
5185                 *fpc++ = FF_SKIP;
5186                 *fpc++ = (U32)skipspaces;
5187             }
5188             skipspaces = 0;
5189             if (s <= send)
5190                 *fpc++ = FF_NEWLINE;
5191             if (noblank) {
5192                 *fpc++ = FF_BLANK;
5193                 if (repeat)
5194                     arg = fpc - linepc + 1;
5195                 else
5196                     arg = 0;
5197                 *fpc++ = (U32)arg;
5198             }
5199             if (s < send) {
5200                 linepc = fpc;
5201                 *fpc++ = FF_LINEMARK;
5202                 noblank = repeat = FALSE;
5203                 base = s;
5204             }
5205             else
5206                 s++;
5207             continue;
5208
5209         case '@':
5210         case '^':
5211             ischop = s[-1] == '^';
5212
5213             if (postspace) {
5214                 *fpc++ = FF_SPACE;
5215                 postspace = FALSE;
5216             }
5217             arg = (s - base) - 1;
5218             if (arg) {
5219                 *fpc++ = FF_LITERAL;
5220                 *fpc++ = (U32)arg;
5221             }
5222
5223             base = s - 1;
5224             *fpc++ = FF_FETCH;
5225             if (*s == '*') { /*  @* or ^*  */
5226                 s++;
5227                 *fpc++ = 2;  /* skip the @* or ^* */
5228                 if (ischop) {
5229                     *fpc++ = FF_LINESNGL;
5230                     *fpc++ = FF_CHOP;
5231                 } else
5232                     *fpc++ = FF_LINEGLOB;
5233             }
5234             else if (*s == '#' || (*s == '.' && s[1] == '#')) { /* @###, ^### */
5235                 arg = ischop ? FORM_NUM_BLANK : 0;
5236                 base = s - 1;
5237                 while (*s == '#')
5238                     s++;
5239                 if (*s == '.') {
5240                     const char * const f = ++s;
5241                     while (*s == '#')
5242                         s++;
5243                     arg |= FORM_NUM_POINT + (s - f);
5244                 }
5245                 *fpc++ = s - base;              /* fieldsize for FETCH */
5246                 *fpc++ = FF_DECIMAL;
5247                 *fpc++ = (U32)arg;
5248                 unchopnum |= ! ischop;
5249             }
5250             else if (*s == '0' && s[1] == '#') {  /* Zero padded decimals */
5251                 arg = ischop ? FORM_NUM_BLANK : 0;
5252                 base = s - 1;
5253                 s++;                                /* skip the '0' first */
5254                 while (*s == '#')
5255                     s++;
5256                 if (*s == '.') {
5257                     const char * const f = ++s;
5258                     while (*s == '#')
5259                         s++;
5260                     arg |= FORM_NUM_POINT + (s - f);
5261                 }
5262                 *fpc++ = s - base;                /* fieldsize for FETCH */
5263                 *fpc++ = FF_0DECIMAL;
5264                 *fpc++ = (U32)arg;
5265                 unchopnum |= ! ischop;
5266             }
5267             else {                              /* text field */
5268                 I32 prespace = 0;
5269                 bool ismore = FALSE;
5270
5271                 if (*s == '>') {
5272                     while (*++s == '>') ;
5273                     prespace = FF_SPACE;
5274                 }
5275                 else if (*s == '|') {
5276                     while (*++s == '|') ;
5277                     prespace = FF_HALFSPACE;
5278                     postspace = TRUE;
5279                 }
5280                 else {
5281                     if (*s == '<')
5282                         while (*++s == '<') ;
5283                     postspace = TRUE;
5284                 }
5285                 if (*s == '.' && s[1] == '.' && s[2] == '.') {
5286                     s += 3;
5287                     ismore = TRUE;
5288                 }
5289                 *fpc++ = s - base;              /* fieldsize for FETCH */
5290
5291                 *fpc++ = ischop ? FF_CHECKCHOP : FF_CHECKNL;
5292
5293                 if (prespace)
5294                     *fpc++ = (U32)prespace; /* add SPACE or HALFSPACE */
5295                 *fpc++ = FF_ITEM;
5296                 if (ismore)
5297                     *fpc++ = FF_MORE;
5298                 if (ischop)
5299                     *fpc++ = FF_CHOP;
5300             }
5301             base = s;
5302             skipspaces = 0;
5303             continue;
5304         }
5305     }
5306     *fpc++ = FF_END;
5307
5308     assert (fpc <= fops + maxops); /* ensure our buffer estimate was valid */
5309     arg = fpc - fops;
5310
5311     mg->mg_ptr = (char *) fops;
5312     mg->mg_len = arg * sizeof(U32);
5313     mg->mg_obj = sv_copy;
5314     mg->mg_flags |= MGf_REFCOUNTED;
5315
5316     if (unchopnum && repeat)
5317         Perl_die(aTHX_ "Repeated format line will never terminate (~~ and @#)");
5318
5319     return mg;
5320 }
5321
5322
5323 STATIC bool
5324 S_num_overflow(NV value, I32 fldsize, I32 frcsize)
5325 {
5326     /* Can value be printed in fldsize chars, using %*.*f ? */
5327     NV pwr = 1;
5328     NV eps = 0.5;
5329     bool res = FALSE;
5330     int intsize = fldsize - (value < 0 ? 1 : 0);
5331
5332     if (frcsize & FORM_NUM_POINT)
5333         intsize--;
5334     frcsize &= ~(FORM_NUM_POINT|FORM_NUM_BLANK);
5335     intsize -= frcsize;
5336
5337     while (intsize--) pwr *= 10.0;
5338     while (frcsize--) eps /= 10.0;
5339
5340     if( value >= 0 ){
5341         if (value + eps >= pwr)
5342             res = TRUE;
5343     } else {
5344         if (value - eps <= -pwr)
5345             res = TRUE;
5346     }
5347     return res;
5348 }
5349
5350 static I32
5351 S_run_user_filter(pTHX_ int idx, SV *buf_sv, int maxlen)
5352 {
5353     dVAR;
5354     SV * const datasv = FILTER_DATA(idx);
5355     const int filter_has_file = IoLINES(datasv);
5356     SV * const filter_state = MUTABLE_SV(IoTOP_GV(datasv));
5357     SV * const filter_sub = MUTABLE_SV(IoBOTTOM_GV(datasv));
5358     int status = 0;
5359     SV *upstream;
5360     STRLEN got_len;
5361     char *got_p = NULL;
5362     char *prune_from = NULL;
5363     bool read_from_cache = FALSE;
5364     STRLEN umaxlen;
5365     SV *err = NULL;
5366
5367     PERL_ARGS_ASSERT_RUN_USER_FILTER;
5368
5369     assert(maxlen >= 0);
5370     umaxlen = maxlen;
5371
5372     /* I was having segfault trouble under Linux 2.2.5 after a
5373        parse error occured.  (Had to hack around it with a test
5374        for PL_parser->error_count == 0.)  Solaris doesn't segfault --
5375        not sure where the trouble is yet.  XXX */
5376
5377     {
5378         SV *const cache = datasv;
5379         if (SvOK(cache)) {
5380             STRLEN cache_len;
5381             const char *cache_p = SvPV(cache, cache_len);
5382             STRLEN take = 0;
5383
5384             if (umaxlen) {
5385                 /* Running in block mode and we have some cached data already.
5386                  */
5387                 if (cache_len >= umaxlen) {
5388                     /* In fact, so much data we don't even need to call
5389                        filter_read.  */
5390                     take = umaxlen;
5391                 }
5392             } else {
5393                 const char *const first_nl =
5394                     (const char *)memchr(cache_p, '\n', cache_len);
5395                 if (first_nl) {
5396                     take = first_nl + 1 - cache_p;
5397                 }
5398             }
5399             if (take) {
5400                 sv_catpvn(buf_sv, cache_p, take);
5401                 sv_chop(cache, cache_p + take);
5402                 /* Definitely not EOF  */
5403                 return 1;
5404             }
5405
5406             sv_catsv(buf_sv, cache);
5407             if (umaxlen) {
5408                 umaxlen -= cache_len;
5409             }
5410             SvOK_off(cache);
5411             read_from_cache = TRUE;
5412         }
5413     }
5414
5415     /* Filter API says that the filter appends to the contents of the buffer.
5416        Usually the buffer is "", so the details don't matter. But if it's not,
5417        then clearly what it contains is already filtered by this filter, so we
5418        don't want to pass it in a second time.
5419        I'm going to use a mortal in case the upstream filter croaks.  */
5420     upstream = ((SvOK(buf_sv) && sv_len(buf_sv)) || SvGMAGICAL(buf_sv))
5421         ? sv_newmortal() : buf_sv;
5422     SvUPGRADE(upstream, SVt_PV);
5423
5424     if (filter_has_file) {
5425         status = FILTER_READ(idx+1, upstream, 0);
5426     }
5427
5428     if (filter_sub && status >= 0) {
5429         dSP;
5430         int count;
5431
5432         ENTER_with_name("call_filter_sub");
5433         SAVE_DEFSV;
5434         SAVETMPS;
5435         EXTEND(SP, 2);
5436
5437         DEFSV_set(upstream);
5438         PUSHMARK(SP);
5439         mPUSHi(0);
5440         if (filter_state) {
5441             PUSHs(filter_state);
5442         }
5443         PUTBACK;
5444         count = call_sv(filter_sub, G_SCALAR|G_EVAL);
5445         SPAGAIN;
5446
5447         if (count > 0) {
5448             SV *out = POPs;
5449             if (SvOK(out)) {
5450                 status = SvIV(out);
5451             }
5452             else {
5453                 SV * const errsv = ERRSV;
5454                 if (SvTRUE_NN(errsv))
5455                     err = newSVsv(errsv);
5456             }
5457         }
5458
5459         PUTBACK;
5460         FREETMPS;
5461         LEAVE_with_name("call_filter_sub");
5462     }
5463
5464     if (SvIsCOW(upstream)) sv_force_normal(upstream);
5465     if(!err && SvOK(upstream)) {
5466         got_p = SvPV(upstream, got_len);
5467         if (umaxlen) {
5468             if (got_len > umaxlen) {
5469                 prune_from = got_p + umaxlen;
5470             }
5471         } else {
5472             char *const first_nl = (char *)memchr(got_p, '\n', got_len);
5473             if (first_nl && first_nl + 1 < got_p + got_len) {
5474                 /* There's a second line here... */
5475                 prune_from = first_nl + 1;
5476             }
5477         }
5478     }
5479     if (!err && prune_from) {
5480         /* Oh. Too long. Stuff some in our cache.  */
5481         STRLEN cached_len = got_p + got_len - prune_from;
5482         SV *const cache = datasv;
5483
5484         if (SvOK(cache)) {
5485             /* Cache should be empty.  */
5486             assert(!SvCUR(cache));
5487         }
5488
5489         sv_setpvn(cache, prune_from, cached_len);
5490         /* If you ask for block mode, you may well split UTF-8 characters.
5491            "If it breaks, you get to keep both parts"
5492            (Your code is broken if you  don't put them back together again
5493            before something notices.) */
5494         if (SvUTF8(upstream)) {
5495             SvUTF8_on(cache);
5496         }
5497         SvCUR_set(upstream, got_len - cached_len);
5498         *prune_from = 0;
5499         /* Can't yet be EOF  */
5500         if (status == 0)
5501             status = 1;
5502     }
5503
5504     /* If they are at EOF but buf_sv has something in it, then they may never
5505        have touched the SV upstream, so it may be undefined.  If we naively
5506        concatenate it then we get a warning about use of uninitialised value.
5507     */
5508     if (!err && upstream != buf_sv &&
5509         (SvOK(upstream) || SvGMAGICAL(upstream))) {
5510         sv_catsv(buf_sv, upstream);
5511     }
5512
5513     if (status <= 0) {
5514         IoLINES(datasv) = 0;
5515         if (filter_state) {
5516             SvREFCNT_dec(filter_state);
5517             IoTOP_GV(datasv) = NULL;
5518         }
5519         if (filter_sub) {
5520             SvREFCNT_dec(filter_sub);
5521             IoBOTTOM_GV(datasv) = NULL;
5522         }
5523         filter_del(S_run_user_filter);
5524     }
5525
5526     if (err)
5527         croak_sv(err);
5528
5529     if (status == 0 && read_from_cache) {
5530         /* If we read some data from the cache (and by getting here it implies
5531            that we emptied the cache) then we aren't yet at EOF, and mustn't
5532            report that to our caller.  */
5533         return 1;
5534     }
5535     return status;
5536 }
5537
5538 /*
5539  * Local variables:
5540  * c-indentation-style: bsd
5541  * c-basic-offset: 4
5542  * indent-tabs-mode: nil
5543  * End:
5544  *
5545  * ex: set ts=8 sts=4 sw=4 et:
5546  */