pp_ctl.c

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