pp_ctl.c

   1 /*    pp_ctl.c
   2  *
   3  *    Copyright (C) 1991, 1992, 1993, 1994, 1995, 1996, 1997, 1998, 1999, 2000,
   4  *    2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008 by Larry Wall and others
   5  *
   6  *    You may distribute under the terms of either the GNU General Public
   7  *    License or the Artistic License, as specified in the README file.
   8  *
   9  */
  10
  11 /*
  12  *      Now far ahead the Road has gone,
  13  *          And I must follow, if I can,
  14  *      Pursuing it with eager feet,
  15  *          Until it joins some larger way
  16  *      Where many paths and errands meet.
  17  *          And whither then?  I cannot say.
  18  *
  19  *     [Bilbo on p.35 of _The Lord of the Rings_, I/i: "A Long-Expected Party"]
  20  */
  21
  22 /* This file contains control-oriented pp ("push/pop") functions that
  23  * execute the opcodes that make up a perl program. A typical pp function
  24  * expects to find its arguments on the stack, and usually pushes its
  25  * results onto the stack, hence the 'pp' terminology. Each OP structure
  26  * contains a pointer to the relevant pp_foo() function.
  27  *
  28  * Control-oriented means things like pp_enteriter() and pp_next(), which
  29  * alter the flow of control of the program.
  30  */
  31
  32
  33 #include "EXTERN.h"
  34 #define PERL_IN_PP_CTL_C
  35 #include "perl.h"
  36
  37 #define DOCATCH(o) ((CATCH_GET == TRUE) ? docatch(o) : (o))
  38
  39 #define dopoptosub(plop)        dopoptosub_at(cxstack, (plop))
  40
  41 PP(pp_wantarray)
  42 {
  43     dVAR;
  44     dSP;
  45     I32 cxix;
  46     const PERL_CONTEXT *cx;
  47     EXTEND(SP, 1);
  48
  49     if (PL_op->op_private & OPpOFFBYONE) {
  50         if (!(cx = caller_cx(1,NULL))) RETPUSHUNDEF;
  51     }
  52     else {
  53       cxix = dopoptosub(cxstack_ix);
  54       if (cxix < 0)
  55         RETPUSHUNDEF;
  56       cx = &cxstack[cxix];
  57     }
  58
  59     switch (cx->blk_gimme) {
  60     case G_ARRAY:
  61         RETPUSHYES;
  62     case G_SCALAR:
  63         RETPUSHNO;
  64     default:
  65         RETPUSHUNDEF;
  66     }
  67 }
  68
  69 PP(pp_regcreset)
  70 {
  71     dVAR;
  72     TAINT_NOT;
  73     return NORMAL;
  74 }
  75
  76 PP(pp_regcomp)
  77 {
  78     dVAR;
  79     dSP;
  80     PMOP *pm = (PMOP*)cLOGOP->op_other;
  81     SV **args;
  82     int nargs;
  83     REGEXP *re = NULL;
  84     REGEXP *new_re;
  85     const regexp_engine *eng;
  86     bool is_bare_re;
  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     PERL_CONTEXT *cx = &cxstack[cxstack_ix];
 181     PMOP * const pm = (PMOP*) cLOGOP->op_other;
 182     SV * const dstr = cx->sb_dstr;
 183     char *s = cx->sb_s;
 184     char *m = cx->sb_m;
 185     char *orig = cx->sb_orig;
 186     REGEXP * const rx = cx->sb_rx;
 187     SV *nsv = NULL;
 188     REGEXP *old = PM_GETRE(pm);
 189
 190     PERL_ASYNC_CHECK();
 191
 192     if(old != rx) {
 193         if(old)
 194             ReREFCNT_dec(old);
 195         PM_SETRE(pm,ReREFCNT_inc(rx));
 196     }
 197
 198     rxres_restore(&cx->sb_rxres, rx);
 199     RX_MATCH_UTF8_set(rx, DO_UTF8(cx->sb_targ));
 200
 201     if (cx->sb_iters++) {
 202         const I32 saviters = cx->sb_iters;
 203         if (cx->sb_iters > cx->sb_maxiters)
 204             DIE(aTHX_ "Substitution loop");
 205
 206         SvGETMAGIC(TOPs); /* possibly clear taint on $1 etc: #67962 */
 207
 208         /* See "how taint works" above pp_subst() */
 209         if (SvTAINTED(TOPs))
 210             cx->sb_rxtainted |= SUBST_TAINT_REPL;
 211         sv_catsv_nomg(dstr, POPs);
 212         /* XXX: adjust for positive offsets of \G for instance s/(.)\G//g with positive pos() */
 213         s -= RX_GOFS(rx);
 214
 215         /* Are we done */
 216         if (CxONCE(cx) || s < orig ||
 217                 !CALLREGEXEC(rx, s, cx->sb_strend, orig,
 218                              (s == m) + RX_GOFS(rx), cx->sb_targ, NULL,
 219                              ((cx->sb_rflags & REXEC_COPY_STR)
 220                               ? (REXEC_IGNOREPOS|REXEC_NOT_FIRST)
 221                               : (REXEC_COPY_STR|REXEC_IGNOREPOS|REXEC_NOT_FIRST))))
 222         {
 223             SV *targ = cx->sb_targ;
 224
 225             assert(cx->sb_strend >= s);
 226             if(cx->sb_strend > s) {
 227                  if (DO_UTF8(dstr) && !SvUTF8(targ))
 228                       sv_catpvn_nomg_utf8_upgrade(dstr, s, cx->sb_strend - s, nsv);
 229                  else
 230                       sv_catpvn_nomg(dstr, s, cx->sb_strend - s);
 231             }
 232             if (RX_MATCH_TAINTED(rx)) /* run time pattern taint, eg locale */
 233                 cx->sb_rxtainted |= SUBST_TAINT_PAT;
 234
 235             if (pm->op_pmflags & PMf_NONDESTRUCT) {
 236                 PUSHs(dstr);
 237                 /* From here on down we're using the copy, and leaving the
 238                    original untouched.  */
 239                 targ = dstr;
 240             }
 241             else {
 242                 if (SvIsCOW(targ)) {
 243                     sv_force_normal_flags(targ, SV_COW_DROP_PV);
 244                 } else
 245                 {
 246                     SvPV_free(targ);
 247                 }
 248                 SvPV_set(targ, SvPVX(dstr));
 249                 SvCUR_set(targ, SvCUR(dstr));
 250                 SvLEN_set(targ, SvLEN(dstr));
 251                 if (DO_UTF8(dstr))
 252                     SvUTF8_on(targ);
 253                 SvPV_set(dstr, NULL);
 254
 255                 mPUSHi(saviters - 1);
 256
 257                 (void)SvPOK_only_UTF8(targ);
 258             }
 259
 260             /* update the taint state of various various variables in
 261              * preparation for final exit.
 262              * See "how taint works" above pp_subst() */
 263             if (PL_tainting) {
 264                 if ((cx->sb_rxtainted & SUBST_TAINT_PAT) ||
 265                     ((cx->sb_rxtainted & (SUBST_TAINT_STR|SUBST_TAINT_RETAINT))
 266                                     == (SUBST_TAINT_STR|SUBST_TAINT_RETAINT))
 267                 )
 268                     (RX_MATCH_TAINTED_on(rx)); /* taint $1 et al */
 269
 270                 if (!(cx->sb_rxtainted & SUBST_TAINT_BOOLRET)
 271                     && (cx->sb_rxtainted & (SUBST_TAINT_STR|SUBST_TAINT_PAT))
 272                 )
 273                     SvTAINTED_on(TOPs);  /* taint return value */
 274                 /* needed for mg_set below */
 275                 PL_tainted = cBOOL(cx->sb_rxtainted &
 276                             (SUBST_TAINT_STR|SUBST_TAINT_PAT|SUBST_TAINT_REPL));
 277                 SvTAINT(TARG);
 278             }
 279             /* PL_tainted must be correctly set for this mg_set */
 280             SvSETMAGIC(TARG);
 281             TAINT_NOT;
 282             LEAVE_SCOPE(cx->sb_oldsave);
 283             POPSUBST(cx);
 284             RETURNOP(pm->op_next);
 285             assert(0); /* NOTREACHED */
 286         }
 287         cx->sb_iters = saviters;
 288     }
 289     if (RX_MATCH_COPIED(rx) && RX_SUBBEG(rx) != orig) {
 290         m = s;
 291         s = orig;
 292         cx->sb_orig = orig = RX_SUBBEG(rx);
 293         s = orig + (m - s);
 294         cx->sb_strend = s + (cx->sb_strend - m);
 295     }
 296     cx->sb_m = m = RX_OFFS(rx)[0].start + orig;
 297     if (m > s) {
 298         if (DO_UTF8(dstr) && !SvUTF8(cx->sb_targ))
 299             sv_catpvn_nomg_utf8_upgrade(dstr, s, m - s, nsv);
 300         else
 301             sv_catpvn_nomg(dstr, s, m-s);
 302     }
 303     cx->sb_s = RX_OFFS(rx)[0].end + orig;
 304     { /* Update the pos() information. */
 305         SV * const sv
 306             = (pm->op_pmflags & PMf_NONDESTRUCT) ? cx->sb_dstr : cx->sb_targ;
 307         MAGIC *mg;
 308         SvUPGRADE(sv, SVt_PVMG);
 309         if (!(mg = mg_find(sv, PERL_MAGIC_regex_global))) {
 310 #ifdef PERL_OLD_COPY_ON_WRITE
 311             if (SvIsCOW(sv))
 312                 sv_force_normal_flags(sv, 0);
 313 #endif
 314             mg = sv_magicext(sv, NULL, PERL_MAGIC_regex_global, &PL_vtbl_mglob,
 315                              NULL, 0);
 316         }
 317         mg->mg_len = m - orig;
 318     }
 319     if (old != rx)
 320         (void)ReREFCNT_inc(rx);
 321     /* update the taint state of various various variables in preparation
 322      * for calling the code block.
 323      * See "how taint works" above pp_subst() */
 324     if (PL_tainting) {
 325         if (RX_MATCH_TAINTED(rx)) /* run time pattern taint, eg locale */
 326             cx->sb_rxtainted |= SUBST_TAINT_PAT;
 327
 328         if ((cx->sb_rxtainted & SUBST_TAINT_PAT) ||
 329             ((cx->sb_rxtainted & (SUBST_TAINT_STR|SUBST_TAINT_RETAINT))
 330                             == (SUBST_TAINT_STR|SUBST_TAINT_RETAINT))
 331         )
 332             (RX_MATCH_TAINTED_on(rx)); /* taint $1 et al */
 333
 334         if (cx->sb_iters > 1 && (cx->sb_rxtainted &
 335                         (SUBST_TAINT_STR|SUBST_TAINT_PAT|SUBST_TAINT_REPL)))
 336             SvTAINTED_on((pm->op_pmflags & PMf_NONDESTRUCT)
 337                          ? cx->sb_dstr : cx->sb_targ);
 338         TAINT_NOT;
 339     }
 340     rxres_save(&cx->sb_rxres, rx);
 341     PL_curpm = pm;
 342     RETURNOP(pm->op_pmstashstartu.op_pmreplstart);
 343 }
 344
 345 void
 346 Perl_rxres_save(pTHX_ void **rsp, REGEXP *rx)
 347 {
 348     UV *p = (UV*)*rsp;
 349     U32 i;
 350
 351     PERL_ARGS_ASSERT_RXRES_SAVE;
 352     PERL_UNUSED_CONTEXT;
 353
 354     if (!p || p[1] < RX_NPARENS(rx)) {
 355 #ifdef PERL_OLD_COPY_ON_WRITE
 356         i = 7 + RX_NPARENS(rx) * 2;
 357 #else
 358         i = 6 + RX_NPARENS(rx) * 2;
 359 #endif
 360         if (!p)
 361             Newx(p, i, UV);
 362         else
 363             Renew(p, i, UV);
 364         *rsp = (void*)p;
 365     }
 366
 367     *p++ = PTR2UV(RX_MATCH_COPIED(rx) ? RX_SUBBEG(rx) : NULL);
 368     RX_MATCH_COPIED_off(rx);
 369
 370 #ifdef PERL_OLD_COPY_ON_WRITE
 371     *p++ = PTR2UV(RX_SAVED_COPY(rx));
 372     RX_SAVED_COPY(rx) = NULL;
 373 #endif
 374
 375     *p++ = RX_NPARENS(rx);
 376
 377     *p++ = PTR2UV(RX_SUBBEG(rx));
 378     *p++ = (UV)RX_SUBLEN(rx);
 379     for (i = 0; i <= RX_NPARENS(rx); ++i) {
 380         *p++ = (UV)RX_OFFS(rx)[i].start;
 381         *p++ = (UV)RX_OFFS(rx)[i].end;
 382     }
 383 }
 384
 385 static void
 386 S_rxres_restore(pTHX_ void **rsp, REGEXP *rx)
 387 {
 388     UV *p = (UV*)*rsp;
 389     U32 i;
 390
 391     PERL_ARGS_ASSERT_RXRES_RESTORE;
 392     PERL_UNUSED_CONTEXT;
 393
 394     RX_MATCH_COPY_FREE(rx);
 395     RX_MATCH_COPIED_set(rx, *p);
 396     *p++ = 0;
 397
 398 #ifdef PERL_OLD_COPY_ON_WRITE
 399     if (RX_SAVED_COPY(rx))
 400         SvREFCNT_dec (RX_SAVED_COPY(rx));
 401     RX_SAVED_COPY(rx) = INT2PTR(SV*,*p);
 402     *p++ = 0;
 403 #endif
 404
 405     RX_NPARENS(rx) = *p++;
 406
 407     RX_SUBBEG(rx) = INT2PTR(char*,*p++);
 408     RX_SUBLEN(rx) = (I32)(*p++);
 409     for (i = 0; i <= RX_NPARENS(rx); ++i) {
 410         RX_OFFS(rx)[i].start = (I32)(*p++);
 411         RX_OFFS(rx)[i].end = (I32)(*p++);
 412     }
 413 }
 414
 415 static void
 416 S_rxres_free(pTHX_ void **rsp)
 417 {
 418     UV * const p = (UV*)*rsp;
 419
 420     PERL_ARGS_ASSERT_RXRES_FREE;
 421     PERL_UNUSED_CONTEXT;
 422
 423     if (p) {
 424 #ifdef PERL_POISON
 425         void *tmp = INT2PTR(char*,*p);
 426         Safefree(tmp);
 427         if (*p)
 428             PoisonFree(*p, 1, sizeof(*p));
 429 #else
 430         Safefree(INT2PTR(char*,*p));
 431 #endif
 432 #ifdef PERL_OLD_COPY_ON_WRITE
 433         if (p[1]) {
 434             SvREFCNT_dec (INT2PTR(SV*,p[1]));
 435         }
 436 #endif
 437         Safefree(p);
 438         *rsp = NULL;
 439     }
 440 }
 441
 442 #define FORM_NUM_BLANK (1<<30)
 443 #define FORM_NUM_POINT (1<<29)
 444
 445 PP(pp_formline)
 446 {
 447     dVAR; dSP; dMARK; dORIGMARK;
 448     SV * const tmpForm = *++MARK;
 449     SV *formsv;             /* contains text of original format */
 450     U32 *fpc;       /* format ops program counter */
 451     char *t;        /* current append position in target string */
 452     const char *f;          /* current position in format string */
 453     I32 arg;
 454     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             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     I32 i;
1297
1298     PERL_ARGS_ASSERT_DOPOPTOLABEL;
1299
1300     for (i = cxstack_ix; i >= 0; i--) {
1301         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         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         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         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         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         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         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             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     I32 cxix = dopoptosub(cxstack_ix);
1741     const PERL_CONTEXT *cx;
1742     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     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         PERL_CONTEXT *cx;
1954         const I32 gimme = G_ARRAY;
1955         U8 hasargs;
1956         GV * const gv = PL_DBgv;
1957         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             PUSHMARK(SP);
1977             (void)(*CvXSUB(cv))(aTHX_ cv);
1978             FREETMPS;
1979             LEAVE;
1980             return NORMAL;
1981         }
1982         else {
1983             PUSHBLOCK(cx, CXt_SUB, SP);
1984             PUSHSUB_DB(cx);
1985             cx->blk_sub.retop = PL_op->op_next;
1986             CvDEPTH(cv)++;
1987             SAVECOMPPAD();
1988             PAD_SET_CUR_NOSAVE(CvPADLIST(cv), 1);
1989             RETURNOP(CvSTART(cv));
1990         }
1991     }
1992     else
1993         return NORMAL;
1994 }
1995
1996 STATIC SV **
1997 S_adjust_stack_on_leave(pTHX_ SV **newsp, SV **sp, SV **mark, I32 gimme, U32 flags)
1998 {
1999     bool padtmp = 0;
2000     PERL_ARGS_ASSERT_ADJUST_STACK_ON_LEAVE;
2001
2002     if (flags & SVs_PADTMP) {
2003         flags &= ~SVs_PADTMP;
2004         padtmp = 1;
2005     }
2006     if (gimme == G_SCALAR) {
2007         if (MARK < SP)
2008             *++newsp = ((SvFLAGS(*SP) & flags) || (padtmp && SvPADTMP(*SP)))
2009                             ? *SP : sv_mortalcopy(*SP);
2010         else {
2011             /* MEXTEND() only updates MARK, so reuse it instead of newsp. */
2012             MARK = newsp;
2013             MEXTEND(MARK, 1);
2014             *++MARK = &PL_sv_undef;
2015             return MARK;
2016         }
2017     }
2018     else if (gimme == G_ARRAY) {
2019         /* in case LEAVE wipes old return values */
2020         while (++MARK <= SP) {
2021             if ((SvFLAGS(*MARK) & flags) || (padtmp && SvPADTMP(*MARK)))
2022                 *++newsp = *MARK;
2023             else {
2024                 *++newsp = sv_mortalcopy(*MARK);
2025                 TAINT_NOT;      /* Each item is independent */
2026             }
2027         }
2028         /* When this function was called with MARK == newsp, we reach this
2029          * point with SP == newsp. */
2030     }
2031
2032     return newsp;
2033 }
2034
2035 PP(pp_enter)
2036 {
2037     dVAR; dSP;
2038     PERL_CONTEXT *cx;
2039     I32 gimme = GIMME_V;
2040
2041     ENTER_with_name("block");
2042
2043     SAVETMPS;
2044     PUSHBLOCK(cx, CXt_BLOCK, SP);
2045
2046     RETURN;
2047 }
2048
2049 PP(pp_leave)
2050 {
2051     dVAR; dSP;
2052     PERL_CONTEXT *cx;
2053     SV **newsp;
2054     PMOP *newpm;
2055     I32 gimme;
2056
2057     if (PL_op->op_flags & OPf_SPECIAL) {
2058         cx = &cxstack[cxstack_ix];
2059         cx->blk_oldpm = PL_curpm;       /* fake block should preserve $1 et al */
2060     }
2061
2062     POPBLOCK(cx,newpm);
2063
2064     gimme = OP_GIMME(PL_op, (cxstack_ix >= 0) ? gimme : G_SCALAR);
2065
2066     TAINT_NOT;
2067     SP = adjust_stack_on_leave(newsp, SP, newsp, gimme, SVs_PADTMP|SVs_TEMP);
2068     PL_curpm = newpm;   /* Don't pop $1 et al till now */
2069
2070     LEAVE_with_name("block");
2071
2072     RETURN;
2073 }
2074
2075 PP(pp_enteriter)
2076 {
2077     dVAR; dSP; dMARK;
2078     PERL_CONTEXT *cx;
2079     const I32 gimme = GIMME_V;
2080     void *itervar; /* location of the iteration variable */
2081     U8 cxtype = CXt_LOOP_FOR;
2082
2083     ENTER_with_name("loop1");
2084     SAVETMPS;
2085
2086     if (PL_op->op_targ) {                        /* "my" variable */
2087         if (PL_op->op_private & OPpLVAL_INTRO) {        /* for my $x (...) */
2088             SvPADSTALE_off(PAD_SVl(PL_op->op_targ));
2089             SAVESETSVFLAGS(PAD_SVl(PL_op->op_targ),
2090                     SVs_PADSTALE, SVs_PADSTALE);
2091         }
2092         SAVEPADSVANDMORTALIZE(PL_op->op_targ);
2093 #ifdef USE_ITHREADS
2094         itervar = PL_comppad;
2095 #else
2096         itervar = &PAD_SVl(PL_op->op_targ);
2097 #endif
2098     }
2099     else {                                      /* symbol table variable */
2100         GV * const gv = MUTABLE_GV(POPs);
2101         SV** svp = &GvSV(gv);
2102         save_pushptrptr(gv, SvREFCNT_inc(*svp), SAVEt_GVSV);
2103         *svp = newSV(0);
2104         itervar = (void *)gv;
2105     }
2106
2107     if (PL_op->op_private & OPpITER_DEF)
2108         cxtype |= CXp_FOR_DEF;
2109
2110     ENTER_with_name("loop2");
2111
2112     PUSHBLOCK(cx, cxtype, SP);
2113     PUSHLOOP_FOR(cx, itervar, MARK);
2114     if (PL_op->op_flags & OPf_STACKED) {
2115         SV *maybe_ary = POPs;
2116         if (SvTYPE(maybe_ary) != SVt_PVAV) {
2117             dPOPss;
2118             SV * const right = maybe_ary;
2119             SvGETMAGIC(sv);
2120             SvGETMAGIC(right);
2121             if (RANGE_IS_NUMERIC(sv,right)) {
2122                 cx->cx_type &= ~CXTYPEMASK;
2123                 cx->cx_type |= CXt_LOOP_LAZYIV;
2124                 /* Make sure that no-one re-orders cop.h and breaks our
2125                    assumptions */
2126                 assert(CxTYPE(cx) == CXt_LOOP_LAZYIV);
2127 #ifdef NV_PRESERVES_UV
2128                 if ((SvOK(sv) && ((SvNV_nomg(sv) < (NV)IV_MIN) ||
2129                                   (SvNV_nomg(sv) > (NV)IV_MAX)))
2130                         ||
2131                     (SvOK(right) && ((SvNV_nomg(right) > (NV)IV_MAX) ||
2132                                      (SvNV_nomg(right) < (NV)IV_MIN))))
2133 #else
2134                 if ((SvOK(sv) && ((SvNV_nomg(sv) <= (NV)IV_MIN)
2135                                   ||
2136                                   ((SvNV_nomg(sv) > 0) &&
2137                                         ((SvUV_nomg(sv) > (UV)IV_MAX) ||
2138                                          (SvNV_nomg(sv) > (NV)UV_MAX)))))
2139                         ||
2140                     (SvOK(right) && ((SvNV_nomg(right) <= (NV)IV_MIN)
2141                                      ||
2142                                      ((SvNV_nomg(right) > 0) &&
2143                                         ((SvUV_nomg(right) > (UV)IV_MAX) ||
2144                                          (SvNV_nomg(right) > (NV)UV_MAX))
2145                                      ))))
2146 #endif
2147                     DIE(aTHX_ "Range iterator outside integer range");
2148                 cx->blk_loop.state_u.lazyiv.cur = SvIV_nomg(sv);
2149                 cx->blk_loop.state_u.lazyiv.end = SvIV_nomg(right);
2150 #ifdef DEBUGGING
2151                 /* for correct -Dstv display */
2152                 cx->blk_oldsp = sp - PL_stack_base;
2153 #endif
2154             }
2155             else {
2156                 cx->cx_type &= ~CXTYPEMASK;
2157                 cx->cx_type |= CXt_LOOP_LAZYSV;
2158                 /* Make sure that no-one re-orders cop.h and breaks our
2159                    assumptions */
2160                 assert(CxTYPE(cx) == CXt_LOOP_LAZYSV);
2161                 cx->blk_loop.state_u.lazysv.cur = newSVsv(sv);
2162                 cx->blk_loop.state_u.lazysv.end = right;
2163                 SvREFCNT_inc(right);
2164                 (void) SvPV_force_nolen(cx->blk_loop.state_u.lazysv.cur);
2165                 /* This will do the upgrade to SVt_PV, and warn if the value
2166                    is uninitialised.  */
2167                 (void) SvPV_nolen_const(right);
2168                 /* Doing this avoids a check every time in pp_iter in pp_hot.c
2169                    to replace !SvOK() with a pointer to "".  */
2170                 if (!SvOK(right)) {
2171                     SvREFCNT_dec(right);
2172                     cx->blk_loop.state_u.lazysv.end = &PL_sv_no;
2173                 }
2174             }
2175         }
2176         else /* SvTYPE(maybe_ary) == SVt_PVAV */ {
2177             cx->blk_loop.state_u.ary.ary = MUTABLE_AV(maybe_ary);
2178             SvREFCNT_inc(maybe_ary);
2179             cx->blk_loop.state_u.ary.ix =
2180                 (PL_op->op_private & OPpITER_REVERSED) ?
2181                 AvFILL(cx->blk_loop.state_u.ary.ary) + 1 :
2182                 -1;
2183         }
2184     }
2185     else { /* iterating over items on the stack */
2186         cx->blk_loop.state_u.ary.ary = NULL; /* means to use the stack */
2187         if (PL_op->op_private & OPpITER_REVERSED) {
2188             cx->blk_loop.state_u.ary.ix = cx->blk_oldsp + 1;
2189         }
2190         else {
2191             cx->blk_loop.state_u.ary.ix = MARK - PL_stack_base;
2192         }
2193     }
2194
2195     RETURN;
2196 }
2197
2198 PP(pp_enterloop)
2199 {
2200     dVAR; dSP;
2201     PERL_CONTEXT *cx;
2202     const I32 gimme = GIMME_V;
2203
2204     ENTER_with_name("loop1");
2205     SAVETMPS;
2206     ENTER_with_name("loop2");
2207
2208     PUSHBLOCK(cx, CXt_LOOP_PLAIN, SP);
2209     PUSHLOOP_PLAIN(cx, SP);
2210
2211     RETURN;
2212 }
2213
2214 PP(pp_leaveloop)
2215 {
2216     dVAR; dSP;
2217     PERL_CONTEXT *cx;
2218     I32 gimme;
2219     SV **newsp;
2220     PMOP *newpm;
2221     SV **mark;
2222
2223     POPBLOCK(cx,newpm);
2224     assert(CxTYPE_is_LOOP(cx));
2225     mark = newsp;
2226     newsp = PL_stack_base + cx->blk_loop.resetsp;
2227
2228     TAINT_NOT;
2229     SP = adjust_stack_on_leave(newsp, SP, MARK, gimme, 0);
2230     PUTBACK;
2231
2232     POPLOOP(cx);        /* Stack values are safe: release loop vars ... */
2233     PL_curpm = newpm;   /* ... and pop $1 et al */
2234
2235     LEAVE_with_name("loop2");
2236     LEAVE_with_name("loop1");
2237
2238     return NORMAL;
2239 }
2240
2241 STATIC void
2242 S_return_lvalues(pTHX_ SV **mark, SV **sp, SV **newsp, I32 gimme,
2243                        PERL_CONTEXT *cx, PMOP *newpm)
2244 {
2245     const bool ref = !!(CxLVAL(cx) & OPpENTERSUB_INARGS);
2246     if (gimme == G_SCALAR) {
2247         if (CxLVAL(cx) && !ref) {     /* Leave it as it is if we can. */
2248             SV *sv;
2249             const char *what = NULL;
2250             if (MARK < SP) {
2251                 assert(MARK+1 == SP);
2252                 if ((SvPADTMP(TOPs) ||
2253                      (SvFLAGS(TOPs) & (SVf_READONLY | SVf_FAKE))
2254                        == SVf_READONLY
2255                     ) &&
2256                     !SvSMAGICAL(TOPs)) {
2257                     what =
2258                         SvREADONLY(TOPs) ? (TOPs == &PL_sv_undef) ? "undef"
2259                         : "a readonly value" : "a temporary";
2260                 }
2261                 else goto copy_sv;
2262             }
2263             else {
2264                 /* sub:lvalue{} will take us here. */
2265                 what = "undef";
2266             }
2267             LEAVE;
2268             cxstack_ix--;
2269             POPSUB(cx,sv);
2270             PL_curpm = newpm;
2271             LEAVESUB(sv);
2272             Perl_croak(aTHX_
2273                       "Can't return %s from lvalue subroutine", what
2274             );
2275         }
2276         if (MARK < SP) {
2277               copy_sv:
2278                 if (cx->blk_sub.cv && CvDEPTH(cx->blk_sub.cv) > 1) {
2279                     if (!SvPADTMP(*SP)) {
2280                         *++newsp = SvREFCNT_inc(*SP);
2281                         FREETMPS;
2282                         sv_2mortal(*newsp);
2283                     }
2284                     else {
2285                         /* FREETMPS could clobber it */
2286                         SV *sv = SvREFCNT_inc(*SP);
2287                         FREETMPS;
2288                         *++newsp = sv_mortalcopy(sv);
2289                         SvREFCNT_dec(sv);
2290                     }
2291                 }
2292                 else
2293                     *++newsp =
2294                       SvPADTMP(*SP)
2295                        ? sv_mortalcopy(*SP)
2296                        : !SvTEMP(*SP)
2297                           ? sv_2mortal(SvREFCNT_inc_simple_NN(*SP))
2298                           : *SP;
2299         }
2300         else {
2301             EXTEND(newsp,1);
2302             *++newsp = &PL_sv_undef;
2303         }
2304         if (CxLVAL(cx) & OPpDEREF) {
2305             SvGETMAGIC(TOPs);
2306             if (!SvOK(TOPs)) {
2307                 TOPs = vivify_ref(TOPs, CxLVAL(cx) & OPpDEREF);
2308             }
2309         }
2310     }
2311     else if (gimme == G_ARRAY) {
2312         assert (!(CxLVAL(cx) & OPpDEREF));
2313         if (ref || !CxLVAL(cx))
2314             while (++MARK <= SP)
2315                 *++newsp =
2316                        SvFLAGS(*MARK) & SVs_PADTMP
2317                            ? sv_mortalcopy(*MARK)
2318                      : SvTEMP(*MARK)
2319                            ? *MARK
2320                            : sv_2mortal(SvREFCNT_inc_simple_NN(*MARK));
2321         else while (++MARK <= SP) {
2322             if (*MARK != &PL_sv_undef
2323                     && (SvPADTMP(*MARK)
2324                        || (SvFLAGS(*MARK) & (SVf_READONLY|SVf_FAKE))
2325                              == SVf_READONLY
2326                        )
2327             ) {
2328                     SV *sv;
2329                     /* Might be flattened array after $#array =  */
2330                     PUTBACK;
2331                     LEAVE;
2332                     cxstack_ix--;
2333                     POPSUB(cx,sv);
2334                     PL_curpm = newpm;
2335                     LEAVESUB(sv);
2336                /* diag_listed_as: Can't return %s from lvalue subroutine */
2337                     Perl_croak(aTHX_
2338                         "Can't return a %s from lvalue subroutine",
2339                         SvREADONLY(TOPs) ? "readonly value" : "temporary");
2340             }
2341             else
2342                 *++newsp =
2343                     SvTEMP(*MARK)
2344                        ? *MARK
2345                        : sv_2mortal(SvREFCNT_inc_simple_NN(*MARK));
2346         }
2347     }
2348     PL_stack_sp = newsp;
2349 }
2350
2351 PP(pp_return)
2352 {
2353     dVAR; dSP; dMARK;
2354     PERL_CONTEXT *cx;
2355     bool popsub2 = FALSE;
2356     bool clear_errsv = FALSE;
2357     bool lval = FALSE;
2358     I32 gimme;
2359     SV **newsp;
2360     PMOP *newpm;
2361     I32 optype = 0;
2362     SV *namesv;
2363     SV *sv;
2364     OP *retop = NULL;
2365
2366     const I32 cxix = dopoptosub(cxstack_ix);
2367
2368     if (cxix < 0) {
2369         if (CxMULTICALL(cxstack)) { /* In this case we must be in a
2370                                      * sort block, which is a CXt_NULL
2371                                      * not a CXt_SUB */
2372             dounwind(0);
2373             PL_stack_base[1] = *PL_stack_sp;
2374             PL_stack_sp = PL_stack_base + 1;
2375             return 0;
2376         }
2377         else
2378             DIE(aTHX_ "Can't return outside a subroutine");
2379     }
2380     if (cxix < cxstack_ix)
2381         dounwind(cxix);
2382
2383     if (CxMULTICALL(&cxstack[cxix])) {
2384         gimme = cxstack[cxix].blk_gimme;
2385         if (gimme == G_VOID)
2386             PL_stack_sp = PL_stack_base;
2387         else if (gimme == G_SCALAR) {
2388             PL_stack_base[1] = *PL_stack_sp;
2389             PL_stack_sp = PL_stack_base + 1;
2390         }
2391         return 0;
2392     }
2393
2394     POPBLOCK(cx,newpm);
2395     switch (CxTYPE(cx)) {
2396     case CXt_SUB:
2397         popsub2 = TRUE;
2398         lval = !!CvLVALUE(cx->blk_sub.cv);
2399         retop = cx->blk_sub.retop;
2400         cxstack_ix++; /* preserve cx entry on stack for use by POPSUB */
2401         break;
2402     case CXt_EVAL:
2403         if (!(PL_in_eval & EVAL_KEEPERR))
2404             clear_errsv = TRUE;
2405         POPEVAL(cx);
2406         namesv = cx->blk_eval.old_namesv;
2407         retop = cx->blk_eval.retop;
2408         if (CxTRYBLOCK(cx))
2409             break;
2410         if (optype == OP_REQUIRE &&
2411             (MARK == SP || (gimme == G_SCALAR && !SvTRUE(*SP))) )
2412         {
2413             /* Unassume the success we assumed earlier. */
2414             (void)hv_delete(GvHVn(PL_incgv),
2415                             SvPVX_const(namesv),
2416                             SvUTF8(namesv) ? -(I32)SvCUR(namesv) : (I32)SvCUR(namesv),
2417                             G_DISCARD);
2418             DIE(aTHX_ "%"SVf" did not return a true value", SVfARG(namesv));
2419         }
2420         break;
2421     case CXt_FORMAT:
2422         POPFORMAT(cx);
2423         retop = cx->blk_sub.retop;
2424         break;
2425     default:
2426         DIE(aTHX_ "panic: return, type=%u", (unsigned) CxTYPE(cx));
2427     }
2428
2429     TAINT_NOT;
2430     if (lval) S_return_lvalues(aTHX_ MARK, SP, newsp, gimme, cx, newpm);
2431     else {
2432       if (gimme == G_SCALAR) {
2433         if (MARK < SP) {
2434             if (popsub2) {
2435                 if (cx->blk_sub.cv && CvDEPTH(cx->blk_sub.cv) > 1) {
2436                     if (SvTEMP(TOPs) && SvREFCNT(TOPs) == 1
2437                          && !SvMAGICAL(TOPs)) {
2438                         *++newsp = SvREFCNT_inc(*SP);
2439                         FREETMPS;
2440                         sv_2mortal(*newsp);
2441                     }
2442                     else {
2443                         sv = SvREFCNT_inc(*SP); /* FREETMPS could clobber it */
2444                         FREETMPS;
2445                         *++newsp = sv_mortalcopy(sv);
2446                         SvREFCNT_dec(sv);
2447                     }
2448                 }
2449                 else if (SvTEMP(*SP) && SvREFCNT(*SP) == 1
2450                           && !SvMAGICAL(*SP)) {
2451                     *++newsp = *SP;
2452                 }
2453                 else
2454                     *++newsp = sv_mortalcopy(*SP);
2455             }
2456             else
2457                 *++newsp = sv_mortalcopy(*SP);
2458         }
2459         else
2460             *++newsp = &PL_sv_undef;
2461       }
2462       else if (gimme == G_ARRAY) {
2463         while (++MARK <= SP) {
2464             *++newsp = popsub2 && SvTEMP(*MARK) && SvREFCNT(*MARK) == 1
2465                                && !SvGMAGICAL(*MARK)
2466                         ? *MARK : sv_mortalcopy(*MARK);
2467             TAINT_NOT;          /* Each item is independent */
2468         }
2469       }
2470       PL_stack_sp = newsp;
2471     }
2472
2473     LEAVE;
2474     /* Stack values are safe: */
2475     if (popsub2) {
2476         cxstack_ix--;
2477         POPSUB(cx,sv);  /* release CV and @_ ... */
2478     }
2479     else
2480         sv = NULL;
2481     PL_curpm = newpm;   /* ... and pop $1 et al */
2482
2483     LEAVESUB(sv);
2484     if (clear_errsv) {
2485         CLEAR_ERRSV();
2486     }
2487     return retop;
2488 }
2489
2490 /* This duplicates parts of pp_leavesub, so that it can share code with
2491  * pp_return */
2492 PP(pp_leavesublv)
2493 {
2494     dVAR; dSP;
2495     SV **newsp;
2496     PMOP *newpm;
2497     I32 gimme;
2498     PERL_CONTEXT *cx;
2499     SV *sv;
2500
2501     if (CxMULTICALL(&cxstack[cxstack_ix]))
2502         return 0;
2503
2504     POPBLOCK(cx,newpm);
2505     cxstack_ix++; /* temporarily protect top context */
2506
2507     TAINT_NOT;
2508
2509     S_return_lvalues(aTHX_ newsp, SP, newsp, gimme, cx, newpm);
2510
2511     LEAVE;
2512     cxstack_ix--;
2513     POPSUB(cx,sv);      /* Stack values are safe: release CV and @_ ... */
2514     PL_curpm = newpm;   /* ... and pop $1 et al */
2515
2516     LEAVESUB(sv);
2517     return cx->blk_sub.retop;
2518 }
2519
2520 static I32
2521 S_unwind_loop(pTHX_ const char * const opname)
2522 {
2523     dVAR;
2524     I32 cxix;
2525     if (PL_op->op_flags & OPf_SPECIAL) {
2526         cxix = dopoptoloop(cxstack_ix);
2527         if (cxix < 0)
2528             /* diag_listed_as: Can't "last" outside a loop block */
2529             Perl_croak(aTHX_ "Can't \"%s\" outside a loop block", opname);
2530     }
2531     else {
2532         dSP;
2533         STRLEN label_len;
2534         const char * const label =
2535             PL_op->op_flags & OPf_STACKED
2536                 ? SvPV(TOPs,label_len)
2537                 : (label_len = strlen(cPVOP->op_pv), cPVOP->op_pv);
2538         const U32 label_flags =
2539             PL_op->op_flags & OPf_STACKED
2540                 ? SvUTF8(POPs)
2541                 : (cPVOP->op_private & OPpPV_IS_UTF8) ? SVf_UTF8 : 0;
2542         PUTBACK;
2543         cxix = dopoptolabel(label, label_len, label_flags);
2544         if (cxix < 0)
2545             /* diag_listed_as: Label not found for "last %s" */
2546             Perl_croak(aTHX_ "Label not found for \"%s %"SVf"\"",
2547                                        opname,
2548                                        SVfARG(PL_op->op_flags & OPf_STACKED
2549                                               && !SvGMAGICAL(TOPp1s)
2550                                               ? TOPp1s
2551                                               : newSVpvn_flags(label,
2552                                                     label_len,
2553                                                     label_flags | SVs_TEMP)));
2554     }
2555     if (cxix < cxstack_ix)
2556         dounwind(cxix);
2557     return cxix;
2558 }
2559
2560 PP(pp_last)
2561 {
2562     dVAR;
2563     PERL_CONTEXT *cx;
2564     I32 pop2 = 0;
2565     I32 gimme;
2566     I32 optype;
2567     OP *nextop = NULL;
2568     SV **newsp;
2569     PMOP *newpm;
2570     SV **mark;
2571     SV *sv = NULL;
2572
2573     S_unwind_loop(aTHX_ "last");
2574
2575     POPBLOCK(cx,newpm);
2576     cxstack_ix++; /* temporarily protect top context */
2577     mark = newsp;
2578     switch (CxTYPE(cx)) {
2579     case CXt_LOOP_LAZYIV:
2580     case CXt_LOOP_LAZYSV:
2581     case CXt_LOOP_FOR:
2582     case CXt_LOOP_PLAIN:
2583         pop2 = CxTYPE(cx);
2584         newsp = PL_stack_base + cx->blk_loop.resetsp;
2585         nextop = cx->blk_loop.my_op->op_lastop->op_next;
2586         break;
2587     case CXt_SUB:
2588         pop2 = CXt_SUB;
2589         nextop = cx->blk_sub.retop;
2590         break;
2591     case CXt_EVAL:
2592         POPEVAL(cx);
2593         nextop = cx->blk_eval.retop;
2594         break;
2595     case CXt_FORMAT:
2596         POPFORMAT(cx);
2597         nextop = cx->blk_sub.retop;
2598         break;
2599     default:
2600         DIE(aTHX_ "panic: last, type=%u", (unsigned) CxTYPE(cx));
2601     }
2602
2603     TAINT_NOT;
2604     PL_stack_sp = adjust_stack_on_leave(newsp, PL_stack_sp, MARK, gimme,
2605                                 pop2 == CXt_SUB ? SVs_TEMP : 0);
2606
2607     LEAVE;
2608     cxstack_ix--;
2609     /* Stack values are safe: */
2610     switch (pop2) {
2611     case CXt_LOOP_LAZYIV:
2612     case CXt_LOOP_PLAIN:
2613     case CXt_LOOP_LAZYSV:
2614     case CXt_LOOP_FOR:
2615         POPLOOP(cx);    /* release loop vars ... */
2616         LEAVE;
2617         break;
2618     case CXt_SUB:
2619         POPSUB(cx,sv);  /* release CV and @_ ... */
2620         break;
2621     }
2622     PL_curpm = newpm;   /* ... and pop $1 et al */
2623
2624     LEAVESUB(sv);
2625     PERL_UNUSED_VAR(optype);
2626     PERL_UNUSED_VAR(gimme);
2627     return nextop;
2628 }
2629
2630 PP(pp_next)
2631 {
2632     dVAR;
2633     PERL_CONTEXT *cx;
2634     const I32 inner = PL_scopestack_ix;
2635
2636     S_unwind_loop(aTHX_ "next");
2637
2638     /* clear off anything above the scope we're re-entering, but
2639      * save the rest until after a possible continue block */
2640     TOPBLOCK(cx);
2641     if (PL_scopestack_ix < inner)
2642         leave_scope(PL_scopestack[PL_scopestack_ix]);
2643     PL_curcop = cx->blk_oldcop;
2644     return (cx)->blk_loop.my_op->op_nextop;
2645 }
2646
2647 PP(pp_redo)
2648 {
2649     dVAR;
2650     const I32 cxix = S_unwind_loop(aTHX_ "redo");
2651     PERL_CONTEXT *cx;
2652     I32 oldsave;
2653     OP* redo_op = cxstack[cxix].blk_loop.my_op->op_redoop;
2654
2655     if (redo_op->op_type == OP_ENTER) {
2656         /* pop one less context to avoid $x being freed in while (my $x..) */
2657         cxstack_ix++;
2658         assert(CxTYPE(&cxstack[cxstack_ix]) == CXt_BLOCK);
2659         redo_op = redo_op->op_next;
2660     }
2661
2662     TOPBLOCK(cx);
2663     oldsave = PL_scopestack[PL_scopestack_ix - 1];
2664     LEAVE_SCOPE(oldsave);
2665     FREETMPS;
2666     PL_curcop = cx->blk_oldcop;
2667     return redo_op;
2668 }
2669
2670 STATIC OP *
2671 S_dofindlabel(pTHX_ OP *o, const char *label, STRLEN len, U32 flags, OP **opstack, OP **oplimit)
2672 {
2673     dVAR;
2674     OP **ops = opstack;
2675     static const char too_deep[] = "Target of goto is too deeply nested";
2676
2677     PERL_ARGS_ASSERT_DOFINDLABEL;
2678
2679     if (ops >= oplimit)
2680         Perl_croak(aTHX_ too_deep);
2681     if (o->op_type == OP_LEAVE ||
2682         o->op_type == OP_SCOPE ||
2683         o->op_type == OP_LEAVELOOP ||
2684         o->op_type == OP_LEAVESUB ||
2685         o->op_type == OP_LEAVETRY)
2686     {
2687         *ops++ = cUNOPo->op_first;
2688         if (ops >= oplimit)
2689             Perl_croak(aTHX_ too_deep);
2690     }
2691     *ops = 0;
2692     if (o->op_flags & OPf_KIDS) {
2693         OP *kid;
2694         /* First try all the kids at this level, since that's likeliest. */
2695         for (kid = cUNOPo->op_first; kid; kid = kid->op_sibling) {
2696             if (kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE) {
2697                 STRLEN kid_label_len;
2698                 U32 kid_label_flags;
2699                 const char *kid_label = CopLABEL_len_flags(kCOP,
2700                                                     &kid_label_len, &kid_label_flags);
2701                 if (kid_label && (
2702                     ( (kid_label_flags & SVf_UTF8) != (flags & SVf_UTF8) ) ?
2703                         (flags & SVf_UTF8)
2704                             ? (bytes_cmp_utf8(
2705                                         (const U8*)kid_label, kid_label_len,
2706                                         (const U8*)label, len) == 0)
2707                             : (bytes_cmp_utf8(
2708                                         (const U8*)label, len,
2709                                         (const U8*)kid_label, kid_label_len) == 0)
2710                     : ( len == kid_label_len && ((kid_label == label)
2711                                     || memEQ(kid_label, label, len)))))
2712                     return kid;
2713             }
2714         }
2715         for (kid = cUNOPo->op_first; kid; kid = kid->op_sibling) {
2716             if (kid == PL_lastgotoprobe)
2717                 continue;
2718             if (kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE) {
2719                 if (ops == opstack)
2720                     *ops++ = kid;
2721                 else if (ops[-1]->op_type == OP_NEXTSTATE ||
2722                          ops[-1]->op_type == OP_DBSTATE)
2723                     ops[-1] = kid;
2724                 else
2725                     *ops++ = kid;
2726             }
2727             if ((o = dofindlabel(kid, label, len, flags, ops, oplimit)))
2728                 return o;
2729         }
2730     }
2731     *ops = 0;
2732     return 0;
2733 }
2734
2735 PP(pp_goto)
2736 {
2737     dVAR; dSP;
2738     OP *retop = NULL;
2739     I32 ix;
2740     PERL_CONTEXT *cx;
2741 #define GOTO_DEPTH 64
2742     OP *enterops[GOTO_DEPTH];
2743     const char *label = NULL;
2744     STRLEN label_len = 0;
2745     U32 label_flags = 0;
2746     const bool do_dump = (PL_op->op_type == OP_DUMP);
2747     static const char must_have_label[] = "goto must have label";
2748
2749     if (PL_op->op_flags & OPf_STACKED) {
2750         SV * const sv = POPs;
2751
2752         /* This egregious kludge implements goto &subroutine */
2753         if (SvROK(sv) && SvTYPE(SvRV(sv)) == SVt_PVCV) {
2754             I32 cxix;
2755             PERL_CONTEXT *cx;
2756             CV *cv = MUTABLE_CV(SvRV(sv));
2757             SV** mark;
2758             I32 items = 0;
2759             I32 oldsave;
2760             bool reified = 0;
2761
2762         retry:
2763             if (!CvROOT(cv) && !CvXSUB(cv)) {
2764                 const GV * const gv = CvGV(cv);
2765                 if (gv) {
2766                     GV *autogv;
2767                     SV *tmpstr;
2768                     /* autoloaded stub? */
2769                     if (cv != GvCV(gv) && (cv = GvCV(gv)))
2770                         goto retry;
2771                     autogv = gv_autoload_pvn(GvSTASH(gv), GvNAME(gv),
2772                                           GvNAMELEN(gv),
2773                                           GvNAMEUTF8(gv) ? SVf_UTF8 : 0);
2774                     if (autogv && (cv = GvCV(autogv)))
2775                         goto retry;
2776                     tmpstr = sv_newmortal();
2777                     gv_efullname3(tmpstr, gv, NULL);
2778                     DIE(aTHX_ "Goto undefined subroutine &%"SVf"", SVfARG(tmpstr));
2779                 }
2780                 DIE(aTHX_ "Goto undefined subroutine");
2781             }
2782
2783             /* First do some returnish stuff. */
2784             SvREFCNT_inc_simple_void(cv); /* avoid premature free during unwind */
2785             FREETMPS;
2786             cxix = dopoptosub(cxstack_ix);
2787             if (cxix < 0)
2788                 DIE(aTHX_ "Can't goto subroutine outside a subroutine");
2789             if (cxix < cxstack_ix)
2790                 dounwind(cxix);
2791             TOPBLOCK(cx);
2792             SPAGAIN;
2793             /* ban goto in eval: see <20050521150056.GC20213@iabyn.com> */
2794             if (CxTYPE(cx) == CXt_EVAL) {
2795                 if (CxREALEVAL(cx))
2796                 /* diag_listed_as: Can't goto subroutine from an eval-%s */
2797                     DIE(aTHX_ "Can't goto subroutine from an eval-string");
2798                 else
2799                 /* diag_listed_as: Can't goto subroutine from an eval-%s */
2800                     DIE(aTHX_ "Can't goto subroutine from an eval-block");
2801             }
2802             else if (CxMULTICALL(cx))
2803                 DIE(aTHX_ "Can't goto subroutine from a sort sub (or similar callback)");
2804             if (CxTYPE(cx) == CXt_SUB && CxHASARGS(cx)) {
2805                 /* put @_ back onto stack */
2806                 AV* av = cx->blk_sub.argarray;
2807
2808                 items = AvFILLp(av) + 1;
2809                 EXTEND(SP, items+1); /* @_ could have been extended. */
2810                 Copy(AvARRAY(av), SP + 1, items, SV*);
2811                 SvREFCNT_dec(GvAV(PL_defgv));
2812                 GvAV(PL_defgv) = cx->blk_sub.savearray;
2813                 CLEAR_ARGARRAY(av);
2814                 /* abandon @_ if it got reified */
2815                 if (AvREAL(av)) {
2816                     reified = 1;
2817                     SvREFCNT_dec(av);
2818                     av = newAV();
2819                     av_extend(av, items-1);
2820                     AvREIFY_only(av);
2821                     PAD_SVl(0) = MUTABLE_SV(cx->blk_sub.argarray = av);
2822                 }
2823             }
2824             else if (CvISXSUB(cv)) {    /* put GvAV(defgv) back onto stack */
2825                 AV* const av = GvAV(PL_defgv);
2826                 items = AvFILLp(av) + 1;
2827                 EXTEND(SP, items+1); /* @_ could have been extended. */
2828                 Copy(AvARRAY(av), SP + 1, items, SV*);
2829             }
2830             mark = SP;
2831             SP += items;
2832             if (CxTYPE(cx) == CXt_SUB &&
2833                 !(CvDEPTH(cx->blk_sub.cv) = cx->blk_sub.olddepth))
2834                 SvREFCNT_dec(cx->blk_sub.cv);
2835             oldsave = PL_scopestack[PL_scopestack_ix - 1];
2836             LEAVE_SCOPE(oldsave);
2837
2838             /* A destructor called during LEAVE_SCOPE could have undefined
2839              * our precious cv.  See bug #99850. */
2840             if (!CvROOT(cv) && !CvXSUB(cv)) {
2841                 const GV * const gv = CvGV(cv);
2842                 if (gv) {
2843                     SV * const tmpstr = sv_newmortal();
2844                     gv_efullname3(tmpstr, gv, NULL);
2845                     DIE(aTHX_ "Goto undefined subroutine &%"SVf"",
2846                                SVfARG(tmpstr));
2847                 }
2848                 DIE(aTHX_ "Goto undefined subroutine");
2849             }
2850
2851             /* Now do some callish stuff. */
2852             SAVETMPS;
2853             SAVEFREESV(cv); /* later, undo the 'avoid premature free' hack */
2854             if (CvISXSUB(cv)) {
2855                 OP* const retop = cx->blk_sub.retop;
2856                 SV **newsp PERL_UNUSED_DECL;
2857                 I32 gimme PERL_UNUSED_DECL;
2858                 if (reified) {
2859                     I32 index;
2860                     for (index=0; index<items; index++)
2861                         sv_2mortal(SP[-index]);
2862                 }
2863
2864                 /* XS subs don't have a CxSUB, so pop it */
2865                 POPBLOCK(cx, PL_curpm);
2866                 /* Push a mark for the start of arglist */
2867                 PUSHMARK(mark);
2868                 PUTBACK;
2869                 (void)(*CvXSUB(cv))(aTHX_ cv);
2870                 LEAVE;
2871                 return retop;
2872             }
2873             else {
2874                 PADLIST * const padlist = CvPADLIST(cv);
2875                 if (CxTYPE(cx) == CXt_EVAL) {
2876                     PL_in_eval = CxOLD_IN_EVAL(cx);
2877                     PL_eval_root = cx->blk_eval.old_eval_root;
2878                     cx->cx_type = CXt_SUB;
2879                 }
2880                 cx->blk_sub.cv = cv;
2881                 cx->blk_sub.olddepth = CvDEPTH(cv);
2882
2883                 CvDEPTH(cv)++;
2884                 if (CvDEPTH(cv) < 2)
2885                     SvREFCNT_inc_simple_void_NN(cv);
2886                 else {
2887                     if (CvDEPTH(cv) == PERL_SUB_DEPTH_WARN && ckWARN(WARN_RECURSION))
2888                         sub_crush_depth(cv);
2889                     pad_push(padlist, CvDEPTH(cv));
2890                 }
2891                 PL_curcop = cx->blk_oldcop;
2892                 SAVECOMPPAD();
2893                 PAD_SET_CUR_NOSAVE(padlist, CvDEPTH(cv));
2894                 if (CxHASARGS(cx))
2895                 {
2896                     AV *const av = MUTABLE_AV(PAD_SVl(0));
2897
2898                     cx->blk_sub.savearray = GvAV(PL_defgv);
2899                     GvAV(PL_defgv) = MUTABLE_AV(SvREFCNT_inc_simple(av));
2900                     CX_CURPAD_SAVE(cx->blk_sub);
2901                     cx->blk_sub.argarray = av;
2902
2903                     if (items >= AvMAX(av) + 1) {
2904                         SV **ary = AvALLOC(av);
2905                         if (AvARRAY(av) != ary) {
2906                             AvMAX(av) += AvARRAY(av) - AvALLOC(av);
2907                             AvARRAY(av) = ary;
2908                         }
2909                         if (items >= AvMAX(av) + 1) {
2910                             AvMAX(av) = items - 1;
2911                             Renew(ary,items+1,SV*);
2912                             AvALLOC(av) = ary;
2913                             AvARRAY(av) = ary;
2914                         }
2915                     }
2916                     ++mark;
2917                     Copy(mark,AvARRAY(av),items,SV*);
2918                     AvFILLp(av) = items - 1;
2919                     assert(!AvREAL(av));
2920                     if (reified) {
2921                         /* transfer 'ownership' of refcnts to new @_ */
2922                         AvREAL_on(av);
2923                         AvREIFY_off(av);
2924                     }
2925                     while (items--) {
2926                         if (*mark)
2927                             SvTEMP_off(*mark);
2928                         mark++;
2929                     }
2930                 }
2931                 if (PERLDB_SUB) {       /* Checking curstash breaks DProf. */
2932                     Perl_get_db_sub(aTHX_ NULL, cv);
2933                     if (PERLDB_GOTO) {
2934                         CV * const gotocv = get_cvs("DB::goto", 0);
2935                         if (gotocv) {
2936                             PUSHMARK( PL_stack_sp );
2937                             call_sv(MUTABLE_SV(gotocv), G_SCALAR | G_NODEBUG);
2938                             PL_stack_sp--;
2939                         }
2940                     }
2941                 }
2942                 RETURNOP(CvSTART(cv));
2943             }
2944         }
2945         else {
2946             label       = SvPV_const(sv, label_len);
2947             label_flags = SvUTF8(sv);
2948         }
2949     }
2950     else if (!(PL_op->op_flags & OPf_SPECIAL)) {
2951         label       = cPVOP->op_pv;
2952         label_flags = (cPVOP->op_private & OPpPV_IS_UTF8) ? SVf_UTF8 : 0;
2953         label_len   = strlen(label);
2954     }
2955     if (!(do_dump || label_len)) DIE(aTHX_ must_have_label);
2956
2957     PERL_ASYNC_CHECK();
2958
2959     if (label_len) {
2960         OP *gotoprobe = NULL;
2961         bool leaving_eval = FALSE;
2962         bool in_block = FALSE;
2963         PERL_CONTEXT *last_eval_cx = NULL;
2964
2965         /* find label */
2966
2967         PL_lastgotoprobe = NULL;
2968         *enterops = 0;
2969         for (ix = cxstack_ix; ix >= 0; ix--) {
2970             cx = &cxstack[ix];
2971             switch (CxTYPE(cx)) {
2972             case CXt_EVAL:
2973                 leaving_eval = TRUE;
2974                 if (!CxTRYBLOCK(cx)) {
2975                     gotoprobe = (last_eval_cx ?
2976                                 last_eval_cx->blk_eval.old_eval_root :
2977                                 PL_eval_root);
2978                     last_eval_cx = cx;
2979                     break;
2980                 }
2981                 /* else fall through */
2982             case CXt_LOOP_LAZYIV:
2983             case CXt_LOOP_LAZYSV:
2984             case CXt_LOOP_FOR:
2985             case CXt_LOOP_PLAIN:
2986             case CXt_GIVEN:
2987             case CXt_WHEN:
2988                 gotoprobe = cx->blk_oldcop->op_sibling;
2989                 break;
2990             case CXt_SUBST:
2991                 continue;
2992             case CXt_BLOCK:
2993                 if (ix) {
2994                     gotoprobe = cx->blk_oldcop->op_sibling;
2995                     in_block = TRUE;
2996                 } else
2997                     gotoprobe = PL_main_root;
2998                 break;
2999             case CXt_SUB:
3000                 if (CvDEPTH(cx->blk_sub.cv) && !CxMULTICALL(cx)) {
3001                     gotoprobe = CvROOT(cx->blk_sub.cv);
3002                     break;
3003                 }
3004                 /* FALL THROUGH */
3005             case CXt_FORMAT:
3006             case CXt_NULL:
3007                 DIE(aTHX_ "Can't \"goto\" out of a pseudo block");
3008             default:
3009                 if (ix)
3010                     DIE(aTHX_ "panic: goto, type=%u, ix=%ld",
3011                         CxTYPE(cx), (long) ix);
3012                 gotoprobe = PL_main_root;
3013                 break;
3014             }
3015             if (gotoprobe) {
3016                 retop = dofindlabel(gotoprobe, label, label_len, label_flags,
3017                                     enterops, enterops + GOTO_DEPTH);
3018                 if (retop)
3019                     break;
3020                 if (gotoprobe->op_sibling &&
3021                         gotoprobe->op_sibling->op_type == OP_UNSTACK &&
3022                         gotoprobe->op_sibling->op_sibling) {
3023                     retop = dofindlabel(gotoprobe->op_sibling->op_sibling,
3024                                         label, label_len, label_flags, enterops,
3025                                         enterops + GOTO_DEPTH);
3026                     if (retop)
3027                         break;
3028                 }
3029             }
3030             PL_lastgotoprobe = gotoprobe;
3031         }
3032         if (!retop)
3033             DIE(aTHX_ "Can't find label %"SVf,
3034                             SVfARG(newSVpvn_flags(label, label_len,
3035                                         SVs_TEMP | label_flags)));
3036
3037         /* if we're leaving an eval, check before we pop any frames
3038            that we're not going to punt, otherwise the error
3039            won't be caught */
3040
3041         if (leaving_eval && *enterops && enterops[1]) {
3042             I32 i;
3043             for (i = 1; enterops[i]; i++)
3044                 if (enterops[i]->op_type == OP_ENTERITER)
3045                     DIE(aTHX_ "Can't \"goto\" into the middle of a foreach loop");
3046         }
3047
3048         if (*enterops && enterops[1]) {
3049             I32 i = enterops[1]->op_type == OP_ENTER && in_block ? 2 : 1;
3050             if (enterops[i])
3051                 deprecate("\"goto\" to jump into a construct");
3052         }
3053
3054         /* pop unwanted frames */
3055
3056         if (ix < cxstack_ix) {
3057             I32 oldsave;
3058
3059             if (ix < 0)
3060                 ix = 0;
3061             dounwind(ix);
3062             TOPBLOCK(cx);
3063             oldsave = PL_scopestack[PL_scopestack_ix];
3064             LEAVE_SCOPE(oldsave);
3065         }
3066
3067         /* push wanted frames */
3068
3069         if (*enterops && enterops[1]) {
3070             OP * const oldop = PL_op;
3071             ix = enterops[1]->op_type == OP_ENTER && in_block ? 2 : 1;
3072             for (; enterops[ix]; ix++) {
3073                 PL_op = enterops[ix];
3074                 /* Eventually we may want to stack the needed arguments
3075                  * for each op.  For now, we punt on the hard ones. */
3076                 if (PL_op->op_type == OP_ENTERITER)
3077                     DIE(aTHX_ "Can't \"goto\" into the middle of a foreach loop");
3078                 PL_op->op_ppaddr(aTHX);
3079             }
3080             PL_op = oldop;
3081         }
3082     }
3083
3084     if (do_dump) {
3085 #ifdef VMS
3086         if (!retop) retop = PL_main_start;
3087 #endif
3088         PL_restartop = retop;
3089         PL_do_undump = TRUE;
3090
3091         my_unexec();
3092
3093         PL_restartop = 0;               /* hmm, must be GNU unexec().. */
3094         PL_do_undump = FALSE;
3095     }
3096
3097     RETURNOP(retop);
3098 }
3099
3100 PP(pp_exit)
3101 {
3102     dVAR;
3103     dSP;
3104     I32 anum;
3105
3106     if (MAXARG < 1)
3107         anum = 0;
3108     else if (!TOPs) {
3109         anum = 0; (void)POPs;
3110     }
3111     else {
3112         anum = SvIVx(POPs);
3113 #ifdef VMS
3114         if (anum == 1 && (PL_op->op_private & OPpEXIT_VMSISH))
3115             anum = 0;
3116         VMSISH_HUSHED  = VMSISH_HUSHED || (PL_op->op_private & OPpHUSH_VMSISH);
3117 #endif
3118     }
3119     PL_exit_flags |= PERL_EXIT_EXPECTED;
3120 #ifdef PERL_MAD
3121     /* KLUDGE: disable exit 0 in BEGIN blocks when we're just compiling */
3122     if (anum || !(PL_minus_c && PL_madskills))
3123         my_exit(anum);
3124 #else
3125     my_exit(anum);
3126 #endif
3127     PUSHs(&PL_sv_undef);
3128     RETURN;
3129 }
3130
3131 /* Eval. */
3132
3133 STATIC void
3134 S_save_lines(pTHX_ AV *array, SV *sv)
3135 {
3136     const char *s = SvPVX_const(sv);
3137     const char * const send = SvPVX_const(sv) + SvCUR(sv);
3138     I32 line = 1;
3139
3140     PERL_ARGS_ASSERT_SAVE_LINES;
3141
3142     while (s && s < send) {
3143         const char *t;
3144         SV * const tmpstr = newSV_type(SVt_PVMG);
3145
3146         t = (const char *)memchr(s, '\n', send - s);
3147         if (t)
3148             t++;
3149         else
3150             t = send;
3151
3152         sv_setpvn(tmpstr, s, t - s);
3153         av_store(array, line++, tmpstr);
3154         s = t;
3155     }
3156 }
3157
3158 /*
3159 =for apidoc docatch
3160
3161 Check for the cases 0 or 3 of cur_env.je_ret, only used inside an eval context.
3162
3163 0 is used as continue inside eval,
3164
3165 3 is used for a die caught by an inner eval - continue inner loop
3166
3167 See cop.h: je_mustcatch, when set at any runlevel to TRUE, means eval ops must
3168 establish a local jmpenv to handle exception traps.
3169
3170 =cut
3171 */
3172 STATIC OP *
3173 S_docatch(pTHX_ OP *o)
3174 {
3175     dVAR;
3176     int ret;
3177     OP * const oldop = PL_op;
3178     dJMPENV;
3179
3180 #ifdef DEBUGGING
3181     assert(CATCH_GET == TRUE);
3182 #endif
3183     PL_op = o;
3184
3185     JMPENV_PUSH(ret);
3186     switch (ret) {
3187     case 0:
3188         assert(cxstack_ix >= 0);
3189         assert(CxTYPE(&cxstack[cxstack_ix]) == CXt_EVAL);
3190         cxstack[cxstack_ix].blk_eval.cur_top_env = PL_top_env;
3191  redo_body:
3192         CALLRUNOPS(aTHX);
3193         break;
3194     case 3:
3195         /* die caught by an inner eval - continue inner loop */
3196         if (PL_restartop && PL_restartjmpenv == PL_top_env) {
3197             PL_restartjmpenv = NULL;
3198             PL_op = PL_restartop;
3199             PL_restartop = 0;
3200             goto redo_body;
3201         }
3202         /* FALL THROUGH */
3203     default:
3204         JMPENV_POP;
3205         PL_op = oldop;
3206         JMPENV_JUMP(ret);
3207         assert(0); /* NOTREACHED */
3208     }
3209     JMPENV_POP;
3210     PL_op = oldop;
3211     return NULL;
3212 }
3213
3214
3215 /*
3216 =for apidoc find_runcv
3217
3218 Locate the CV corresponding to the currently executing sub or eval.
3219 If db_seqp is non_null, skip CVs that are in the DB package and populate
3220 *db_seqp with the cop sequence number at the point that the DB:: code was
3221 entered. (allows debuggers to eval in the scope of the breakpoint rather
3222 than in the scope of the debugger itself).
3223
3224 =cut
3225 */
3226
3227 CV*
3228 Perl_find_runcv(pTHX_ U32 *db_seqp)
3229 {
3230     return Perl_find_runcv_where(aTHX_ 0, 0, db_seqp);
3231 }
3232
3233 /* If this becomes part of the API, it might need a better name. */
3234 CV *
3235 Perl_find_runcv_where(pTHX_ U8 cond, IV arg, U32 *db_seqp)
3236 {
3237     dVAR;
3238     PERL_SI      *si;
3239     int          level = 0;
3240
3241     if (db_seqp)
3242         *db_seqp = PL_curcop->cop_seq;
3243     for (si = PL_curstackinfo; si; si = si->si_prev) {
3244         I32 ix;
3245         for (ix = si->si_cxix; ix >= 0; ix--) {
3246             const PERL_CONTEXT *cx = &(si->si_cxstack[ix]);
3247             CV *cv = NULL;
3248             if (CxTYPE(cx) == CXt_SUB || CxTYPE(cx) == CXt_FORMAT) {
3249                 cv = cx->blk_sub.cv;
3250                 /* skip DB:: code */
3251                 if (db_seqp && PL_debstash && CvSTASH(cv) == PL_debstash) {
3252                     *db_seqp = cx->blk_oldcop->cop_seq;
3253                     continue;
3254                 }
3255             }
3256             else if (CxTYPE(cx) == CXt_EVAL && !CxTRYBLOCK(cx))
3257                 cv = cx->blk_eval.cv;
3258             if (cv) {
3259                 switch (cond) {
3260                 case FIND_RUNCV_padid_eq:
3261                     if (!CvPADLIST(cv)
3262                      || CvPADLIST(cv)->xpadl_id != (U32)arg) continue;
3263                     return cv;
3264                 case FIND_RUNCV_level_eq:
3265                     if (level++ != arg) continue;
3266                     /* GERONIMO! */
3267                 default:
3268                     return cv;
3269                 }
3270             }
3271         }
3272     }
3273     return cond == FIND_RUNCV_padid_eq ? NULL : PL_main_cv;
3274 }
3275
3276
3277 /* Run yyparse() in a setjmp wrapper. Returns:
3278  *   0: yyparse() successful
3279  *   1: yyparse() failed
3280  *   3: yyparse() died
3281  */
3282 STATIC int
3283 S_try_yyparse(pTHX_ int gramtype)
3284 {
3285     int ret;
3286     dJMPENV;
3287
3288     assert(CxTYPE(&cxstack[cxstack_ix]) == CXt_EVAL);
3289     JMPENV_PUSH(ret);
3290     switch (ret) {
3291     case 0:
3292         ret = yyparse(gramtype) ? 1 : 0;
3293         break;
3294     case 3:
3295         break;
3296     default:
3297         JMPENV_POP;
3298         JMPENV_JUMP(ret);
3299         assert(0); /* NOTREACHED */
3300     }
3301     JMPENV_POP;
3302     return ret;
3303 }
3304
3305
3306 /* Compile a require/do or an eval ''.
3307  *
3308  * outside is the lexically enclosing CV (if any) that invoked us.
3309  * seq     is the current COP scope value.
3310  * hh      is the saved hints hash, if any.
3311  *
3312  * Returns a bool indicating whether the compile was successful; if so,
3313  * PL_eval_start contains the first op of the compiled code; otherwise,
3314  * pushes undef.
3315  *
3316  * This function is called from two places: pp_require and pp_entereval.
3317  * These can be distinguished by whether PL_op is entereval.
3318  */
3319
3320 STATIC bool
3321 S_doeval(pTHX_ int gimme, CV* outside, U32 seq, HV *hh)
3322 {
3323     dVAR; dSP;
3324     OP * const saveop = PL_op;
3325     bool clear_hints = saveop->op_type != OP_ENTEREVAL;
3326     COP * const oldcurcop = PL_curcop;
3327     bool in_require = (saveop->op_type == OP_REQUIRE);
3328     int yystatus;
3329     CV *evalcv;
3330
3331     PL_in_eval = (in_require
3332                   ? (EVAL_INREQUIRE | (PL_in_eval & EVAL_INEVAL))
3333                   : EVAL_INEVAL);
3334
3335     PUSHMARK(SP);
3336
3337     evalcv = MUTABLE_CV(newSV_type(SVt_PVCV));
3338     CvEVAL_on(evalcv);
3339     assert(CxTYPE(&cxstack[cxstack_ix]) == CXt_EVAL);
3340     cxstack[cxstack_ix].blk_eval.cv = evalcv;
3341     cxstack[cxstack_ix].blk_gimme = gimme;
3342
3343     CvOUTSIDE_SEQ(evalcv) = seq;
3344     CvOUTSIDE(evalcv) = MUTABLE_CV(SvREFCNT_inc_simple(outside));
3345
3346     /* set up a scratch pad */
3347
3348     CvPADLIST(evalcv) = pad_new(padnew_SAVE);
3349     PL_op = NULL; /* avoid PL_op and PL_curpad referring to different CVs */
3350
3351
3352     if (!PL_madskills)
3353         SAVEMORTALIZESV(evalcv);        /* must remain until end of current statement */
3354
3355     /* make sure we compile in the right package */
3356
3357     if (CopSTASH_ne(PL_curcop, PL_curstash)) {
3358         SAVEGENERICSV(PL_curstash);
3359         PL_curstash = (HV *)SvREFCNT_inc_simple(CopSTASH(PL_curcop));
3360     }
3361     /* XXX:ajgo do we really need to alloc an AV for begin/checkunit */
3362     SAVESPTR(PL_beginav);
3363     PL_beginav = newAV();
3364     SAVEFREESV(PL_beginav);
3365     SAVESPTR(PL_unitcheckav);
3366     PL_unitcheckav = newAV();
3367     SAVEFREESV(PL_unitcheckav);
3368
3369 #ifdef PERL_MAD
3370     SAVEBOOL(PL_madskills);
3371     PL_madskills = 0;
3372 #endif
3373
3374     ENTER_with_name("evalcomp");
3375     SAVESPTR(PL_compcv);
3376     PL_compcv = evalcv;
3377
3378     /* try to compile it */
3379
3380     PL_eval_root = NULL;
3381     PL_curcop = &PL_compiling;
3382     if ((saveop->op_type != OP_REQUIRE) && (saveop->op_flags & OPf_SPECIAL))
3383         PL_in_eval |= EVAL_KEEPERR;
3384     else
3385         CLEAR_ERRSV();
3386
3387     SAVEHINTS();
3388     if (clear_hints) {
3389         PL_hints = 0;
3390         hv_clear(GvHV(PL_hintgv));
3391     }
3392     else {
3393         PL_hints = saveop->op_private & OPpEVAL_COPHH
3394                      ? oldcurcop->cop_hints : saveop->op_targ;
3395         if (hh) {
3396             /* SAVEHINTS created a new HV in PL_hintgv, which we need to GC */
3397             SvREFCNT_dec(GvHV(PL_hintgv));
3398             GvHV(PL_hintgv) = hh;
3399         }
3400     }
3401     SAVECOMPILEWARNINGS();
3402     if (clear_hints) {
3403         if (PL_dowarn & G_WARN_ALL_ON)
3404             PL_compiling.cop_warnings = pWARN_ALL ;
3405         else if (PL_dowarn & G_WARN_ALL_OFF)
3406             PL_compiling.cop_warnings = pWARN_NONE ;
3407         else
3408             PL_compiling.cop_warnings = pWARN_STD ;
3409     }
3410     else {
3411         PL_compiling.cop_warnings =
3412             DUP_WARNINGS(oldcurcop->cop_warnings);
3413         cophh_free(CopHINTHASH_get(&PL_compiling));
3414         if (Perl_cop_fetch_label(aTHX_ oldcurcop, NULL, NULL)) {
3415             /* The label, if present, is the first entry on the chain. So rather
3416                than writing a blank label in front of it (which involves an
3417                allocation), just use the next entry in the chain.  */
3418             PL_compiling.cop_hints_hash
3419                 = cophh_copy(oldcurcop->cop_hints_hash->refcounted_he_next);
3420             /* Check the assumption that this removed the label.  */
3421             assert(Perl_cop_fetch_label(aTHX_ &PL_compiling, NULL, NULL) == NULL);
3422         }
3423         else
3424             PL_compiling.cop_hints_hash = cophh_copy(oldcurcop->cop_hints_hash);
3425     }
3426
3427     CALL_BLOCK_HOOKS(bhk_eval, saveop);
3428
3429     /* note that yyparse() may raise an exception, e.g. C<BEGIN{die}>,
3430      * so honour CATCH_GET and trap it here if necessary */
3431
3432     yystatus = (!in_require && CATCH_GET) ? S_try_yyparse(aTHX_ GRAMPROG) : yyparse(GRAMPROG);
3433
3434     if (yystatus || PL_parser->error_count || !PL_eval_root) {
3435         SV **newsp;                     /* Used by POPBLOCK. */
3436         PERL_CONTEXT *cx;
3437         I32 optype;                     /* Used by POPEVAL. */
3438         SV *namesv;
3439
3440         cx = NULL;
3441         namesv = NULL;
3442         PERL_UNUSED_VAR(newsp);
3443         PERL_UNUSED_VAR(optype);
3444
3445         /* note that if yystatus == 3, then the EVAL CX block has already
3446          * been popped, and various vars restored */
3447         PL_op = saveop;
3448         if (yystatus != 3) {
3449             if (PL_eval_root) {
3450                 cv_forget_slab(evalcv);
3451                 op_free(PL_eval_root);
3452                 PL_eval_root = NULL;
3453             }
3454             SP = PL_stack_base + POPMARK;       /* pop original mark */
3455             POPBLOCK(cx,PL_curpm);
3456             POPEVAL(cx);
3457             namesv = cx->blk_eval.old_namesv;
3458             /* POPBLOCK renders LEAVE_with_name("evalcomp") unnecessary. */
3459             LEAVE_with_name("eval"); /* pp_entereval knows about this LEAVE.  */
3460         }
3461
3462         if (in_require) {
3463             if (!cx) {
3464                 /* If cx is still NULL, it means that we didn't go in the
3465                  * POPEVAL branch. */
3466                 cx = &cxstack[cxstack_ix];
3467                 assert(CxTYPE(cx) == CXt_EVAL);
3468                 namesv = cx->blk_eval.old_namesv;
3469             }
3470             (void)hv_store(GvHVn(PL_incgv),
3471                            SvPVX_const(namesv),
3472                            SvUTF8(namesv) ? -(I32)SvCUR(namesv) : (I32)SvCUR(namesv),
3473                            &PL_sv_undef, 0);
3474             Perl_croak(aTHX_ "%"SVf"Compilation failed in require",
3475                        SVfARG(ERRSV
3476                                 ? ERRSV
3477                                 : newSVpvs_flags("Unknown error\n", SVs_TEMP)));
3478         }
3479         else {
3480             if (!*(SvPVx_nolen_const(ERRSV))) {
3481                 sv_setpvs(ERRSV, "Compilation error");
3482             }
3483         }
3484         if (gimme != G_ARRAY) PUSHs(&PL_sv_undef);
3485         PUTBACK;
3486         return FALSE;
3487     }
3488     else
3489         LEAVE_with_name("evalcomp");
3490
3491     CopLINE_set(&PL_compiling, 0);
3492     SAVEFREEOP(PL_eval_root);
3493     cv_forget_slab(evalcv);
3494
3495     DEBUG_x(dump_eval());
3496
3497     /* Register with debugger: */
3498     if (PERLDB_INTER && saveop->op_type == OP_REQUIRE) {
3499         CV * const cv = get_cvs("DB::postponed", 0);
3500         if (cv) {
3501             dSP;
3502             PUSHMARK(SP);
3503             XPUSHs(MUTABLE_SV(CopFILEGV(&PL_compiling)));
3504             PUTBACK;
3505             call_sv(MUTABLE_SV(cv), G_DISCARD);
3506         }
3507     }
3508
3509     if (PL_unitcheckav) {
3510         OP *es = PL_eval_start;
3511         call_list(PL_scopestack_ix, PL_unitcheckav);
3512         PL_eval_start = es;
3513     }
3514
3515     /* compiled okay, so do it */
3516
3517     CvDEPTH(evalcv) = 1;
3518     SP = PL_stack_base + POPMARK;               /* pop original mark */
3519     PL_op = saveop;                     /* The caller may need it. */
3520     PL_parser->lex_state = LEX_NOTPARSING;      /* $^S needs this. */
3521
3522     PUTBACK;
3523     return TRUE;
3524 }
3525
3526 STATIC PerlIO *
3527 S_check_type_and_open(pTHX_ SV *name)
3528 {
3529     Stat_t st;
3530     const char *p = SvPV_nolen_const(name);
3531     const int st_rc = PerlLIO_stat(p, &st);
3532
3533     PERL_ARGS_ASSERT_CHECK_TYPE_AND_OPEN;
3534
3535     if (st_rc < 0 || S_ISDIR(st.st_mode) || S_ISBLK(st.st_mode)) {
3536         return NULL;
3537     }
3538
3539 #if !defined(PERLIO_IS_STDIO) && !defined(USE_SFIO)
3540     return PerlIO_openn(aTHX_ ":", PERL_SCRIPT_MODE, -1, 0, 0, NULL, 1, &name);
3541 #else
3542     return PerlIO_open(p, PERL_SCRIPT_MODE);
3543 #endif
3544 }
3545
3546 #ifndef PERL_DISABLE_PMC
3547 STATIC PerlIO *
3548 S_doopen_pm(pTHX_ SV *name)
3549 {
3550     STRLEN namelen;
3551     const char *p = SvPV_const(name, namelen);
3552
3553     PERL_ARGS_ASSERT_DOOPEN_PM;
3554
3555     if (namelen > 3 && memEQs(p + namelen - 3, 3, ".pm")) {
3556         SV *const pmcsv = sv_newmortal();
3557         Stat_t pmcstat;
3558
3559         SvSetSV_nosteal(pmcsv,name);
3560         sv_catpvn(pmcsv, "c", 1);
3561
3562         if (PerlLIO_stat(SvPV_nolen_const(pmcsv), &pmcstat) >= 0)
3563             return check_type_and_open(pmcsv);
3564     }
3565     return check_type_and_open(name);
3566 }
3567 #else
3568 #  define doopen_pm(name) check_type_and_open(name)
3569 #endif /* !PERL_DISABLE_PMC */
3570
3571 PP(pp_require)
3572 {
3573     dVAR; dSP;
3574     PERL_CONTEXT *cx;
3575     SV *sv;
3576     const char *name;
3577     STRLEN len;
3578     char * unixname;
3579     STRLEN unixlen;
3580 #ifdef VMS
3581     int vms_unixname = 0;
3582     char *unixnamebuf;
3583     char *unixdir;
3584     char *unixdirbuf;
3585 #endif
3586     const char *tryname = NULL;
3587     SV *namesv = NULL;
3588     const I32 gimme = GIMME_V;
3589     int filter_has_file = 0;
3590     PerlIO *tryrsfp = NULL;
3591     SV *filter_cache = NULL;
3592     SV *filter_state = NULL;
3593     SV *filter_sub = NULL;
3594     SV *hook_sv = NULL;
3595     SV *encoding;
3596     OP *op;
3597     int saved_errno;
3598
3599     sv = POPs;
3600     if ( (SvNIOKp(sv) || SvVOK(sv)) && PL_op->op_type != OP_DOFILE) {
3601         sv = sv_2mortal(new_version(sv));
3602         if (!sv_derived_from(PL_patchlevel, "version"))
3603             upg_version(PL_patchlevel, TRUE);
3604         if (cUNOP->op_first->op_type == OP_CONST && cUNOP->op_first->op_private & OPpCONST_NOVER) {
3605             if ( vcmp(sv,PL_patchlevel) <= 0 )
3606                 DIE(aTHX_ "Perls since %"SVf" too modern--this is %"SVf", stopped",
3607                     SVfARG(sv_2mortal(vnormal(sv))),
3608                     SVfARG(sv_2mortal(vnormal(PL_patchlevel)))
3609                 );
3610         }
3611         else {
3612             if ( vcmp(sv,PL_patchlevel) > 0 ) {
3613                 I32 first = 0;
3614                 AV *lav;
3615                 SV * const req = SvRV(sv);
3616                 SV * const pv = *hv_fetchs(MUTABLE_HV(req), "original", FALSE);
3617
3618                 /* get the left hand term */
3619                 lav = MUTABLE_AV(SvRV(*hv_fetchs(MUTABLE_HV(req), "version", FALSE)));
3620
3621                 first  = SvIV(*av_fetch(lav,0,0));
3622                 if (   first > (int)PERL_REVISION    /* probably 'use 6.0' */
3623                     || hv_exists(MUTABLE_HV(req), "qv", 2 ) /* qv style */
3624                     || av_len(lav) > 1               /* FP with > 3 digits */
3625                     || strstr(SvPVX(pv),".0")        /* FP with leading 0 */
3626                    ) {
3627                     DIE(aTHX_ "Perl %"SVf" required--this is only "
3628                         "%"SVf", stopped",
3629                         SVfARG(sv_2mortal(vnormal(req))),
3630                         SVfARG(sv_2mortal(vnormal(PL_patchlevel)))
3631                     );
3632                 }
3633                 else { /* probably 'use 5.10' or 'use 5.8' */
3634                     SV *hintsv;
3635                     I32 second = 0;
3636
3637                     if (av_len(lav)>=1)
3638                         second = SvIV(*av_fetch(lav,1,0));
3639
3640                     second /= second >= 600  ? 100 : 10;
3641                     hintsv = Perl_newSVpvf(aTHX_ "v%d.%d.0",
3642                                            (int)first, (int)second);
3643                     upg_version(hintsv, TRUE);
3644
3645                     DIE(aTHX_ "Perl %"SVf" required (did you mean %"SVf"?)"
3646                         "--this is only %"SVf", stopped",
3647                         SVfARG(sv_2mortal(vnormal(req))),
3648                         SVfARG(sv_2mortal(vnormal(sv_2mortal(hintsv)))),
3649                         SVfARG(sv_2mortal(vnormal(PL_patchlevel)))
3650                     );
3651                 }
3652             }
3653         }
3654
3655         RETPUSHYES;
3656     }
3657     name = SvPV_const(sv, len);
3658     if (!(name && len > 0 && *name))
3659         DIE(aTHX_ "Null filename used");
3660     TAINT_PROPER("require");
3661
3662
3663 #ifdef VMS
3664     /* The key in the %ENV hash is in the syntax of file passed as the argument
3665      * usually this is in UNIX format, but sometimes in VMS format, which
3666      * can result in a module being pulled in more than once.
3667      * To prevent this, the key must be stored in UNIX format if the VMS
3668      * name can be translated to UNIX.
3669      */
3670
3671     if ((unixnamebuf = SvPVX(sv_2mortal(newSVpv("", VMS_MAXRSS-1))))
3672         && (unixname = tounixspec(name, unixnamebuf)) != NULL) {
3673         unixlen = strlen(unixname);
3674         vms_unixname = 1;
3675     }
3676     else
3677 #endif
3678     {
3679         /* if not VMS or VMS name can not be translated to UNIX, pass it
3680          * through.
3681          */
3682         unixname = (char *) name;
3683         unixlen = len;
3684     }
3685     if (PL_op->op_type == OP_REQUIRE) {
3686         SV * const * const svp = hv_fetch(GvHVn(PL_incgv),
3687                                           unixname, unixlen, 0);
3688         if ( svp ) {
3689             if (*svp != &PL_sv_undef)
3690                 RETPUSHYES;
3691             else
3692                 DIE(aTHX_ "Attempt to reload %s aborted.\n"
3693                             "Compilation failed in require", unixname);
3694         }
3695     }
3696
3697     /* prepare to compile file */
3698
3699     if (path_is_absolute(name)) {
3700         /* At this point, name is SvPVX(sv)  */
3701         tryname = name;
3702         tryrsfp = doopen_pm(sv);
3703     }
3704     if (!tryrsfp && !(errno == EACCES && path_is_absolute(name))) {
3705         AV * const ar = GvAVn(PL_incgv);
3706         I32 i;
3707 #ifdef VMS
3708         if (vms_unixname)
3709 #endif
3710         {
3711             namesv = newSV_type(SVt_PV);
3712             for (i = 0; i <= AvFILL(ar); i++) {
3713                 SV * const dirsv = *av_fetch(ar, i, TRUE);
3714
3715                 if (SvTIED_mg((const SV *)ar, PERL_MAGIC_tied))
3716                     mg_get(dirsv);
3717                 if (SvROK(dirsv)) {
3718                     int count;
3719                     SV **svp;
3720                     SV *loader = dirsv;
3721
3722                     if (SvTYPE(SvRV(loader)) == SVt_PVAV
3723                         && !sv_isobject(loader))
3724                     {
3725                         loader = *av_fetch(MUTABLE_AV(SvRV(loader)), 0, TRUE);
3726                     }
3727
3728                     Perl_sv_setpvf(aTHX_ namesv, "/loader/0x%"UVxf"/%s",
3729                                    PTR2UV(SvRV(dirsv)), name);
3730                     tryname = SvPVX_const(namesv);
3731                     tryrsfp = NULL;
3732
3733                     ENTER_with_name("call_INC");
3734                     SAVETMPS;
3735                     EXTEND(SP, 2);
3736
3737                     PUSHMARK(SP);
3738                     PUSHs(dirsv);
3739                     PUSHs(sv);
3740                     PUTBACK;
3741                     if (sv_isobject(loader))
3742                         count = call_method("INC", G_ARRAY);
3743                     else
3744                         count = call_sv(loader, G_ARRAY);
3745                     SPAGAIN;
3746
3747                     if (count > 0) {
3748                         int i = 0;
3749                         SV *arg;
3750
3751                         SP -= count - 1;
3752                         arg = SP[i++];
3753
3754                         if (SvROK(arg) && (SvTYPE(SvRV(arg)) <= SVt_PVLV)
3755                             && !isGV_with_GP(SvRV(arg))) {
3756                             filter_cache = SvRV(arg);
3757                             SvREFCNT_inc_simple_void_NN(filter_cache);
3758
3759                             if (i < count) {
3760                                 arg = SP[i++];
3761                             }
3762                         }
3763
3764                         if (SvROK(arg) && isGV_with_GP(SvRV(arg))) {
3765                             arg = SvRV(arg);
3766                         }
3767
3768                         if (isGV_with_GP(arg)) {
3769                             IO * const io = GvIO((const GV *)arg);
3770
3771                             ++filter_has_file;
3772
3773                             if (io) {
3774                                 tryrsfp = IoIFP(io);
3775                                 if (IoOFP(io) && IoOFP(io) != IoIFP(io)) {
3776                                     PerlIO_close(IoOFP(io));
3777                                 }
3778                                 IoIFP(io) = NULL;
3779                                 IoOFP(io) = NULL;
3780                             }
3781
3782                             if (i < count) {
3783                                 arg = SP[i++];
3784                             }
3785                         }
3786
3787                         if (SvROK(arg) && SvTYPE(SvRV(arg)) == SVt_PVCV) {
3788                             filter_sub = arg;
3789                             SvREFCNT_inc_simple_void_NN(filter_sub);
3790
3791                             if (i < count) {
3792                                 filter_state = SP[i];
3793                                 SvREFCNT_inc_simple_void(filter_state);
3794                             }
3795                         }
3796
3797                         if (!tryrsfp && (filter_cache || filter_sub)) {
3798                             tryrsfp = PerlIO_open(BIT_BUCKET,
3799                                                   PERL_SCRIPT_MODE);
3800                         }
3801                         SP--;
3802                     }
3803
3804                     PUTBACK;
3805                     FREETMPS;
3806                     LEAVE_with_name("call_INC");
3807
3808                     /* Adjust file name if the hook has set an %INC entry.
3809                        This needs to happen after the FREETMPS above.  */
3810                     svp = hv_fetch(GvHVn(PL_incgv), name, len, 0);
3811                     if (svp)
3812                         tryname = SvPV_nolen_const(*svp);
3813
3814                     if (tryrsfp) {
3815                         hook_sv = dirsv;
3816                         break;
3817                     }
3818
3819                     filter_has_file = 0;
3820                     if (filter_cache) {
3821                         SvREFCNT_dec(filter_cache);
3822                         filter_cache = NULL;
3823                     }
3824                     if (filter_state) {
3825                         SvREFCNT_dec(filter_state);
3826                         filter_state = NULL;
3827                     }
3828                     if (filter_sub) {
3829                         SvREFCNT_dec(filter_sub);
3830                         filter_sub = NULL;
3831                     }
3832                 }
3833                 else {
3834                   if (!path_is_absolute(name)
3835                   ) {
3836                     const char *dir;
3837                     STRLEN dirlen;
3838
3839                     if (SvOK(dirsv)) {
3840                         dir = SvPV_const(dirsv, dirlen);
3841                     } else {
3842                         dir = "";
3843                         dirlen = 0;
3844                     }
3845
3846 #ifdef VMS
3847                     if (((unixdirbuf = SvPVX(sv_2mortal(newSVpv("", VMS_MAXRSS-1)))) == NULL)
3848                         || ((unixdir = tounixpath(dir, unixdirbuf)) == NULL))
3849                         continue;
3850                     sv_setpv(namesv, unixdir);
3851                     sv_catpv(namesv, unixname);
3852 #else
3853 #  ifdef __SYMBIAN32__
3854                     if (PL_origfilename[0] &&
3855                         PL_origfilename[1] == ':' &&
3856                         !(dir[0] && dir[1] == ':'))
3857                         Perl_sv_setpvf(aTHX_ namesv,
3858                                        "%c:%s\\%s",
3859                                        PL_origfilename[0],
3860                                        dir, name);
3861                     else
3862                         Perl_sv_setpvf(aTHX_ namesv,
3863                                        "%s\\%s",
3864                                        dir, name);
3865 #  else
3866                     /* The equivalent of
3867                        Perl_sv_setpvf(aTHX_ namesv, "%s/%s", dir, name);
3868                        but without the need to parse the format string, or
3869                        call strlen on either pointer, and with the correct
3870                        allocation up front.  */
3871                     {
3872                         char *tmp = SvGROW(namesv, dirlen + len + 2);
3873
3874                         memcpy(tmp, dir, dirlen);
3875                         tmp +=dirlen;
3876                         *tmp++ = '/';
3877                         /* name came from an SV, so it will have a '\0' at the
3878                            end that we can copy as part of this memcpy().  */
3879                         memcpy(tmp, name, len + 1);
3880
3881                         SvCUR_set(namesv, dirlen + len + 1);
3882                         SvPOK_on(namesv);
3883                     }
3884 #  endif
3885 #endif
3886                     TAINT_PROPER("require");
3887                     tryname = SvPVX_const(namesv);
3888                     tryrsfp = doopen_pm(namesv);
3889                     if (tryrsfp) {
3890                         if (tryname[0] == '.' && tryname[1] == '/') {
3891                             ++tryname;
3892                             while (*++tryname == '/');
3893                         }
3894                         break;
3895                     }
3896                     else if (errno == EMFILE || errno == EACCES) {
3897                         /* no point in trying other paths if out of handles;
3898                          * on the other hand, if we couldn't open one of the
3899                          * files, then going on with the search could lead to
3900                          * unexpected results; see perl #113422
3901                          */
3902                         break;
3903                     }
3904                   }
3905                 }
3906             }
3907         }
3908     }
3909     saved_errno = errno; /* sv_2mortal can realloc things */
3910     sv_2mortal(namesv);
3911     if (!tryrsfp) {
3912         if (PL_op->op_type == OP_REQUIRE) {
3913             if(saved_errno == EMFILE || saved_errno == EACCES) {
3914                 /* diag_listed_as: Can't locate %s */
3915                 DIE(aTHX_ "Can't locate %s:   %s", name, Strerror(saved_errno));
3916             } else {
3917                 if (namesv) {                   /* did we lookup @INC? */
3918                     AV * const ar = GvAVn(PL_incgv);
3919                     I32 i;
3920                     SV *const inc = newSVpvs_flags("", SVs_TEMP);
3921                     for (i = 0; i <= AvFILL(ar); i++) {
3922                         sv_catpvs(inc, " ");
3923                         sv_catsv(inc, *av_fetch(ar, i, TRUE));
3924                     }
3925
3926                     /* diag_listed_as: Can't locate %s */
3927                     DIE(aTHX_
3928                         "Can't locate %s in @INC%s%s (@INC contains:%" SVf ")",
3929                         name,
3930                         (len >= 2 && memEQ(name + len - 2, ".h", 3)
3931                          ? " (change .h to .ph maybe?) (did you run h2ph?)" : ""),
3932                         (len >= 3 && memEQ(name + len - 3, ".ph", 4)
3933                          ? " (did you run h2ph?)" : ""),
3934                         inc
3935                         );
3936                 }
3937             }
3938             DIE(aTHX_ "Can't locate %s", name);
3939         }
3940
3941         CLEAR_ERRSV();
3942         RETPUSHUNDEF;
3943     }
3944     else
3945         SETERRNO(0, SS_NORMAL);
3946
3947     /* Assume success here to prevent recursive requirement. */
3948     /* name is never assigned to again, so len is still strlen(name)  */
3949     /* Check whether a hook in @INC has already filled %INC */
3950     if (!hook_sv) {
3951         (void)hv_store(GvHVn(PL_incgv),
3952                        unixname, unixlen, newSVpv(tryname,0),0);
3953     } else {
3954         SV** const svp = hv_fetch(GvHVn(PL_incgv), unixname, unixlen, 0);
3955         if (!svp)
3956             (void)hv_store(GvHVn(PL_incgv),
3957                            unixname, unixlen, SvREFCNT_inc_simple(hook_sv), 0 );
3958     }
3959
3960     ENTER_with_name("eval");
3961     SAVETMPS;
3962     SAVECOPFILE_FREE(&PL_compiling);
3963     CopFILE_set(&PL_compiling, tryname);
3964     lex_start(NULL, tryrsfp, 0);
3965
3966     if (filter_sub || filter_cache) {
3967         /* We can use the SvPV of the filter PVIO itself as our cache, rather
3968            than hanging another SV from it. In turn, filter_add() optionally
3969            takes the SV to use as the filter (or creates a new SV if passed
3970            NULL), so simply pass in whatever value filter_cache has.  */
3971         SV * const datasv = filter_add(S_run_user_filter, filter_cache);
3972         IoLINES(datasv) = filter_has_file;
3973         IoTOP_GV(datasv) = MUTABLE_GV(filter_state);
3974         IoBOTTOM_GV(datasv) = MUTABLE_GV(filter_sub);
3975     }
3976
3977     /* switch to eval mode */
3978     PUSHBLOCK(cx, CXt_EVAL, SP);
3979     PUSHEVAL(cx, name);
3980     cx->blk_eval.retop = PL_op->op_next;
3981
3982     SAVECOPLINE(&PL_compiling);
3983     CopLINE_set(&PL_compiling, 0);
3984
3985     PUTBACK;
3986
3987     /* Store and reset encoding. */
3988     encoding = PL_encoding;
3989     PL_encoding = NULL;
3990
3991     if (doeval(gimme, NULL, PL_curcop->cop_seq, NULL))
3992         op = DOCATCH(PL_eval_start);
3993     else
3994         op = PL_op->op_next;
3995
3996     /* Restore encoding. */
3997     PL_encoding = encoding;
3998
3999     return op;
4000 }
4001
4002 /* This is a op added to hold the hints hash for
4003    pp_entereval. The hash can be modified by the code
4004    being eval'ed, so we return a copy instead. */
4005
4006 PP(pp_hintseval)
4007 {
4008     dVAR;
4009     dSP;
4010     mXPUSHs(MUTABLE_SV(hv_copy_hints_hv(MUTABLE_HV(cSVOP_sv))));
4011     RETURN;
4012 }
4013
4014
4015 PP(pp_entereval)
4016 {
4017     dVAR; dSP;
4018     PERL_CONTEXT *cx;
4019     SV *sv;
4020     const I32 gimme = GIMME_V;
4021     const U32 was = PL_breakable_sub_gen;
4022     char tbuf[TYPE_DIGITS(long) + 12];
4023     bool saved_delete = FALSE;
4024     char *tmpbuf = tbuf;
4025     STRLEN len;
4026     CV* runcv;
4027     U32 seq, lex_flags = 0;
4028     HV *saved_hh = NULL;
4029     const bool bytes = PL_op->op_private & OPpEVAL_BYTES;
4030
4031     if (PL_op->op_private & OPpEVAL_HAS_HH) {
4032         saved_hh = MUTABLE_HV(SvREFCNT_inc(POPs));
4033     }
4034     else if (PL_hints & HINT_LOCALIZE_HH || (
4035                 PL_op->op_private & OPpEVAL_COPHH
4036              && PL_curcop->cop_hints & HINT_LOCALIZE_HH
4037             )) {
4038         saved_hh = cop_hints_2hv(PL_curcop, 0);
4039         hv_magic(saved_hh, NULL, PERL_MAGIC_hints);
4040     }
4041     sv = POPs;
4042     if (!SvPOK(sv)) {
4043         /* make sure we've got a plain PV (no overload etc) before testing
4044          * for taint. Making a copy here is probably overkill, but better
4045          * safe than sorry */
4046         STRLEN len;
4047         const char * const p = SvPV_const(sv, len);
4048
4049         sv = newSVpvn_flags(p, len, SVs_TEMP | SvUTF8(sv));
4050         lex_flags |= LEX_START_COPIED;
4051
4052         if (bytes && SvUTF8(sv))
4053             SvPVbyte_force(sv, len);
4054     }
4055     else if (bytes && SvUTF8(sv)) {
4056         /* Don't modify someone else's scalar */
4057         STRLEN len;
4058         sv = newSVsv(sv);
4059         (void)sv_2mortal(sv);
4060         SvPVbyte_force(sv,len);
4061         lex_flags |= LEX_START_COPIED;
4062     }
4063
4064     TAINT_IF(SvTAINTED(sv));
4065     TAINT_PROPER("eval");
4066
4067     ENTER_with_name("eval");
4068     lex_start(sv, NULL, lex_flags | (PL_op->op_private & OPpEVAL_UNICODE
4069                            ? LEX_IGNORE_UTF8_HINTS
4070                            : bytes ? LEX_EVALBYTES : LEX_START_SAME_FILTER
4071                         )
4072              );
4073     SAVETMPS;
4074
4075     /* switch to eval mode */
4076
4077     if (PERLDB_NAMEEVAL && CopLINE(PL_curcop)) {
4078         SV * const temp_sv = sv_newmortal();
4079         Perl_sv_setpvf(aTHX_ temp_sv, "_<(eval %lu)[%s:%"IVdf"]",
4080                        (unsigned long)++PL_evalseq,
4081                        CopFILE(PL_curcop), (IV)CopLINE(PL_curcop));
4082         tmpbuf = SvPVX(temp_sv);
4083         len = SvCUR(temp_sv);
4084     }
4085     else
4086         len = my_snprintf(tmpbuf, sizeof(tbuf), "_<(eval %lu)", (unsigned long)++PL_evalseq);
4087     SAVECOPFILE_FREE(&PL_compiling);
4088     CopFILE_set(&PL_compiling, tmpbuf+2);
4089     SAVECOPLINE(&PL_compiling);
4090     CopLINE_set(&PL_compiling, 1);
4091     /* special case: an eval '' executed within the DB package gets lexically
4092      * placed in the first non-DB CV rather than the current CV - this
4093      * allows the debugger to execute code, find lexicals etc, in the
4094      * scope of the code being debugged. Passing &seq gets find_runcv
4095      * to do the dirty work for us */
4096     runcv = find_runcv(&seq);
4097
4098     PUSHBLOCK(cx, (CXt_EVAL|CXp_REAL), SP);
4099     PUSHEVAL(cx, 0);
4100     cx->blk_eval.retop = PL_op->op_next;
4101
4102     /* prepare to compile string */
4103
4104     if ((PERLDB_LINE || PERLDB_SAVESRC) && PL_curstash != PL_debstash)
4105         save_lines(CopFILEAV(&PL_compiling), PL_parser->linestr);
4106     else {
4107         /* XXX For C<eval "...">s within BEGIN {} blocks, this ends up
4108            deleting the eval's FILEGV from the stash before gv_check() runs
4109            (i.e. before run-time proper). To work around the coredump that
4110            ensues, we always turn GvMULTI_on for any globals that were
4111            introduced within evals. See force_ident(). GSAR 96-10-12 */
4112         char *const safestr = savepvn(tmpbuf, len);
4113         SAVEDELETE(PL_defstash, safestr, len);
4114         saved_delete = TRUE;
4115     }
4116
4117     PUTBACK;
4118
4119     if (doeval(gimme, runcv, seq, saved_hh)) {
4120         if (was != PL_breakable_sub_gen /* Some subs defined here. */
4121             ? (PERLDB_LINE || PERLDB_SAVESRC)
4122             :  PERLDB_SAVESRC_NOSUBS) {
4123             /* Retain the filegv we created.  */
4124         } else if (!saved_delete) {
4125             char *const safestr = savepvn(tmpbuf, len);
4126             SAVEDELETE(PL_defstash, safestr, len);
4127         }
4128         return DOCATCH(PL_eval_start);
4129     } else {
4130         /* We have already left the scope set up earlier thanks to the LEAVE
4131            in doeval().  */
4132         if (was != PL_breakable_sub_gen /* Some subs defined here. */
4133             ? (PERLDB_LINE || PERLDB_SAVESRC)
4134             :  PERLDB_SAVESRC_INVALID) {
4135             /* Retain the filegv we created.  */
4136         } else if (!saved_delete) {
4137             (void)hv_delete(PL_defstash, tmpbuf, len, G_DISCARD);
4138         }
4139         return PL_op->op_next;
4140     }
4141 }
4142
4143 PP(pp_leaveeval)
4144 {
4145     dVAR; dSP;
4146     SV **newsp;
4147     PMOP *newpm;
4148     I32 gimme;
4149     PERL_CONTEXT *cx;
4150     OP *retop;
4151     const U8 save_flags = PL_op -> op_flags;
4152     I32 optype;
4153     SV *namesv;
4154     CV *evalcv;
4155
4156     PERL_ASYNC_CHECK();
4157     POPBLOCK(cx,newpm);
4158     POPEVAL(cx);
4159     namesv = cx->blk_eval.old_namesv;
4160     retop = cx->blk_eval.retop;
4161     evalcv = cx->blk_eval.cv;
4162
4163     TAINT_NOT;
4164     SP = adjust_stack_on_leave((gimme == G_VOID) ? SP : newsp, SP, newsp,
4165                                 gimme, SVs_TEMP);
4166     PL_curpm = newpm;   /* Don't pop $1 et al till now */
4167
4168 #ifdef DEBUGGING
4169     assert(CvDEPTH(evalcv) == 1);
4170 #endif
4171     CvDEPTH(evalcv) = 0;
4172
4173     if (optype == OP_REQUIRE &&
4174         !(gimme == G_SCALAR ? SvTRUE(*SP) : SP > newsp))
4175     {
4176         /* Unassume the success we assumed earlier. */
4177         (void)hv_delete(GvHVn(PL_incgv),
4178                         SvPVX_const(namesv),
4179                         SvUTF8(namesv) ? -(I32)SvCUR(namesv) : (I32)SvCUR(namesv),
4180                         G_DISCARD);
4181         retop = Perl_die(aTHX_ "%"SVf" did not return a true value",
4182                                SVfARG(namesv));
4183         /* die_unwind() did LEAVE, or we won't be here */
4184     }
4185     else {
4186         LEAVE_with_name("eval");
4187         if (!(save_flags & OPf_SPECIAL)) {
4188             CLEAR_ERRSV();
4189         }
4190     }
4191
4192     RETURNOP(retop);
4193 }
4194
4195 /* Common code for Perl_call_sv and Perl_fold_constants, put here to keep it
4196    close to the related Perl_create_eval_scope.  */
4197 void
4198 Perl_delete_eval_scope(pTHX)
4199 {
4200     SV **newsp;
4201     PMOP *newpm;
4202     I32 gimme;
4203     PERL_CONTEXT *cx;
4204     I32 optype;
4205
4206     POPBLOCK(cx,newpm);
4207     POPEVAL(cx);
4208     PL_curpm = newpm;
4209     LEAVE_with_name("eval_scope");
4210     PERL_UNUSED_VAR(newsp);
4211     PERL_UNUSED_VAR(gimme);
4212     PERL_UNUSED_VAR(optype);
4213 }
4214
4215 /* Common-ish code salvaged from Perl_call_sv and pp_entertry, because it was
4216    also needed by Perl_fold_constants.  */
4217 PERL_CONTEXT *
4218 Perl_create_eval_scope(pTHX_ U32 flags)
4219 {
4220     PERL_CONTEXT *cx;
4221     const I32 gimme = GIMME_V;
4222
4223     ENTER_with_name("eval_scope");
4224     SAVETMPS;
4225
4226     PUSHBLOCK(cx, (CXt_EVAL|CXp_TRYBLOCK), PL_stack_sp);
4227     PUSHEVAL(cx, 0);
4228
4229     PL_in_eval = EVAL_INEVAL;
4230     if (flags & G_KEEPERR)
4231         PL_in_eval |= EVAL_KEEPERR;
4232     else
4233         CLEAR_ERRSV();
4234     if (flags & G_FAKINGEVAL) {
4235         PL_eval_root = PL_op; /* Only needed so that goto works right. */
4236     }
4237     return cx;
4238 }
4239
4240 PP(pp_entertry)
4241 {
4242     dVAR;
4243     PERL_CONTEXT * const cx = create_eval_scope(0);
4244     cx->blk_eval.retop = cLOGOP->op_other->op_next;
4245     return DOCATCH(PL_op->op_next);
4246 }
4247
4248 PP(pp_leavetry)
4249 {
4250     dVAR; dSP;
4251     SV **newsp;
4252     PMOP *newpm;
4253     I32 gimme;
4254     PERL_CONTEXT *cx;
4255     I32 optype;
4256
4257     PERL_ASYNC_CHECK();
4258     POPBLOCK(cx,newpm);
4259     POPEVAL(cx);
4260     PERL_UNUSED_VAR(optype);
4261
4262     TAINT_NOT;
4263     SP = adjust_stack_on_leave(newsp, SP, newsp, gimme, SVs_PADTMP|SVs_TEMP);
4264     PL_curpm = newpm;   /* Don't pop $1 et al till now */
4265
4266     LEAVE_with_name("eval_scope");
4267     CLEAR_ERRSV();
4268     RETURN;
4269 }
4270
4271 PP(pp_entergiven)
4272 {
4273     dVAR; dSP;
4274     PERL_CONTEXT *cx;
4275     const I32 gimme = GIMME_V;
4276
4277     ENTER_with_name("given");
4278     SAVETMPS;
4279
4280     if (PL_op->op_targ) {
4281         SAVEPADSVANDMORTALIZE(PL_op->op_targ);
4282         SvREFCNT_dec(PAD_SVl(PL_op->op_targ));
4283         PAD_SVl(PL_op->op_targ) = SvREFCNT_inc_NN(POPs);
4284     }
4285     else {
4286         SAVE_DEFSV;
4287         DEFSV_set(POPs);
4288     }
4289
4290     PUSHBLOCK(cx, CXt_GIVEN, SP);
4291     PUSHGIVEN(cx);
4292
4293     RETURN;
4294 }
4295
4296 PP(pp_leavegiven)
4297 {
4298     dVAR; dSP;
4299     PERL_CONTEXT *cx;
4300     I32 gimme;
4301     SV **newsp;
4302     PMOP *newpm;
4303     PERL_UNUSED_CONTEXT;
4304
4305     POPBLOCK(cx,newpm);
4306     assert(CxTYPE(cx) == CXt_GIVEN);
4307
4308     TAINT_NOT;
4309     SP = adjust_stack_on_leave(newsp, SP, newsp, gimme, SVs_PADTMP|SVs_TEMP);
4310     PL_curpm = newpm;   /* Don't pop $1 et al till now */
4311
4312     LEAVE_with_name("given");
4313     RETURN;
4314 }
4315
4316 /* Helper routines used by pp_smartmatch */
4317 STATIC PMOP *
4318 S_make_matcher(pTHX_ REGEXP *re)
4319 {
4320     dVAR;
4321     PMOP *matcher = (PMOP *) newPMOP(OP_MATCH, OPf_WANT_SCALAR | OPf_STACKED);
4322
4323     PERL_ARGS_ASSERT_MAKE_MATCHER;
4324
4325     PM_SETRE(matcher, ReREFCNT_inc(re));
4326
4327     SAVEFREEOP((OP *) matcher);
4328     ENTER_with_name("matcher"); SAVETMPS;
4329     SAVEOP();
4330     return matcher;
4331 }
4332
4333 STATIC bool
4334 S_matcher_matches_sv(pTHX_ PMOP *matcher, SV *sv)
4335 {
4336     dVAR;
4337     dSP;
4338
4339     PERL_ARGS_ASSERT_MATCHER_MATCHES_SV;
4340
4341     PL_op = (OP *) matcher;
4342     XPUSHs(sv);
4343     PUTBACK;
4344     (void) Perl_pp_match(aTHX);
4345     SPAGAIN;
4346     return (SvTRUEx(POPs));
4347 }
4348
4349 STATIC void
4350 S_destroy_matcher(pTHX_ PMOP *matcher)
4351 {
4352     dVAR;
4353
4354     PERL_ARGS_ASSERT_DESTROY_MATCHER;
4355     PERL_UNUSED_ARG(matcher);
4356
4357     FREETMPS;
4358     LEAVE_with_name("matcher");
4359 }
4360
4361 /* Do a smart match */
4362 PP(pp_smartmatch)
4363 {
4364     DEBUG_M(Perl_deb(aTHX_ "Starting smart match resolution\n"));
4365     return do_smartmatch(NULL, NULL, 0);
4366 }
4367
4368 /* This version of do_smartmatch() implements the
4369  * table of smart matches that is found in perlsyn.
4370  */
4371 STATIC OP *
4372 S_do_smartmatch(pTHX_ HV *seen_this, HV *seen_other, const bool copied)
4373 {
4374     dVAR;
4375     dSP;
4376
4377     bool object_on_left = FALSE;
4378     SV *e = TOPs;       /* e is for 'expression' */
4379     SV *d = TOPm1s;     /* d is for 'default', as in PL_defgv */
4380
4381     /* Take care only to invoke mg_get() once for each argument.
4382      * Currently we do this by copying the SV if it's magical. */
4383     if (d) {
4384         if (!copied && SvGMAGICAL(d))
4385             d = sv_mortalcopy(d);
4386     }
4387     else
4388         d = &PL_sv_undef;
4389
4390     assert(e);
4391     if (SvGMAGICAL(e))
4392         e = sv_mortalcopy(e);
4393
4394     /* First of all, handle overload magic of the rightmost argument */
4395     if (SvAMAGIC(e)) {
4396         SV * tmpsv;
4397         DEBUG_M(Perl_deb(aTHX_ "    applying rule Any-Object\n"));
4398         DEBUG_M(Perl_deb(aTHX_ "        attempting overload\n"));
4399
4400         tmpsv = amagic_call(d, e, smart_amg, AMGf_noleft);
4401         if (tmpsv) {
4402             SPAGAIN;
4403             (void)POPs;
4404             SETs(tmpsv);
4405             RETURN;
4406         }
4407         DEBUG_M(Perl_deb(aTHX_ "        failed to run overload method; continuing...\n"));
4408     }
4409
4410     SP -= 2;    /* Pop the values */
4411
4412
4413     /* ~~ undef */
4414     if (!SvOK(e)) {
4415         DEBUG_M(Perl_deb(aTHX_ "    applying rule Any-undef\n"));
4416         if (SvOK(d))
4417             RETPUSHNO;
4418         else
4419             RETPUSHYES;
4420     }
4421
4422     if (sv_isobject(e) && (SvTYPE(SvRV(e)) != SVt_REGEXP)) {
4423         DEBUG_M(Perl_deb(aTHX_ "    applying rule Any-Object\n"));
4424         Perl_croak(aTHX_ "Smart matching a non-overloaded object breaks encapsulation");
4425     }
4426     if (sv_isobject(d) && (SvTYPE(SvRV(d)) != SVt_REGEXP))
4427         object_on_left = TRUE;
4428
4429     /* ~~ sub */
4430     if (SvROK(e) && SvTYPE(SvRV(e)) == SVt_PVCV) {
4431         I32 c;
4432         if (object_on_left) {
4433             goto sm_any_sub; /* Treat objects like scalars */
4434         }
4435         else if (SvROK(d) && SvTYPE(SvRV(d)) == SVt_PVHV) {
4436             /* Test sub truth for each key */
4437             HE *he;
4438             bool andedresults = TRUE;
4439             HV *hv = (HV*) SvRV(d);
4440             I32 numkeys = hv_iterinit(hv);
4441             DEBUG_M(Perl_deb(aTHX_ "    applying rule Hash-CodeRef\n"));
4442             if (numkeys == 0)
4443                 RETPUSHYES;
4444             while ( (he = hv_iternext(hv)) ) {
4445                 DEBUG_M(Perl_deb(aTHX_ "        testing hash key...\n"));
4446                 ENTER_with_name("smartmatch_hash_key_test");
4447                 SAVETMPS;
4448                 PUSHMARK(SP);
4449                 PUSHs(hv_iterkeysv(he));
4450                 PUTBACK;
4451                 c = call_sv(e, G_SCALAR);
4452                 SPAGAIN;
4453                 if (c == 0)
4454                     andedresults = FALSE;
4455                 else
4456                     andedresults = SvTRUEx(POPs) && andedresults;
4457                 FREETMPS;
4458                 LEAVE_with_name("smartmatch_hash_key_test");
4459             }
4460             if (andedresults)
4461                 RETPUSHYES;
4462             else
4463                 RETPUSHNO;
4464         }
4465         else if (SvROK(d) && SvTYPE(SvRV(d)) == SVt_PVAV) {
4466             /* Test sub truth for each element */
4467             I32 i;
4468             bool andedresults = TRUE;
4469             AV *av = (AV*) SvRV(d);
4470             const I32 len = av_len(av);
4471             DEBUG_M(Perl_deb(aTHX_ "    applying rule Array-CodeRef\n"));
4472             if (len == -1)
4473                 RETPUSHYES;
4474             for (i = 0; i <= len; ++i) {
4475                 SV * const * const svp = av_fetch(av, i, FALSE);
4476                 DEBUG_M(Perl_deb(aTHX_ "        testing array element...\n"));
4477                 ENTER_with_name("smartmatch_array_elem_test");
4478                 SAVETMPS;
4479                 PUSHMARK(SP);
4480                 if (svp)
4481                     PUSHs(*svp);
4482                 PUTBACK;
4483                 c = call_sv(e, G_SCALAR);
4484                 SPAGAIN;
4485                 if (c == 0)
4486                     andedresults = FALSE;
4487                 else
4488                     andedresults = SvTRUEx(POPs) && andedresults;
4489                 FREETMPS;
4490                 LEAVE_with_name("smartmatch_array_elem_test");
4491             }
4492             if (andedresults)
4493                 RETPUSHYES;
4494             else
4495                 RETPUSHNO;
4496         }
4497         else {
4498           sm_any_sub:
4499             DEBUG_M(Perl_deb(aTHX_ "    applying rule Any-CodeRef\n"));
4500             ENTER_with_name("smartmatch_coderef");
4501             SAVETMPS;
4502             PUSHMARK(SP);
4503             PUSHs(d);
4504             PUTBACK;
4505             c = call_sv(e, G_SCALAR);
4506             SPAGAIN;
4507             if (c == 0)
4508                 PUSHs(&PL_sv_no);
4509             else if (SvTEMP(TOPs))
4510                 SvREFCNT_inc_void(TOPs);
4511             FREETMPS;
4512             LEAVE_with_name("smartmatch_coderef");
4513             RETURN;
4514         }
4515     }
4516     /* ~~ %hash */
4517     else if (SvROK(e) && SvTYPE(SvRV(e)) == SVt_PVHV) {
4518         if (object_on_left) {
4519             goto sm_any_hash; /* Treat objects like scalars */
4520         }
4521         else if (!SvOK(d)) {
4522             DEBUG_M(Perl_deb(aTHX_ "    applying rule Any-Hash ($a undef)\n"));
4523             RETPUSHNO;
4524         }
4525         else if (SvROK(d) && SvTYPE(SvRV(d)) == SVt_PVHV) {
4526             /* Check that the key-sets are identical */
4527             HE *he;
4528             HV *other_hv = MUTABLE_HV(SvRV(d));
4529             bool tied = FALSE;
4530             bool other_tied = FALSE;
4531             U32 this_key_count  = 0,
4532                 other_key_count = 0;
4533             HV *hv = MUTABLE_HV(SvRV(e));
4534
4535             DEBUG_M(Perl_deb(aTHX_ "    applying rule Hash-Hash\n"));
4536             /* Tied hashes don't know how many keys they have. */
4537             if (SvTIED_mg((SV*)hv, PERL_MAGIC_tied)) {
4538                 tied = TRUE;
4539             }
4540             else if (SvTIED_mg((const SV *)other_hv, PERL_MAGIC_tied)) {
4541                 HV * const temp = other_hv;
4542                 other_hv = hv;
4543                 hv = temp;
4544                 tied = TRUE;
4545             }
4546             if (SvTIED_mg((const SV *)other_hv, PERL_MAGIC_tied))
4547                 other_tied = TRUE;
4548
4549             if (!tied && HvUSEDKEYS((const HV *) hv) != HvUSEDKEYS(other_hv))
4550                 RETPUSHNO;
4551
4552             /* The hashes have the same number of keys, so it suffices
4553                to check that one is a subset of the other. */
4554             (void) hv_iterinit(hv);
4555             while ( (he = hv_iternext(hv)) ) {
4556                 SV *key = hv_iterkeysv(he);
4557
4558                 DEBUG_M(Perl_deb(aTHX_ "        comparing hash key...\n"));
4559                 ++ this_key_count;
4560
4561                 if(!hv_exists_ent(other_hv, key, 0)) {
4562                     (void) hv_iterinit(hv);     /* reset iterator */
4563                     RETPUSHNO;
4564                 }
4565             }
4566
4567             if (other_tied) {
4568                 (void) hv_iterinit(other_hv);
4569                 while ( hv_iternext(other_hv) )
4570                     ++other_key_count;
4571             }
4572             else
4573                 other_key_count = HvUSEDKEYS(other_hv);
4574
4575             if (this_key_count != other_key_count)
4576                 RETPUSHNO;
4577             else
4578                 RETPUSHYES;
4579         }
4580         else if (SvROK(d) && SvTYPE(SvRV(d)) == SVt_PVAV) {
4581             AV * const other_av = MUTABLE_AV(SvRV(d));
4582             const I32 other_len = av_len(other_av) + 1;
4583             I32 i;
4584             HV *hv = MUTABLE_HV(SvRV(e));
4585
4586             DEBUG_M(Perl_deb(aTHX_ "    applying rule Array-Hash\n"));
4587             for (i = 0; i < other_len; ++i) {
4588                 SV ** const svp = av_fetch(other_av, i, FALSE);
4589                 DEBUG_M(Perl_deb(aTHX_ "        checking for key existence...\n"));
4590                 if (svp) {      /* ??? When can this not happen? */
4591                     if (hv_exists_ent(hv, *svp, 0))
4592                         RETPUSHYES;
4593                 }
4594             }
4595             RETPUSHNO;
4596         }
4597         else if (SvROK(d) && SvTYPE(SvRV(d)) == SVt_REGEXP) {
4598             DEBUG_M(Perl_deb(aTHX_ "    applying rule Regex-Hash\n"));
4599           sm_regex_hash:
4600             {
4601                 PMOP * const matcher = make_matcher((REGEXP*) SvRV(d));
4602                 HE *he;
4603                 HV *hv = MUTABLE_HV(SvRV(e));
4604
4605                 (void) hv_iterinit(hv);
4606                 while ( (he = hv_iternext(hv)) ) {
4607                     DEBUG_M(Perl_deb(aTHX_ "        testing key against pattern...\n"));
4608                     if (matcher_matches_sv(matcher, hv_iterkeysv(he))) {
4609                         (void) hv_iterinit(hv);
4610                         destroy_matcher(matcher);
4611                         RETPUSHYES;
4612                     }
4613                 }
4614                 destroy_matcher(matcher);
4615                 RETPUSHNO;
4616             }
4617         }
4618         else {
4619           sm_any_hash:
4620             DEBUG_M(Perl_deb(aTHX_ "    applying rule Any-Hash\n"));
4621             if (hv_exists_ent(MUTABLE_HV(SvRV(e)), d, 0))
4622                 RETPUSHYES;
4623             else
4624                 RETPUSHNO;
4625         }
4626     }
4627     /* ~~ @array */
4628     else if (SvROK(e) && SvTYPE(SvRV(e)) == SVt_PVAV) {
4629         if (object_on_left) {
4630             goto sm_any_array; /* Treat objects like scalars */
4631         }
4632         else if (SvROK(d) && SvTYPE(SvRV(d)) == SVt_PVHV) {
4633             AV * const other_av = MUTABLE_AV(SvRV(e));
4634             const I32 other_len = av_len(other_av) + 1;
4635             I32 i;
4636
4637             DEBUG_M(Perl_deb(aTHX_ "    applying rule Hash-Array\n"));
4638             for (i = 0; i < other_len; ++i) {
4639                 SV ** const svp = av_fetch(other_av, i, FALSE);
4640
4641                 DEBUG_M(Perl_deb(aTHX_ "        testing for key existence...\n"));
4642                 if (svp) {      /* ??? When can this not happen? */
4643                     if (hv_exists_ent(MUTABLE_HV(SvRV(d)), *svp, 0))
4644                         RETPUSHYES;
4645                 }
4646             }
4647             RETPUSHNO;
4648         }
4649         if (SvROK(d) && SvTYPE(SvRV(d)) == SVt_PVAV) {
4650             AV *other_av = MUTABLE_AV(SvRV(d));
4651             DEBUG_M(Perl_deb(aTHX_ "    applying rule Array-Array\n"));
4652             if (av_len(MUTABLE_AV(SvRV(e))) != av_len(other_av))
4653                 RETPUSHNO;
4654             else {
4655                 I32 i;
4656                 const I32 other_len = av_len(other_av);
4657
4658                 if (NULL == seen_this) {
4659                     seen_this = newHV();
4660                     (void) sv_2mortal(MUTABLE_SV(seen_this));
4661                 }
4662                 if (NULL == seen_other) {
4663                     seen_other = newHV();
4664                     (void) sv_2mortal(MUTABLE_SV(seen_other));
4665                 }
4666                 for(i = 0; i <= other_len; ++i) {
4667                     SV * const * const this_elem = av_fetch(MUTABLE_AV(SvRV(e)), i, FALSE);
4668                     SV * const * const other_elem = av_fetch(other_av, i, FALSE);
4669
4670                     if (!this_elem || !other_elem) {
4671                         if ((this_elem && SvOK(*this_elem))
4672                                 || (other_elem && SvOK(*other_elem)))
4673                             RETPUSHNO;
4674                     }
4675                     else if (hv_exists_ent(seen_this,
4676                                 sv_2mortal(newSViv(PTR2IV(*this_elem))), 0) ||
4677                             hv_exists_ent(seen_other,
4678                                 sv_2mortal(newSViv(PTR2IV(*other_elem))), 0))
4679                     {
4680                         if (*this_elem != *other_elem)
4681                             RETPUSHNO;
4682                     }
4683                     else {
4684                         (void)hv_store_ent(seen_this,
4685                                 sv_2mortal(newSViv(PTR2IV(*this_elem))),
4686                                 &PL_sv_undef, 0);
4687                         (void)hv_store_ent(seen_other,
4688                                 sv_2mortal(newSViv(PTR2IV(*other_elem))),
4689                                 &PL_sv_undef, 0);
4690                         PUSHs(*other_elem);
4691                         PUSHs(*this_elem);
4692
4693                         PUTBACK;
4694                         DEBUG_M(Perl_deb(aTHX_ "        recursively comparing array element...\n"));
4695                         (void) do_smartmatch(seen_this, seen_other, 0);
4696                         SPAGAIN;
4697                         DEBUG_M(Perl_deb(aTHX_ "        recursion finished\n"));
4698
4699                         if (!SvTRUEx(POPs))
4700                             RETPUSHNO;
4701                     }
4702                 }
4703                 RETPUSHYES;
4704             }
4705         }
4706         else if (SvROK(d) && SvTYPE(SvRV(d)) == SVt_REGEXP) {
4707             DEBUG_M(Perl_deb(aTHX_ "    applying rule Regex-Array\n"));
4708           sm_regex_array:
4709             {
4710                 PMOP * const matcher = make_matcher((REGEXP*) SvRV(d));
4711                 const I32 this_len = av_len(MUTABLE_AV(SvRV(e)));
4712                 I32 i;
4713
4714                 for(i = 0; i <= this_len; ++i) {
4715                     SV * const * const svp = av_fetch(MUTABLE_AV(SvRV(e)), i, FALSE);
4716                     DEBUG_M(Perl_deb(aTHX_ "        testing element against pattern...\n"));
4717                     if (svp && matcher_matches_sv(matcher, *svp)) {
4718                         destroy_matcher(matcher);
4719                         RETPUSHYES;
4720                     }
4721                 }
4722                 destroy_matcher(matcher);
4723                 RETPUSHNO;
4724             }
4725         }
4726         else if (!SvOK(d)) {
4727             /* undef ~~ array */
4728             const I32 this_len = av_len(MUTABLE_AV(SvRV(e)));
4729             I32 i;
4730
4731             DEBUG_M(Perl_deb(aTHX_ "    applying rule Undef-Array\n"));
4732             for (i = 0; i <= this_len; ++i) {
4733                 SV * const * const svp = av_fetch(MUTABLE_AV(SvRV(e)), i, FALSE);
4734                 DEBUG_M(Perl_deb(aTHX_ "        testing for undef element...\n"));
4735                 if (!svp || !SvOK(*svp))
4736                     RETPUSHYES;
4737             }
4738             RETPUSHNO;
4739         }
4740         else {
4741           sm_any_array:
4742             {
4743                 I32 i;
4744                 const I32 this_len = av_len(MUTABLE_AV(SvRV(e)));
4745
4746                 DEBUG_M(Perl_deb(aTHX_ "    applying rule Any-Array\n"));
4747                 for (i = 0; i <= this_len; ++i) {
4748                     SV * const * const svp = av_fetch(MUTABLE_AV(SvRV(e)), i, FALSE);
4749                     if (!svp)
4750                         continue;
4751
4752                     PUSHs(d);
4753                     PUSHs(*svp);
4754                     PUTBACK;
4755                     /* infinite recursion isn't supposed to happen here */
4756                     DEBUG_M(Perl_deb(aTHX_ "        recursively testing array element...\n"));
4757                     (void) do_smartmatch(NULL, NULL, 1);
4758                     SPAGAIN;
4759                     DEBUG_M(Perl_deb(aTHX_ "        recursion finished\n"));
4760                     if (SvTRUEx(POPs))
4761                         RETPUSHYES;
4762                 }
4763                 RETPUSHNO;
4764             }
4765         }
4766     }
4767     /* ~~ qr// */
4768     else if (SvROK(e) && SvTYPE(SvRV(e)) == SVt_REGEXP) {
4769         if (!object_on_left && SvROK(d) && SvTYPE(SvRV(d)) == SVt_PVHV) {
4770             SV *t = d; d = e; e = t;
4771             DEBUG_M(Perl_deb(aTHX_ "    applying rule Hash-Regex\n"));
4772             goto sm_regex_hash;
4773         }
4774         else if (!object_on_left && SvROK(d) && SvTYPE(SvRV(d)) == SVt_PVAV) {
4775             SV *t = d; d = e; e = t;
4776             DEBUG_M(Perl_deb(aTHX_ "    applying rule Array-Regex\n"));
4777             goto sm_regex_array;
4778         }
4779         else {
4780             PMOP * const matcher = make_matcher((REGEXP*) SvRV(e));
4781
4782             DEBUG_M(Perl_deb(aTHX_ "    applying rule Any-Regex\n"));
4783             PUTBACK;
4784             PUSHs(matcher_matches_sv(matcher, d)
4785                     ? &PL_sv_yes
4786                     : &PL_sv_no);
4787             destroy_matcher(matcher);
4788             RETURN;
4789         }
4790     }
4791     /* ~~ scalar */
4792     /* See if there is overload magic on left */
4793     else if (object_on_left && SvAMAGIC(d)) {
4794         SV *tmpsv;
4795         DEBUG_M(Perl_deb(aTHX_ "    applying rule Object-Any\n"));
4796         DEBUG_M(Perl_deb(aTHX_ "        attempting overload\n"));
4797         PUSHs(d); PUSHs(e);
4798         PUTBACK;
4799         tmpsv = amagic_call(d, e, smart_amg, AMGf_noright);
4800         if (tmpsv) {
4801             SPAGAIN;
4802             (void)POPs;
4803             SETs(tmpsv);
4804             RETURN;
4805         }
4806         SP -= 2;
4807         DEBUG_M(Perl_deb(aTHX_ "        failed to run overload method; falling back...\n"));
4808         goto sm_any_scalar;
4809     }
4810     else if (!SvOK(d)) {
4811         /* undef ~~ scalar ; we already know that the scalar is SvOK */
4812         DEBUG_M(Perl_deb(aTHX_ "    applying rule undef-Any\n"));
4813         RETPUSHNO;
4814     }
4815     else
4816   sm_any_scalar:
4817     if (SvNIOK(e) || (SvPOK(e) && looks_like_number(e) && SvNIOK(d))) {
4818         DEBUG_M(if (SvNIOK(e))
4819                     Perl_deb(aTHX_ "    applying rule Any-Num\n");
4820                 else
4821                     Perl_deb(aTHX_ "    applying rule Num-numish\n");
4822         );
4823         /* numeric comparison */
4824         PUSHs(d); PUSHs(e);
4825         PUTBACK;
4826         if (CopHINTS_get(PL_curcop) & HINT_INTEGER)
4827             (void) Perl_pp_i_eq(aTHX);
4828         else
4829             (void) Perl_pp_eq(aTHX);
4830         SPAGAIN;
4831         if (SvTRUEx(POPs))
4832             RETPUSHYES;
4833         else
4834             RETPUSHNO;
4835     }
4836
4837     /* As a last resort, use string comparison */
4838     DEBUG_M(Perl_deb(aTHX_ "    applying rule Any-Any\n"));
4839     PUSHs(d); PUSHs(e);
4840     PUTBACK;
4841     return Perl_pp_seq(aTHX);
4842 }
4843
4844 PP(pp_enterwhen)
4845 {
4846     dVAR; dSP;
4847     PERL_CONTEXT *cx;
4848     const I32 gimme = GIMME_V;
4849
4850     /* This is essentially an optimization: if the match
4851        fails, we don't want to push a context and then
4852        pop it again right away, so we skip straight
4853        to the op that follows the leavewhen.
4854        RETURNOP calls PUTBACK which restores the stack pointer after the POPs.
4855     */
4856     if ((0 == (PL_op->op_flags & OPf_SPECIAL)) && !SvTRUEx(POPs))
4857         RETURNOP(cLOGOP->op_other->op_next);
4858
4859     ENTER_with_name("when");
4860     SAVETMPS;
4861
4862     PUSHBLOCK(cx, CXt_WHEN, SP);
4863     PUSHWHEN(cx);
4864
4865     RETURN;
4866 }
4867
4868 PP(pp_leavewhen)
4869 {
4870     dVAR; dSP;
4871     I32 cxix;
4872     PERL_CONTEXT *cx;
4873     I32 gimme;
4874     SV **newsp;
4875     PMOP *newpm;
4876
4877     cxix = dopoptogiven(cxstack_ix);
4878     if (cxix < 0)
4879         /* diag_listed_as: Can't "when" outside a topicalizer */
4880         DIE(aTHX_ "Can't \"%s\" outside a topicalizer",
4881                    PL_op->op_flags & OPf_SPECIAL ? "default" : "when");
4882
4883     POPBLOCK(cx,newpm);
4884     assert(CxTYPE(cx) == CXt_WHEN);
4885
4886     TAINT_NOT;
4887     SP = adjust_stack_on_leave(newsp, SP, newsp, gimme, SVs_PADTMP|SVs_TEMP);
4888     PL_curpm = newpm;   /* pop $1 et al */
4889
4890     LEAVE_with_name("when");
4891
4892     if (cxix < cxstack_ix)
4893         dounwind(cxix);
4894
4895     cx = &cxstack[cxix];
4896
4897     if (CxFOREACH(cx)) {
4898         /* clear off anything above the scope we're re-entering */
4899         I32 inner = PL_scopestack_ix;
4900
4901         TOPBLOCK(cx);
4902         if (PL_scopestack_ix < inner)
4903             leave_scope(PL_scopestack[PL_scopestack_ix]);
4904         PL_curcop = cx->blk_oldcop;
4905
4906         return cx->blk_loop.my_op->op_nextop;
4907     }
4908     else
4909         RETURNOP(cx->blk_givwhen.leave_op);
4910 }
4911
4912 PP(pp_continue)
4913 {
4914     dVAR; dSP;
4915     I32 cxix;
4916     PERL_CONTEXT *cx;
4917     I32 gimme;
4918     SV **newsp;
4919     PMOP *newpm;
4920
4921     PERL_UNUSED_VAR(gimme);
4922
4923     cxix = dopoptowhen(cxstack_ix);
4924     if (cxix < 0)
4925         DIE(aTHX_ "Can't \"continue\" outside a when block");
4926
4927     if (cxix < cxstack_ix)
4928         dounwind(cxix);
4929
4930     POPBLOCK(cx,newpm);
4931     assert(CxTYPE(cx) == CXt_WHEN);
4932
4933     SP = newsp;
4934     PL_curpm = newpm;   /* pop $1 et al */
4935
4936     LEAVE_with_name("when");
4937     RETURNOP(cx->blk_givwhen.leave_op->op_next);
4938 }
4939
4940 PP(pp_break)
4941 {
4942     dVAR;
4943     I32 cxix;
4944     PERL_CONTEXT *cx;
4945
4946     cxix = dopoptogiven(cxstack_ix);
4947     if (cxix < 0)
4948         DIE(aTHX_ "Can't \"break\" outside a given block");
4949
4950     cx = &cxstack[cxix];
4951     if (CxFOREACH(cx))
4952         DIE(aTHX_ "Can't \"break\" in a loop topicalizer");
4953
4954     if (cxix < cxstack_ix)
4955         dounwind(cxix);
4956
4957     /* Restore the sp at the time we entered the given block */
4958     TOPBLOCK(cx);
4959
4960     return cx->blk_givwhen.leave_op;
4961 }
4962
4963 static MAGIC *
4964 S_doparseform(pTHX_ SV *sv)
4965 {
4966     STRLEN len;
4967     char *s = SvPV(sv, len);
4968     char *send;
4969     char *base = NULL; /* start of current field */
4970     I32 skipspaces = 0; /* number of contiguous spaces seen */
4971     bool noblank   = FALSE; /* ~ or ~~ seen on this line */
4972     bool repeat    = FALSE; /* ~~ seen on this line */
4973     bool postspace = FALSE; /* a text field may need right padding */
4974     U32 *fops;
4975     U32 *fpc;
4976     U32 *linepc = NULL;     /* position of last FF_LINEMARK */
4977     I32 arg;
4978     bool ischop;            /* it's a ^ rather than a @ */
4979     bool unchopnum = FALSE; /* at least one @ (i.e. non-chop) num field seen */
4980     int maxops = 12; /* FF_LINEMARK + FF_END + 10 (\0 without preceding \n) */
4981     MAGIC *mg = NULL;
4982     SV *sv_copy;
4983
4984     PERL_ARGS_ASSERT_DOPARSEFORM;
4985
4986     if (len == 0)
4987         Perl_croak(aTHX_ "Null picture in formline");
4988
4989     if (SvTYPE(sv) >= SVt_PVMG) {
4990         /* This might, of course, still return NULL.  */
4991         mg = mg_find(sv, PERL_MAGIC_fm);
4992     } else {
4993         sv_upgrade(sv, SVt_PVMG);
4994     }
4995
4996     if (mg) {
4997         /* still the same as previously-compiled string? */
4998         SV *old = mg->mg_obj;
4999         if ( !(!!SvUTF8(old) ^ !!SvUTF8(sv))
5000               && len == SvCUR(old)
5001               && strnEQ(SvPVX(old), SvPVX(sv), len)
5002         ) {
5003             DEBUG_f(PerlIO_printf(Perl_debug_log,"Re-using compiled format\n"));
5004             return mg;
5005         }
5006
5007         DEBUG_f(PerlIO_printf(Perl_debug_log, "Re-compiling format\n"));
5008         Safefree(mg->mg_ptr);
5009         mg->mg_ptr = NULL;
5010         SvREFCNT_dec(old);
5011         mg->mg_obj = NULL;
5012     }
5013     else {
5014         DEBUG_f(PerlIO_printf(Perl_debug_log, "Compiling format\n"));
5015         mg = sv_magicext(sv, NULL, PERL_MAGIC_fm, &PL_vtbl_fm, NULL, 0);
5016     }
5017
5018     sv_copy = newSVpvn_utf8(s, len, SvUTF8(sv));
5019     s = SvPV(sv_copy, len); /* work on the copy, not the original */
5020     send = s + len;
5021
5022
5023     /* estimate the buffer size needed */
5024     for (base = s; s <= send; s++) {
5025         if (*s == '\n' || *s == '@' || *s == '^')
5026             maxops += 10;
5027     }
5028     s = base;
5029     base = NULL;
5030
5031     Newx(fops, maxops, U32);
5032     fpc = fops;
5033
5034     if (s < send) {
5035         linepc = fpc;
5036         *fpc++ = FF_LINEMARK;
5037         noblank = repeat = FALSE;
5038         base = s;
5039     }
5040
5041     while (s <= send) {
5042         switch (*s++) {
5043         default:
5044             skipspaces = 0;
5045             continue;
5046
5047         case '~':
5048             if (*s == '~') {
5049                 repeat = TRUE;
5050                 skipspaces++;
5051                 s++;
5052             }
5053             noblank = TRUE;
5054             /* FALL THROUGH */
5055         case ' ': case '\t':
5056             skipspaces++;
5057             continue;
5058         case 0:
5059             if (s < send) {
5060                 skipspaces = 0;
5061                 continue;
5062             } /* else FALL THROUGH */
5063         case '\n':
5064             arg = s - base;
5065             skipspaces++;
5066             arg -= skipspaces;
5067             if (arg) {
5068                 if (postspace)
5069                     *fpc++ = FF_SPACE;
5070                 *fpc++ = FF_LITERAL;
5071                 *fpc++ = (U32)arg;
5072             }
5073             postspace = FALSE;
5074             if (s <= send)
5075                 skipspaces--;
5076             if (skipspaces) {
5077                 *fpc++ = FF_SKIP;
5078                 *fpc++ = (U32)skipspaces;
5079             }
5080             skipspaces = 0;
5081             if (s <= send)
5082                 *fpc++ = FF_NEWLINE;
5083             if (noblank) {
5084                 *fpc++ = FF_BLANK;
5085                 if (repeat)
5086                     arg = fpc - linepc + 1;
5087                 else
5088                     arg = 0;
5089                 *fpc++ = (U32)arg;
5090             }
5091             if (s < send) {
5092                 linepc = fpc;
5093                 *fpc++ = FF_LINEMARK;
5094                 noblank = repeat = FALSE;
5095                 base = s;
5096             }
5097             else
5098                 s++;
5099             continue;
5100
5101         case '@':
5102         case '^':
5103             ischop = s[-1] == '^';
5104
5105             if (postspace) {
5106                 *fpc++ = FF_SPACE;
5107                 postspace = FALSE;
5108             }
5109             arg = (s - base) - 1;
5110             if (arg) {
5111                 *fpc++ = FF_LITERAL;
5112                 *fpc++ = (U32)arg;
5113             }
5114
5115             base = s - 1;
5116             *fpc++ = FF_FETCH;
5117             if (*s == '*') { /*  @* or ^*  */
5118                 s++;
5119                 *fpc++ = 2;  /* skip the @* or ^* */
5120                 if (ischop) {
5121                     *fpc++ = FF_LINESNGL;
5122                     *fpc++ = FF_CHOP;
5123                 } else
5124                     *fpc++ = FF_LINEGLOB;
5125             }
5126             else if (*s == '#' || (*s == '.' && s[1] == '#')) { /* @###, ^### */
5127                 arg = ischop ? FORM_NUM_BLANK : 0;
5128                 base = s - 1;
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_DECIMAL;
5139                 *fpc++ = (U32)arg;
5140                 unchopnum |= ! ischop;
5141             }
5142             else if (*s == '0' && s[1] == '#') {  /* Zero padded decimals */
5143                 arg = ischop ? FORM_NUM_BLANK : 0;
5144                 base = s - 1;
5145                 s++;                                /* skip the '0' first */
5146                 while (*s == '#')
5147                     s++;
5148                 if (*s == '.') {
5149                     const char * const f = ++s;
5150                     while (*s == '#')
5151                         s++;
5152                     arg |= FORM_NUM_POINT + (s - f);
5153                 }
5154                 *fpc++ = s - base;                /* fieldsize for FETCH */
5155                 *fpc++ = FF_0DECIMAL;
5156                 *fpc++ = (U32)arg;
5157                 unchopnum |= ! ischop;
5158             }
5159             else {                              /* text field */
5160                 I32 prespace = 0;
5161                 bool ismore = FALSE;
5162
5163                 if (*s == '>') {
5164                     while (*++s == '>') ;
5165                     prespace = FF_SPACE;
5166                 }
5167                 else if (*s == '|') {
5168                     while (*++s == '|') ;
5169                     prespace = FF_HALFSPACE;
5170                     postspace = TRUE;
5171                 }
5172                 else {
5173                     if (*s == '<')
5174                         while (*++s == '<') ;
5175                     postspace = TRUE;
5176                 }
5177                 if (*s == '.' && s[1] == '.' && s[2] == '.') {
5178                     s += 3;
5179                     ismore = TRUE;
5180                 }
5181                 *fpc++ = s - base;              /* fieldsize for FETCH */
5182
5183                 *fpc++ = ischop ? FF_CHECKCHOP : FF_CHECKNL;
5184
5185                 if (prespace)
5186                     *fpc++ = (U32)prespace; /* add SPACE or HALFSPACE */
5187                 *fpc++ = FF_ITEM;
5188                 if (ismore)
5189                     *fpc++ = FF_MORE;
5190                 if (ischop)
5191                     *fpc++ = FF_CHOP;
5192             }
5193             base = s;
5194             skipspaces = 0;
5195             continue;
5196         }
5197     }
5198     *fpc++ = FF_END;
5199
5200     assert (fpc <= fops + maxops); /* ensure our buffer estimate was valid */
5201     arg = fpc - fops;
5202
5203     mg->mg_ptr = (char *) fops;
5204     mg->mg_len = arg * sizeof(U32);
5205     mg->mg_obj = sv_copy;
5206     mg->mg_flags |= MGf_REFCOUNTED;
5207
5208     if (unchopnum && repeat)
5209         Perl_die(aTHX_ "Repeated format line will never terminate (~~ and @#)");
5210
5211     return mg;
5212 }
5213
5214
5215 STATIC bool
5216 S_num_overflow(NV value, I32 fldsize, I32 frcsize)
5217 {
5218     /* Can value be printed in fldsize chars, using %*.*f ? */
5219     NV pwr = 1;
5220     NV eps = 0.5;
5221     bool res = FALSE;
5222     int intsize = fldsize - (value < 0 ? 1 : 0);
5223
5224     if (frcsize & FORM_NUM_POINT)
5225         intsize--;
5226     frcsize &= ~(FORM_NUM_POINT|FORM_NUM_BLANK);
5227     intsize -= frcsize;
5228
5229     while (intsize--) pwr *= 10.0;
5230     while (frcsize--) eps /= 10.0;
5231
5232     if( value >= 0 ){
5233         if (value + eps >= pwr)
5234             res = TRUE;
5235     } else {
5236         if (value - eps <= -pwr)
5237             res = TRUE;
5238     }
5239     return res;
5240 }
5241
5242 static I32
5243 S_run_user_filter(pTHX_ int idx, SV *buf_sv, int maxlen)
5244 {
5245     dVAR;
5246     SV * const datasv = FILTER_DATA(idx);
5247     const int filter_has_file = IoLINES(datasv);
5248     SV * const filter_state = MUTABLE_SV(IoTOP_GV(datasv));
5249     SV * const filter_sub = MUTABLE_SV(IoBOTTOM_GV(datasv));
5250     int status = 0;
5251     SV *upstream;
5252     STRLEN got_len;
5253     char *got_p = NULL;
5254     char *prune_from = NULL;
5255     bool read_from_cache = FALSE;
5256     STRLEN umaxlen;
5257     SV *err = NULL;
5258
5259     PERL_ARGS_ASSERT_RUN_USER_FILTER;
5260
5261     assert(maxlen >= 0);
5262     umaxlen = maxlen;
5263
5264     /* I was having segfault trouble under Linux 2.2.5 after a
5265        parse error occured.  (Had to hack around it with a test
5266        for PL_parser->error_count == 0.)  Solaris doesn't segfault --
5267        not sure where the trouble is yet.  XXX */
5268
5269     {
5270         SV *const cache = datasv;
5271         if (SvOK(cache)) {
5272             STRLEN cache_len;
5273             const char *cache_p = SvPV(cache, cache_len);
5274             STRLEN take = 0;
5275
5276             if (umaxlen) {
5277                 /* Running in block mode and we have some cached data already.
5278                  */
5279                 if (cache_len >= umaxlen) {
5280                     /* In fact, so much data we don't even need to call
5281                        filter_read.  */
5282                     take = umaxlen;
5283                 }
5284             } else {
5285                 const char *const first_nl =
5286                     (const char *)memchr(cache_p, '\n', cache_len);
5287                 if (first_nl) {
5288                     take = first_nl + 1 - cache_p;
5289                 }
5290             }
5291             if (take) {
5292                 sv_catpvn(buf_sv, cache_p, take);
5293                 sv_chop(cache, cache_p + take);
5294                 /* Definitely not EOF  */
5295                 return 1;
5296             }
5297
5298             sv_catsv(buf_sv, cache);
5299             if (umaxlen) {
5300                 umaxlen -= cache_len;
5301             }
5302             SvOK_off(cache);
5303             read_from_cache = TRUE;
5304         }
5305     }
5306
5307     /* Filter API says that the filter appends to the contents of the buffer.
5308        Usually the buffer is "", so the details don't matter. But if it's not,
5309        then clearly what it contains is already filtered by this filter, so we
5310        don't want to pass it in a second time.
5311        I'm going to use a mortal in case the upstream filter croaks.  */
5312     upstream = ((SvOK(buf_sv) && sv_len(buf_sv)) || SvGMAGICAL(buf_sv))
5313         ? sv_newmortal() : buf_sv;
5314     SvUPGRADE(upstream, SVt_PV);
5315
5316     if (filter_has_file) {
5317         status = FILTER_READ(idx+1, upstream, 0);
5318     }
5319
5320     if (filter_sub && status >= 0) {
5321         dSP;
5322         int count;
5323
5324         ENTER_with_name("call_filter_sub");
5325         SAVE_DEFSV;
5326         SAVETMPS;
5327         EXTEND(SP, 2);
5328
5329         DEFSV_set(upstream);
5330         PUSHMARK(SP);
5331         mPUSHi(0);
5332         if (filter_state) {
5333             PUSHs(filter_state);
5334         }
5335         PUTBACK;
5336         count = call_sv(filter_sub, G_SCALAR|G_EVAL);
5337         SPAGAIN;
5338
5339         if (count > 0) {
5340             SV *out = POPs;
5341             if (SvOK(out)) {
5342                 status = SvIV(out);
5343             }
5344             else if (SvTRUE(ERRSV)) {
5345                 err = newSVsv(ERRSV);
5346             }
5347         }
5348
5349         PUTBACK;
5350         FREETMPS;
5351         LEAVE_with_name("call_filter_sub");
5352     }
5353
5354     if(!err && SvOK(upstream)) {
5355         got_p = SvPV(upstream, got_len);
5356         if (umaxlen) {
5357             if (got_len > umaxlen) {
5358                 prune_from = got_p + umaxlen;
5359             }
5360         } else {
5361             char *const first_nl = (char *)memchr(got_p, '\n', got_len);
5362             if (first_nl && first_nl + 1 < got_p + got_len) {
5363                 /* There's a second line here... */
5364                 prune_from = first_nl + 1;
5365             }
5366         }
5367     }
5368     if (!err && prune_from) {
5369         /* Oh. Too long. Stuff some in our cache.  */
5370         STRLEN cached_len = got_p + got_len - prune_from;
5371         SV *const cache = datasv;
5372
5373         if (SvOK(cache)) {
5374             /* Cache should be empty.  */
5375             assert(!SvCUR(cache));
5376         }
5377
5378         sv_setpvn(cache, prune_from, cached_len);
5379         /* If you ask for block mode, you may well split UTF-8 characters.
5380            "If it breaks, you get to keep both parts"
5381            (Your code is broken if you  don't put them back together again
5382            before something notices.) */
5383         if (SvUTF8(upstream)) {
5384             SvUTF8_on(cache);
5385         }
5386         SvCUR_set(upstream, got_len - cached_len);
5387         *prune_from = 0;
5388         /* Can't yet be EOF  */
5389         if (status == 0)
5390             status = 1;
5391     }
5392
5393     /* If they are at EOF but buf_sv has something in it, then they may never
5394        have touched the SV upstream, so it may be undefined.  If we naively
5395        concatenate it then we get a warning about use of uninitialised value.
5396     */
5397     if (!err && upstream != buf_sv &&
5398         (SvOK(upstream) || SvGMAGICAL(upstream))) {
5399         sv_catsv(buf_sv, upstream);
5400     }
5401
5402     if (status <= 0) {
5403         IoLINES(datasv) = 0;
5404         if (filter_state) {
5405             SvREFCNT_dec(filter_state);
5406             IoTOP_GV(datasv) = NULL;
5407         }
5408         if (filter_sub) {
5409             SvREFCNT_dec(filter_sub);
5410             IoBOTTOM_GV(datasv) = NULL;
5411         }
5412         filter_del(S_run_user_filter);
5413     }
5414
5415     if (err)
5416         croak_sv(err);
5417
5418     if (status == 0 && read_from_cache) {
5419         /* If we read some data from the cache (and by getting here it implies
5420            that we emptied the cache) then we aren't yet at EOF, and mustn't
5421            report that to our caller.  */
5422         return 1;
5423     }
5424     return status;
5425 }
5426
5427 /* perhaps someone can come up with a better name for
5428    this?  it is not really "absolute", per se ... */
5429 static bool
5430 S_path_is_absolute(const char *name)
5431 {
5432     PERL_ARGS_ASSERT_PATH_IS_ABSOLUTE;
5433
5434     if (PERL_FILE_IS_ABSOLUTE(name)
5435 #ifdef WIN32
5436         || (*name == '.' && ((name[1] == '/' ||
5437                              (name[1] == '.' && name[2] == '/'))
5438                          || (name[1] == '\\' ||
5439                              ( name[1] == '.' && name[2] == '\\')))
5440             )
5441 #else
5442         || (*name == '.' && (name[1] == '/' ||
5443                              (name[1] == '.' && name[2] == '/')))
5444 #endif
5445          )
5446     {
5447         return TRUE;
5448     }
5449     else
5450         return FALSE;
5451 }
5452
5453 /*
5454  * Local variables:
5455  * c-indentation-style: bsd
5456  * c-basic-offset: 4
5457  * indent-tabs-mode: nil
5458  * End:
5459  *
5460  * ex: set ts=8 sts=4 sw=4 et:
5461  */