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