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