pp_ctl.c

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