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