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