pp_ctl.c

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