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