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           {
1337             const char *cx_label = CxLABEL(cx);
1338             if (!cx_label || strNE(label, cx_label) ) {
1339                 DEBUG_l(Perl_deb(aTHX_ "(Skipping label #%ld %s)\n",
1340                         (long)i, cx_label));
1341                 continue;
1342             }
1343             DEBUG_l( Perl_deb(aTHX_ "(Found label #%ld %s)\n", (long)i, label));
1344             return i;
1345           }
1346         }
1347     }
1348     return i;
1349 }
1350
1351
1352
1353 I32
1354 Perl_dowantarray(pTHX)
1355 {
1356     dVAR;
1357     const I32 gimme = block_gimme();
1358     return (gimme == G_VOID) ? G_SCALAR : gimme;
1359 }
1360
1361 I32
1362 Perl_block_gimme(pTHX)
1363 {
1364     dVAR;
1365     const I32 cxix = dopoptosub(cxstack_ix);
1366     if (cxix < 0)
1367         return G_VOID;
1368
1369     switch (cxstack[cxix].blk_gimme) {
1370     case G_VOID:
1371         return G_VOID;
1372     case G_SCALAR:
1373         return G_SCALAR;
1374     case G_ARRAY:
1375         return G_ARRAY;
1376     default:
1377         Perl_croak(aTHX_ "panic: bad gimme: %d\n", cxstack[cxix].blk_gimme);
1378         /* NOTREACHED */
1379         return 0;
1380     }
1381 }
1382
1383 I32
1384 Perl_is_lvalue_sub(pTHX)
1385 {
1386     dVAR;
1387     const I32 cxix = dopoptosub(cxstack_ix);
1388     assert(cxix >= 0);  /* We should only be called from inside subs */
1389
1390     if (CxLVAL(cxstack + cxix) && CvLVALUE(cxstack[cxix].blk_sub.cv))
1391         return CxLVAL(cxstack + cxix);
1392     else
1393         return 0;
1394 }
1395
1396 STATIC I32
1397 S_dopoptosub_at(pTHX_ const PERL_CONTEXT *cxstk, I32 startingblock)
1398 {
1399     dVAR;
1400     I32 i;
1401
1402     PERL_ARGS_ASSERT_DOPOPTOSUB_AT;
1403
1404     for (i = startingblock; i >= 0; i--) {
1405         register const PERL_CONTEXT * const cx = &cxstk[i];
1406         switch (CxTYPE(cx)) {
1407         default:
1408             continue;
1409         case CXt_EVAL:
1410         case CXt_SUB:
1411         case CXt_FORMAT:
1412             DEBUG_l( Perl_deb(aTHX_ "(Found sub #%ld)\n", (long)i));
1413             return i;
1414         }
1415     }
1416     return i;
1417 }
1418
1419 STATIC I32
1420 S_dopoptoeval(pTHX_ I32 startingblock)
1421 {
1422     dVAR;
1423     I32 i;
1424     for (i = startingblock; i >= 0; i--) {
1425         register const PERL_CONTEXT *cx = &cxstack[i];
1426         switch (CxTYPE(cx)) {
1427         default:
1428             continue;
1429         case CXt_EVAL:
1430             DEBUG_l( Perl_deb(aTHX_ "(Found eval #%ld)\n", (long)i));
1431             return i;
1432         }
1433     }
1434     return i;
1435 }
1436
1437 STATIC I32
1438 S_dopoptoloop(pTHX_ I32 startingblock)
1439 {
1440     dVAR;
1441     I32 i;
1442     for (i = startingblock; i >= 0; i--) {
1443         register const PERL_CONTEXT * const cx = &cxstack[i];
1444         switch (CxTYPE(cx)) {
1445         case CXt_SUBST:
1446         case CXt_SUB:
1447         case CXt_FORMAT:
1448         case CXt_EVAL:
1449         case CXt_NULL:
1450             Perl_ck_warner(aTHX_ packWARN(WARN_EXITING), "Exiting %s via %s",
1451                            context_name[CxTYPE(cx)], OP_NAME(PL_op));
1452             if ((CxTYPE(cx)) == CXt_NULL)
1453                 return -1;
1454             break;
1455         case CXt_LOOP_LAZYIV:
1456         case CXt_LOOP_LAZYSV:
1457         case CXt_LOOP_FOR:
1458         case CXt_LOOP_PLAIN:
1459             DEBUG_l( Perl_deb(aTHX_ "(Found loop #%ld)\n", (long)i));
1460             return i;
1461         }
1462     }
1463     return i;
1464 }
1465
1466 STATIC I32
1467 S_dopoptogiven(pTHX_ I32 startingblock)
1468 {
1469     dVAR;
1470     I32 i;
1471     for (i = startingblock; i >= 0; i--) {
1472         register const PERL_CONTEXT *cx = &cxstack[i];
1473         switch (CxTYPE(cx)) {
1474         default:
1475             continue;
1476         case CXt_GIVEN:
1477             DEBUG_l( Perl_deb(aTHX_ "(Found given #%ld)\n", (long)i));
1478             return i;
1479         case CXt_LOOP_PLAIN:
1480             assert(!CxFOREACHDEF(cx));
1481             break;
1482         case CXt_LOOP_LAZYIV:
1483         case CXt_LOOP_LAZYSV:
1484         case CXt_LOOP_FOR:
1485             if (CxFOREACHDEF(cx)) {
1486                 DEBUG_l( Perl_deb(aTHX_ "(Found foreach #%ld)\n", (long)i));
1487                 return i;
1488             }
1489         }
1490     }
1491     return i;
1492 }
1493
1494 STATIC I32
1495 S_dopoptowhen(pTHX_ I32 startingblock)
1496 {
1497     dVAR;
1498     I32 i;
1499     for (i = startingblock; i >= 0; i--) {
1500         register const PERL_CONTEXT *cx = &cxstack[i];
1501         switch (CxTYPE(cx)) {
1502         default:
1503             continue;
1504         case CXt_WHEN:
1505             DEBUG_l( Perl_deb(aTHX_ "(Found when #%ld)\n", (long)i));
1506             return i;
1507         }
1508     }
1509     return i;
1510 }
1511
1512 void
1513 Perl_dounwind(pTHX_ I32 cxix)
1514 {
1515     dVAR;
1516     I32 optype;
1517
1518     while (cxstack_ix > cxix) {
1519         SV *sv;
1520         register PERL_CONTEXT *cx = &cxstack[cxstack_ix];
1521         DEBUG_l(PerlIO_printf(Perl_debug_log, "Unwinding block %ld, type %s\n",
1522                               (long) cxstack_ix, PL_block_type[CxTYPE(cx)]));
1523         /* Note: we don't need to restore the base context info till the end. */
1524         switch (CxTYPE(cx)) {
1525         case CXt_SUBST:
1526             POPSUBST(cx);
1527             continue;  /* not break */
1528         case CXt_SUB:
1529             POPSUB(cx,sv);
1530             LEAVESUB(sv);
1531             break;
1532         case CXt_EVAL:
1533             POPEVAL(cx);
1534             break;
1535         case CXt_LOOP_LAZYIV:
1536         case CXt_LOOP_LAZYSV:
1537         case CXt_LOOP_FOR:
1538         case CXt_LOOP_PLAIN:
1539             POPLOOP(cx);
1540             break;
1541         case CXt_NULL:
1542             break;
1543         case CXt_FORMAT:
1544             POPFORMAT(cx);
1545             break;
1546         }
1547         cxstack_ix--;
1548     }
1549     PERL_UNUSED_VAR(optype);
1550 }
1551
1552 void
1553 Perl_qerror(pTHX_ SV *err)
1554 {
1555     dVAR;
1556
1557     PERL_ARGS_ASSERT_QERROR;
1558
1559     if (PL_in_eval)
1560         sv_catsv(ERRSV, err);
1561     else if (PL_errors)
1562         sv_catsv(PL_errors, err);
1563     else
1564         Perl_warn(aTHX_ "%"SVf, SVfARG(err));
1565     if (PL_parser)
1566         ++PL_parser->error_count;
1567 }
1568
1569 void
1570 Perl_die_where(pTHX_ SV *msv)
1571 {
1572     dVAR;
1573
1574     if (PL_in_eval) {
1575         I32 cxix;
1576         I32 gimme;
1577
1578         if (msv) {
1579             if (PL_in_eval & EVAL_KEEPERR) {
1580                 static const char prefix[] = "\t(in cleanup) ";
1581                 SV * const err = ERRSV;
1582                 const char *e = NULL;
1583                 if (!SvPOK(err))
1584                     sv_setpvs(err,"");
1585                 else if (SvCUR(err) >= sizeof(prefix)+SvCUR(msv)-1) {
1586                     STRLEN len;
1587                     STRLEN msglen;
1588                     const char* message = SvPV_const(msv, msglen);
1589                     e = SvPV_const(err, len);
1590                     e += len - msglen;
1591                     if (*e != *message || strNE(e,message))
1592                         e = NULL;
1593                 }
1594                 if (!e) {
1595                     STRLEN start;
1596                     SvGROW(err, SvCUR(err)+sizeof(prefix)+SvCUR(msv));
1597                     sv_catpvn(err, prefix, sizeof(prefix)-1);
1598                     sv_catsv(err, msv);
1599                     start = SvCUR(err)-SvCUR(msv)-sizeof(prefix)+1;
1600                     Perl_ck_warner(aTHX_ packWARN(WARN_MISC), "%s",
1601                                    SvPVX_const(err)+start);
1602                 }
1603             }
1604             else {
1605                 STRLEN msglen;
1606                 const char* message = SvPV_const(msv, msglen);
1607                 sv_setpvn(ERRSV, message, msglen);
1608                 SvFLAGS(ERRSV) |= SvFLAGS(msv) & SVf_UTF8;
1609             }
1610         }
1611
1612         while ((cxix = dopoptoeval(cxstack_ix)) < 0
1613                && PL_curstackinfo->si_prev)
1614         {
1615             dounwind(-1);
1616             POPSTACK;
1617         }
1618
1619         if (cxix >= 0) {
1620             I32 optype;
1621             register PERL_CONTEXT *cx;
1622             SV **newsp;
1623
1624             if (cxix < cxstack_ix)
1625                 dounwind(cxix);
1626
1627             POPBLOCK(cx,PL_curpm);
1628             if (CxTYPE(cx) != CXt_EVAL) {
1629                 STRLEN msglen;
1630                 const char* message = SvPVx_const( msv ? msv : ERRSV, msglen);
1631                 PerlIO_write(Perl_error_log, (const char *)"panic: die ", 11);
1632                 PerlIO_write(Perl_error_log, message, msglen);
1633                 my_exit(1);
1634             }
1635             POPEVAL(cx);
1636
1637             if (gimme == G_SCALAR)
1638                 *++newsp = &PL_sv_undef;
1639             PL_stack_sp = newsp;
1640
1641             LEAVE;
1642
1643             /* LEAVE could clobber PL_curcop (see save_re_context())
1644              * XXX it might be better to find a way to avoid messing with
1645              * PL_curcop in save_re_context() instead, but this is a more
1646              * minimal fix --GSAR */
1647             PL_curcop = cx->blk_oldcop;
1648
1649             if (optype == OP_REQUIRE) {
1650                 const char* const msg = SvPVx_nolen_const(ERRSV);
1651                 SV * const nsv = cx->blk_eval.old_namesv;
1652                 (void)hv_store(GvHVn(PL_incgv), SvPVX_const(nsv), SvCUR(nsv),
1653                                &PL_sv_undef, 0);
1654                 DIE(aTHX_ "%sCompilation failed in require",
1655                     *msg ? msg : "Unknown error\n");
1656             }
1657             assert(CxTYPE(cx) == CXt_EVAL);
1658             PL_restartop = cx->blk_eval.retop;
1659             JMPENV_JUMP(3);
1660             /* NOTREACHED */
1661         }
1662     }
1663
1664     write_to_stderr( msv ? msv : ERRSV );
1665     my_failure_exit();
1666     /* NOTREACHED */
1667 }
1668
1669 PP(pp_xor)
1670 {
1671     dVAR; dSP; dPOPTOPssrl;
1672     if (SvTRUE(left) != SvTRUE(right))
1673         RETSETYES;
1674     else
1675         RETSETNO;
1676 }
1677
1678 PP(pp_caller)
1679 {
1680     dVAR;
1681     dSP;
1682     register I32 cxix = dopoptosub(cxstack_ix);
1683     register const PERL_CONTEXT *cx;
1684     register const PERL_CONTEXT *ccstack = cxstack;
1685     const PERL_SI *top_si = PL_curstackinfo;
1686     I32 gimme;
1687     const char *stashname;
1688     I32 count = 0;
1689
1690     if (MAXARG)
1691         count = POPi;
1692
1693     for (;;) {
1694         /* we may be in a higher stacklevel, so dig down deeper */
1695         while (cxix < 0 && top_si->si_type != PERLSI_MAIN) {
1696             top_si = top_si->si_prev;
1697             ccstack = top_si->si_cxstack;
1698             cxix = dopoptosub_at(ccstack, top_si->si_cxix);
1699         }
1700         if (cxix < 0) {
1701             if (GIMME != G_ARRAY) {
1702                 EXTEND(SP, 1);
1703                 RETPUSHUNDEF;
1704             }
1705             RETURN;
1706         }
1707         /* caller() should not report the automatic calls to &DB::sub */
1708         if (PL_DBsub && GvCV(PL_DBsub) && cxix >= 0 &&
1709                 ccstack[cxix].blk_sub.cv == GvCV(PL_DBsub))
1710             count++;
1711         if (!count--)
1712             break;
1713         cxix = dopoptosub_at(ccstack, cxix - 1);
1714     }
1715
1716     cx = &ccstack[cxix];
1717     if (CxTYPE(cx) == CXt_SUB || CxTYPE(cx) == CXt_FORMAT) {
1718         const I32 dbcxix = dopoptosub_at(ccstack, cxix - 1);
1719         /* We expect that ccstack[dbcxix] is CXt_SUB, anyway, the
1720            field below is defined for any cx. */
1721         /* caller() should not report the automatic calls to &DB::sub */
1722         if (PL_DBsub && GvCV(PL_DBsub) && dbcxix >= 0 && ccstack[dbcxix].blk_sub.cv == GvCV(PL_DBsub))
1723             cx = &ccstack[dbcxix];
1724     }
1725
1726     stashname = CopSTASHPV(cx->blk_oldcop);
1727     if (GIMME != G_ARRAY) {
1728         EXTEND(SP, 1);
1729         if (!stashname)
1730             PUSHs(&PL_sv_undef);
1731         else {
1732             dTARGET;
1733             sv_setpv(TARG, stashname);
1734             PUSHs(TARG);
1735         }
1736         RETURN;
1737     }
1738
1739     EXTEND(SP, 11);
1740
1741     if (!stashname)
1742         PUSHs(&PL_sv_undef);
1743     else
1744         mPUSHs(newSVpv(stashname, 0));
1745     mPUSHs(newSVpv(OutCopFILE(cx->blk_oldcop), 0));
1746     mPUSHi((I32)CopLINE(cx->blk_oldcop));
1747     if (!MAXARG)
1748         RETURN;
1749     if (CxTYPE(cx) == CXt_SUB || CxTYPE(cx) == CXt_FORMAT) {
1750         GV * const cvgv = CvGV(ccstack[cxix].blk_sub.cv);
1751         /* So is ccstack[dbcxix]. */
1752         if (isGV(cvgv)) {
1753             SV * const sv = newSV(0);
1754             gv_efullname3(sv, cvgv, NULL);
1755             mPUSHs(sv);
1756             PUSHs(boolSV(CxHASARGS(cx)));
1757         }
1758         else {
1759             PUSHs(newSVpvs_flags("(unknown)", SVs_TEMP));
1760             PUSHs(boolSV(CxHASARGS(cx)));
1761         }
1762     }
1763     else {
1764         PUSHs(newSVpvs_flags("(eval)", SVs_TEMP));
1765         mPUSHi(0);
1766     }
1767     gimme = (I32)cx->blk_gimme;
1768     if (gimme == G_VOID)
1769         PUSHs(&PL_sv_undef);
1770     else
1771         PUSHs(boolSV((gimme & G_WANT) == G_ARRAY));
1772     if (CxTYPE(cx) == CXt_EVAL) {
1773         /* eval STRING */
1774         if (CxOLD_OP_TYPE(cx) == OP_ENTEREVAL) {
1775             PUSHs(cx->blk_eval.cur_text);
1776             PUSHs(&PL_sv_no);
1777         }
1778         /* require */
1779         else if (cx->blk_eval.old_namesv) {
1780             mPUSHs(newSVsv(cx->blk_eval.old_namesv));
1781             PUSHs(&PL_sv_yes);
1782         }
1783         /* eval BLOCK (try blocks have old_namesv == 0) */
1784         else {
1785             PUSHs(&PL_sv_undef);
1786             PUSHs(&PL_sv_undef);
1787         }
1788     }
1789     else {
1790         PUSHs(&PL_sv_undef);
1791         PUSHs(&PL_sv_undef);
1792     }
1793     if (CxTYPE(cx) == CXt_SUB && CxHASARGS(cx)
1794         && CopSTASH_eq(PL_curcop, PL_debstash))
1795     {
1796         AV * const ary = cx->blk_sub.argarray;
1797         const int off = AvARRAY(ary) - AvALLOC(ary);
1798
1799         if (!PL_dbargs) {
1800             PL_dbargs = GvAV(gv_AVadd(gv_fetchpvs("DB::args", GV_ADDMULTI,
1801                                                   SVt_PVAV)));
1802             AvREAL_off(PL_dbargs);      /* XXX should be REIFY (see av.h) */
1803         }
1804
1805         if (AvMAX(PL_dbargs) < AvFILLp(ary) + off)
1806             av_extend(PL_dbargs, AvFILLp(ary) + off);
1807         Copy(AvALLOC(ary), AvARRAY(PL_dbargs), AvFILLp(ary) + 1 + off, SV*);
1808         AvFILLp(PL_dbargs) = AvFILLp(ary) + off;
1809     }
1810     /* XXX only hints propagated via op_private are currently
1811      * visible (others are not easily accessible, since they
1812      * use the global PL_hints) */
1813     mPUSHi(CopHINTS_get(cx->blk_oldcop));
1814     {
1815         SV * mask ;
1816         STRLEN * const old_warnings = cx->blk_oldcop->cop_warnings ;
1817
1818         if  (old_warnings == pWARN_NONE ||
1819                 (old_warnings == pWARN_STD && (PL_dowarn & G_WARN_ON) == 0))
1820             mask = newSVpvn(WARN_NONEstring, WARNsize) ;
1821         else if (old_warnings == pWARN_ALL ||
1822                   (old_warnings == pWARN_STD && PL_dowarn & G_WARN_ON)) {
1823             /* Get the bit mask for $warnings::Bits{all}, because
1824              * it could have been extended by warnings::register */
1825             SV **bits_all;
1826             HV * const bits = get_hv("warnings::Bits", 0);
1827             if (bits && (bits_all=hv_fetchs(bits, "all", FALSE))) {
1828                 mask = newSVsv(*bits_all);
1829             }
1830             else {
1831                 mask = newSVpvn(WARN_ALLstring, WARNsize) ;
1832             }
1833         }
1834         else
1835             mask = newSVpvn((char *) (old_warnings + 1), old_warnings[0]);
1836         mPUSHs(mask);
1837     }
1838
1839     PUSHs(cx->blk_oldcop->cop_hints_hash ?
1840           sv_2mortal(newRV_noinc(
1841                                  MUTABLE_SV(Perl_refcounted_he_chain_2hv(aTHX_
1842                                               cx->blk_oldcop->cop_hints_hash))))
1843           : &PL_sv_undef);
1844     RETURN;
1845 }
1846
1847 PP(pp_reset)
1848 {
1849     dVAR;
1850     dSP;
1851     const char * const tmps = (MAXARG < 1) ? (const char *)"" : POPpconstx;
1852     sv_reset(tmps, CopSTASH(PL_curcop));
1853     PUSHs(&PL_sv_yes);
1854     RETURN;
1855 }
1856
1857 /* like pp_nextstate, but used instead when the debugger is active */
1858
1859 PP(pp_dbstate)
1860 {
1861     dVAR;
1862     PL_curcop = (COP*)PL_op;
1863     TAINT_NOT;          /* Each statement is presumed innocent */
1864     PL_stack_sp = PL_stack_base + cxstack[cxstack_ix].blk_oldsp;
1865     FREETMPS;
1866
1867     if (PL_op->op_flags & OPf_SPECIAL /* breakpoint */
1868             || SvIV(PL_DBsingle) || SvIV(PL_DBsignal) || SvIV(PL_DBtrace))
1869     {
1870         dSP;
1871         register PERL_CONTEXT *cx;
1872         const I32 gimme = G_ARRAY;
1873         U8 hasargs;
1874         GV * const gv = PL_DBgv;
1875         register CV * const cv = GvCV(gv);
1876
1877         if (!cv)
1878             DIE(aTHX_ "No DB::DB routine defined");
1879
1880         if (CvDEPTH(cv) >= 1 && !(PL_debug & DEBUG_DB_RECURSE_FLAG))
1881             /* don't do recursive DB::DB call */
1882             return NORMAL;
1883
1884         ENTER_with_name("sub");
1885         SAVETMPS;
1886
1887         SAVEI32(PL_debug);
1888         SAVESTACK_POS();
1889         PL_debug = 0;
1890         hasargs = 0;
1891         SPAGAIN;
1892
1893         if (CvISXSUB(cv)) {
1894             CvDEPTH(cv)++;
1895             PUSHMARK(SP);
1896             (void)(*CvXSUB(cv))(aTHX_ cv);
1897             CvDEPTH(cv)--;
1898             FREETMPS;
1899             LEAVE_with_name("sub");
1900             return NORMAL;
1901         }
1902         else {
1903             PUSHBLOCK(cx, CXt_SUB, SP);
1904             PUSHSUB_DB(cx);
1905             cx->blk_sub.retop = PL_op->op_next;
1906             CvDEPTH(cv)++;
1907             SAVECOMPPAD();
1908             PAD_SET_CUR_NOSAVE(CvPADLIST(cv), 1);
1909             RETURNOP(CvSTART(cv));
1910         }
1911     }
1912     else
1913         return NORMAL;
1914 }
1915
1916 PP(pp_enteriter)
1917 {
1918     dVAR; dSP; dMARK;
1919     register PERL_CONTEXT *cx;
1920     const I32 gimme = GIMME_V;
1921     SV **svp;
1922     U8 cxtype = CXt_LOOP_FOR;
1923 #ifdef USE_ITHREADS
1924     PAD *iterdata;
1925 #endif
1926
1927     ENTER_with_name("loop1");
1928     SAVETMPS;
1929
1930     if (PL_op->op_targ) {
1931         if (PL_op->op_private & OPpLVAL_INTRO) { /* for my $x (...) */
1932             SvPADSTALE_off(PAD_SVl(PL_op->op_targ));
1933             SAVESETSVFLAGS(PAD_SVl(PL_op->op_targ),
1934                     SVs_PADSTALE, SVs_PADSTALE);
1935         }
1936         SAVEPADSVANDMORTALIZE(PL_op->op_targ);
1937 #ifndef USE_ITHREADS
1938         svp = &PAD_SVl(PL_op->op_targ);         /* "my" variable */
1939 #else
1940         iterdata = NULL;
1941 #endif
1942     }
1943     else {
1944         GV * const gv = MUTABLE_GV(POPs);
1945         svp = &GvSV(gv);                        /* symbol table variable */
1946         SAVEGENERICSV(*svp);
1947         *svp = newSV(0);
1948 #ifdef USE_ITHREADS
1949         iterdata = (PAD*)gv;
1950 #endif
1951     }
1952
1953     if (PL_op->op_private & OPpITER_DEF)
1954         cxtype |= CXp_FOR_DEF;
1955
1956     ENTER_with_name("loop2");
1957
1958     PUSHBLOCK(cx, cxtype, SP);
1959 #ifdef USE_ITHREADS
1960     PUSHLOOP_FOR(cx, iterdata, MARK, PL_op->op_targ);
1961 #else
1962     PUSHLOOP_FOR(cx, svp, MARK, 0);
1963 #endif
1964     if (PL_op->op_flags & OPf_STACKED) {
1965         SV *maybe_ary = POPs;
1966         if (SvTYPE(maybe_ary) != SVt_PVAV) {
1967             dPOPss;
1968             SV * const right = maybe_ary;
1969             SvGETMAGIC(sv);
1970             SvGETMAGIC(right);
1971             if (RANGE_IS_NUMERIC(sv,right)) {
1972                 cx->cx_type &= ~CXTYPEMASK;
1973                 cx->cx_type |= CXt_LOOP_LAZYIV;
1974                 /* Make sure that no-one re-orders cop.h and breaks our
1975                    assumptions */
1976                 assert(CxTYPE(cx) == CXt_LOOP_LAZYIV);
1977 #ifdef NV_PRESERVES_UV
1978                 if ((SvOK(sv) && ((SvNV(sv) < (NV)IV_MIN) ||
1979                                   (SvNV(sv) > (NV)IV_MAX)))
1980                         ||
1981                     (SvOK(right) && ((SvNV(right) > (NV)IV_MAX) ||
1982                                      (SvNV(right) < (NV)IV_MIN))))
1983 #else
1984                 if ((SvOK(sv) && ((SvNV(sv) <= (NV)IV_MIN)
1985                                   ||
1986                                   ((SvNV(sv) > 0) &&
1987                                         ((SvUV(sv) > (UV)IV_MAX) ||
1988                                          (SvNV(sv) > (NV)UV_MAX)))))
1989                         ||
1990                     (SvOK(right) && ((SvNV(right) <= (NV)IV_MIN)
1991                                      ||
1992                                      ((SvNV(right) > 0) &&
1993                                         ((SvUV(right) > (UV)IV_MAX) ||
1994                                          (SvNV(right) > (NV)UV_MAX))))))
1995 #endif
1996                     DIE(aTHX_ "Range iterator outside integer range");
1997                 cx->blk_loop.state_u.lazyiv.cur = SvIV(sv);
1998                 cx->blk_loop.state_u.lazyiv.end = SvIV(right);
1999 #ifdef DEBUGGING
2000                 /* for correct -Dstv display */
2001                 cx->blk_oldsp = sp - PL_stack_base;
2002 #endif
2003             }
2004             else {
2005                 cx->cx_type &= ~CXTYPEMASK;
2006                 cx->cx_type |= CXt_LOOP_LAZYSV;
2007                 /* Make sure that no-one re-orders cop.h and breaks our
2008                    assumptions */
2009                 assert(CxTYPE(cx) == CXt_LOOP_LAZYSV);
2010                 cx->blk_loop.state_u.lazysv.cur = newSVsv(sv);
2011                 cx->blk_loop.state_u.lazysv.end = right;
2012                 SvREFCNT_inc(right);
2013                 (void) SvPV_force_nolen(cx->blk_loop.state_u.lazysv.cur);
2014                 /* This will do the upgrade to SVt_PV, and warn if the value
2015                    is uninitialised.  */
2016                 (void) SvPV_nolen_const(right);
2017                 /* Doing this avoids a check every time in pp_iter in pp_hot.c
2018                    to replace !SvOK() with a pointer to "".  */
2019                 if (!SvOK(right)) {
2020                     SvREFCNT_dec(right);
2021                     cx->blk_loop.state_u.lazysv.end = &PL_sv_no;
2022                 }
2023             }
2024         }
2025         else /* SvTYPE(maybe_ary) == SVt_PVAV */ {
2026             cx->blk_loop.state_u.ary.ary = MUTABLE_AV(maybe_ary);
2027             SvREFCNT_inc(maybe_ary);
2028             cx->blk_loop.state_u.ary.ix =
2029                 (PL_op->op_private & OPpITER_REVERSED) ?
2030                 AvFILL(cx->blk_loop.state_u.ary.ary) + 1 :
2031                 -1;
2032         }
2033     }
2034     else { /* iterating over items on the stack */
2035         cx->blk_loop.state_u.ary.ary = NULL; /* means to use the stack */
2036         if (PL_op->op_private & OPpITER_REVERSED) {
2037             cx->blk_loop.state_u.ary.ix = cx->blk_oldsp + 1;
2038         }
2039         else {
2040             cx->blk_loop.state_u.ary.ix = MARK - PL_stack_base;
2041         }
2042     }
2043
2044     RETURN;
2045 }
2046
2047 PP(pp_enterloop)
2048 {
2049     dVAR; dSP;
2050     register PERL_CONTEXT *cx;
2051     const I32 gimme = GIMME_V;
2052
2053     ENTER_with_name("loop1");
2054     SAVETMPS;
2055     ENTER_with_name("loop2");
2056
2057     PUSHBLOCK(cx, CXt_LOOP_PLAIN, SP);
2058     PUSHLOOP_PLAIN(cx, SP);
2059
2060     RETURN;
2061 }
2062
2063 PP(pp_leaveloop)
2064 {
2065     dVAR; dSP;
2066     register PERL_CONTEXT *cx;
2067     I32 gimme;
2068     SV **newsp;
2069     PMOP *newpm;
2070     SV **mark;
2071
2072     POPBLOCK(cx,newpm);
2073     assert(CxTYPE_is_LOOP(cx));
2074     mark = newsp;
2075     newsp = PL_stack_base + cx->blk_loop.resetsp;
2076
2077     TAINT_NOT;
2078     if (gimme == G_VOID)
2079         NOOP;
2080     else if (gimme == G_SCALAR) {
2081         if (mark < SP)
2082             *++newsp = sv_mortalcopy(*SP);
2083         else
2084             *++newsp = &PL_sv_undef;
2085     }
2086     else {
2087         while (mark < SP) {
2088             *++newsp = sv_mortalcopy(*++mark);
2089             TAINT_NOT;          /* Each item is independent */
2090         }
2091     }
2092     SP = newsp;
2093     PUTBACK;
2094
2095     POPLOOP(cx);        /* Stack values are safe: release loop vars ... */
2096     PL_curpm = newpm;   /* ... and pop $1 et al */
2097
2098     LEAVE_with_name("loop2");
2099     LEAVE_with_name("loop1");
2100
2101     return NORMAL;
2102 }
2103
2104 PP(pp_return)
2105 {
2106     dVAR; dSP; dMARK;
2107     register PERL_CONTEXT *cx;
2108     bool popsub2 = FALSE;
2109     bool clear_errsv = FALSE;
2110     I32 gimme;
2111     SV **newsp;
2112     PMOP *newpm;
2113     I32 optype = 0;
2114     SV *sv;
2115     OP *retop = NULL;
2116
2117     const I32 cxix = dopoptosub(cxstack_ix);
2118
2119     if (cxix < 0) {
2120         if (CxMULTICALL(cxstack)) { /* In this case we must be in a
2121                                      * sort block, which is a CXt_NULL
2122                                      * not a CXt_SUB */
2123             dounwind(0);
2124             PL_stack_base[1] = *PL_stack_sp;
2125             PL_stack_sp = PL_stack_base + 1;
2126             return 0;
2127         }
2128         else
2129             DIE(aTHX_ "Can't return outside a subroutine");
2130     }
2131     if (cxix < cxstack_ix)
2132         dounwind(cxix);
2133
2134     if (CxMULTICALL(&cxstack[cxix])) {
2135         gimme = cxstack[cxix].blk_gimme;
2136         if (gimme == G_VOID)
2137             PL_stack_sp = PL_stack_base;
2138         else if (gimme == G_SCALAR) {
2139             PL_stack_base[1] = *PL_stack_sp;
2140             PL_stack_sp = PL_stack_base + 1;
2141         }
2142         return 0;
2143     }
2144
2145     POPBLOCK(cx,newpm);
2146     switch (CxTYPE(cx)) {
2147     case CXt_SUB:
2148         popsub2 = TRUE;
2149         retop = cx->blk_sub.retop;
2150         cxstack_ix++; /* preserve cx entry on stack for use by POPSUB */
2151         break;
2152     case CXt_EVAL:
2153         if (!(PL_in_eval & EVAL_KEEPERR))
2154             clear_errsv = TRUE;
2155         POPEVAL(cx);
2156         retop = cx->blk_eval.retop;
2157         if (CxTRYBLOCK(cx))
2158             break;
2159         lex_end();
2160         if (optype == OP_REQUIRE &&
2161             (MARK == SP || (gimme == G_SCALAR && !SvTRUE(*SP))) )
2162         {
2163             /* Unassume the success we assumed earlier. */
2164             SV * const nsv = cx->blk_eval.old_namesv;
2165             (void)hv_delete(GvHVn(PL_incgv), SvPVX_const(nsv), SvCUR(nsv), G_DISCARD);
2166             DIE(aTHX_ "%"SVf" did not return a true value", SVfARG(nsv));
2167         }
2168         break;
2169     case CXt_FORMAT:
2170         POPFORMAT(cx);
2171         retop = cx->blk_sub.retop;
2172         break;
2173     default:
2174         DIE(aTHX_ "panic: return");
2175     }
2176
2177     TAINT_NOT;
2178     if (gimme == G_SCALAR) {
2179         if (MARK < SP) {
2180             if (popsub2) {
2181                 if (cx->blk_sub.cv && CvDEPTH(cx->blk_sub.cv) > 1) {
2182                     if (SvTEMP(TOPs)) {
2183                         *++newsp = SvREFCNT_inc(*SP);
2184                         FREETMPS;
2185                         sv_2mortal(*newsp);
2186                     }
2187                     else {
2188                         sv = SvREFCNT_inc(*SP); /* FREETMPS could clobber it */
2189                         FREETMPS;
2190                         *++newsp = sv_mortalcopy(sv);
2191                         SvREFCNT_dec(sv);
2192                     }
2193                 }
2194                 else
2195                     *++newsp = (SvTEMP(*SP)) ? *SP : sv_mortalcopy(*SP);
2196             }
2197             else
2198                 *++newsp = sv_mortalcopy(*SP);
2199         }
2200         else
2201             *++newsp = &PL_sv_undef;
2202     }
2203     else if (gimme == G_ARRAY) {
2204         while (++MARK <= SP) {
2205             *++newsp = (popsub2 && SvTEMP(*MARK))
2206                         ? *MARK : sv_mortalcopy(*MARK);
2207             TAINT_NOT;          /* Each item is independent */
2208         }
2209     }
2210     PL_stack_sp = newsp;
2211
2212     LEAVE;
2213     /* Stack values are safe: */
2214     if (popsub2) {
2215         cxstack_ix--;
2216         POPSUB(cx,sv);  /* release CV and @_ ... */
2217     }
2218     else
2219         sv = NULL;
2220     PL_curpm = newpm;   /* ... and pop $1 et al */
2221
2222     LEAVESUB(sv);
2223     if (clear_errsv) {
2224         CLEAR_ERRSV();
2225     }
2226     return retop;
2227 }
2228
2229 PP(pp_last)
2230 {
2231     dVAR; dSP;
2232     I32 cxix;
2233     register PERL_CONTEXT *cx;
2234     I32 pop2 = 0;
2235     I32 gimme;
2236     I32 optype;
2237     OP *nextop = NULL;
2238     SV **newsp;
2239     PMOP *newpm;
2240     SV **mark;
2241     SV *sv = NULL;
2242
2243
2244     if (PL_op->op_flags & OPf_SPECIAL) {
2245         cxix = dopoptoloop(cxstack_ix);
2246         if (cxix < 0)
2247             DIE(aTHX_ "Can't \"last\" outside a loop block");
2248     }
2249     else {
2250         cxix = dopoptolabel(cPVOP->op_pv);
2251         if (cxix < 0)
2252             DIE(aTHX_ "Label not found for \"last %s\"", cPVOP->op_pv);
2253     }
2254     if (cxix < cxstack_ix)
2255         dounwind(cxix);
2256
2257     POPBLOCK(cx,newpm);
2258     cxstack_ix++; /* temporarily protect top context */
2259     mark = newsp;
2260     switch (CxTYPE(cx)) {
2261     case CXt_LOOP_LAZYIV:
2262     case CXt_LOOP_LAZYSV:
2263     case CXt_LOOP_FOR:
2264     case CXt_LOOP_PLAIN:
2265         pop2 = CxTYPE(cx);
2266         newsp = PL_stack_base + cx->blk_loop.resetsp;
2267         nextop = cx->blk_loop.my_op->op_lastop->op_next;
2268         break;
2269     case CXt_SUB:
2270         pop2 = CXt_SUB;
2271         nextop = cx->blk_sub.retop;
2272         break;
2273     case CXt_EVAL:
2274         POPEVAL(cx);
2275         nextop = cx->blk_eval.retop;
2276         break;
2277     case CXt_FORMAT:
2278         POPFORMAT(cx);
2279         nextop = cx->blk_sub.retop;
2280         break;
2281     default:
2282         DIE(aTHX_ "panic: last");
2283     }
2284
2285     TAINT_NOT;
2286     if (gimme == G_SCALAR) {
2287         if (MARK < SP)
2288             *++newsp = ((pop2 == CXt_SUB) && SvTEMP(*SP))
2289                         ? *SP : sv_mortalcopy(*SP);
2290         else
2291             *++newsp = &PL_sv_undef;
2292     }
2293     else if (gimme == G_ARRAY) {
2294         while (++MARK <= SP) {
2295             *++newsp = ((pop2 == CXt_SUB) && SvTEMP(*MARK))
2296                         ? *MARK : sv_mortalcopy(*MARK);
2297             TAINT_NOT;          /* Each item is independent */
2298         }
2299     }
2300     SP = newsp;
2301     PUTBACK;
2302
2303     LEAVE;
2304     cxstack_ix--;
2305     /* Stack values are safe: */
2306     switch (pop2) {
2307     case CXt_LOOP_LAZYIV:
2308     case CXt_LOOP_PLAIN:
2309     case CXt_LOOP_LAZYSV:
2310     case CXt_LOOP_FOR:
2311         POPLOOP(cx);    /* release loop vars ... */
2312         LEAVE;
2313         break;
2314     case CXt_SUB:
2315         POPSUB(cx,sv);  /* release CV and @_ ... */
2316         break;
2317     }
2318     PL_curpm = newpm;   /* ... and pop $1 et al */
2319
2320     LEAVESUB(sv);
2321     PERL_UNUSED_VAR(optype);
2322     PERL_UNUSED_VAR(gimme);
2323     return nextop;
2324 }
2325
2326 PP(pp_next)
2327 {
2328     dVAR;
2329     I32 cxix;
2330     register PERL_CONTEXT *cx;
2331     I32 inner;
2332
2333     if (PL_op->op_flags & OPf_SPECIAL) {
2334         cxix = dopoptoloop(cxstack_ix);
2335         if (cxix < 0)
2336             DIE(aTHX_ "Can't \"next\" outside a loop block");
2337     }
2338     else {
2339         cxix = dopoptolabel(cPVOP->op_pv);
2340         if (cxix < 0)
2341             DIE(aTHX_ "Label not found for \"next %s\"", cPVOP->op_pv);
2342     }
2343     if (cxix < cxstack_ix)
2344         dounwind(cxix);
2345
2346     /* clear off anything above the scope we're re-entering, but
2347      * save the rest until after a possible continue block */
2348     inner = PL_scopestack_ix;
2349     TOPBLOCK(cx);
2350     if (PL_scopestack_ix < inner)
2351         leave_scope(PL_scopestack[PL_scopestack_ix]);
2352     PL_curcop = cx->blk_oldcop;
2353     return CX_LOOP_NEXTOP_GET(cx);
2354 }
2355
2356 PP(pp_redo)
2357 {
2358     dVAR;
2359     I32 cxix;
2360     register PERL_CONTEXT *cx;
2361     I32 oldsave;
2362     OP* redo_op;
2363
2364     if (PL_op->op_flags & OPf_SPECIAL) {
2365         cxix = dopoptoloop(cxstack_ix);
2366         if (cxix < 0)
2367             DIE(aTHX_ "Can't \"redo\" outside a loop block");
2368     }
2369     else {
2370         cxix = dopoptolabel(cPVOP->op_pv);
2371         if (cxix < 0)
2372             DIE(aTHX_ "Label not found for \"redo %s\"", cPVOP->op_pv);
2373     }
2374     if (cxix < cxstack_ix)
2375         dounwind(cxix);
2376
2377     redo_op = cxstack[cxix].blk_loop.my_op->op_redoop;
2378     if (redo_op->op_type == OP_ENTER) {
2379         /* pop one less context to avoid $x being freed in while (my $x..) */
2380         cxstack_ix++;
2381         assert(CxTYPE(&cxstack[cxstack_ix]) == CXt_BLOCK);
2382         redo_op = redo_op->op_next;
2383     }
2384
2385     TOPBLOCK(cx);
2386     oldsave = PL_scopestack[PL_scopestack_ix - 1];
2387     LEAVE_SCOPE(oldsave);
2388     FREETMPS;
2389     PL_curcop = cx->blk_oldcop;
2390     return redo_op;
2391 }
2392
2393 STATIC OP *
2394 S_dofindlabel(pTHX_ OP *o, const char *label, OP **opstack, OP **oplimit)
2395 {
2396     dVAR;
2397     OP **ops = opstack;
2398     static const char too_deep[] = "Target of goto is too deeply nested";
2399
2400     PERL_ARGS_ASSERT_DOFINDLABEL;
2401
2402     if (ops >= oplimit)
2403         Perl_croak(aTHX_ too_deep);
2404     if (o->op_type == OP_LEAVE ||
2405         o->op_type == OP_SCOPE ||
2406         o->op_type == OP_LEAVELOOP ||
2407         o->op_type == OP_LEAVESUB ||
2408         o->op_type == OP_LEAVETRY)
2409     {
2410         *ops++ = cUNOPo->op_first;
2411         if (ops >= oplimit)
2412             Perl_croak(aTHX_ too_deep);
2413     }
2414     *ops = 0;
2415     if (o->op_flags & OPf_KIDS) {
2416         OP *kid;
2417         /* First try all the kids at this level, since that's likeliest. */
2418         for (kid = cUNOPo->op_first; kid; kid = kid->op_sibling) {
2419             if (kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE) {
2420                 const char *kid_label = CopLABEL(kCOP);
2421                 if (kid_label && strEQ(kid_label, label))
2422                     return kid;
2423             }
2424         }
2425         for (kid = cUNOPo->op_first; kid; kid = kid->op_sibling) {
2426             if (kid == PL_lastgotoprobe)
2427                 continue;
2428             if (kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE) {
2429                 if (ops == opstack)
2430                     *ops++ = kid;
2431                 else if (ops[-1]->op_type == OP_NEXTSTATE ||
2432                          ops[-1]->op_type == OP_DBSTATE)
2433                     ops[-1] = kid;
2434                 else
2435                     *ops++ = kid;
2436             }
2437             if ((o = dofindlabel(kid, label, ops, oplimit)))
2438                 return o;
2439         }
2440     }
2441     *ops = 0;
2442     return 0;
2443 }
2444
2445 PP(pp_goto)
2446 {
2447     dVAR; dSP;
2448     OP *retop = NULL;
2449     I32 ix;
2450     register PERL_CONTEXT *cx;
2451 #define GOTO_DEPTH 64
2452     OP *enterops[GOTO_DEPTH];
2453     const char *label = NULL;
2454     const bool do_dump = (PL_op->op_type == OP_DUMP);
2455     static const char must_have_label[] = "goto must have label";
2456
2457     if (PL_op->op_flags & OPf_STACKED) {
2458         SV * const sv = POPs;
2459
2460         /* This egregious kludge implements goto &subroutine */
2461         if (SvROK(sv) && SvTYPE(SvRV(sv)) == SVt_PVCV) {
2462             I32 cxix;
2463             register PERL_CONTEXT *cx;
2464             CV *cv = MUTABLE_CV(SvRV(sv));
2465             SV** mark;
2466             I32 items = 0;
2467             I32 oldsave;
2468             bool reified = 0;
2469
2470         retry:
2471             if (!CvROOT(cv) && !CvXSUB(cv)) {
2472                 const GV * const gv = CvGV(cv);
2473                 if (gv) {
2474                     GV *autogv;
2475                     SV *tmpstr;
2476                     /* autoloaded stub? */
2477                     if (cv != GvCV(gv) && (cv = GvCV(gv)))
2478                         goto retry;
2479                     autogv = gv_autoload4(GvSTASH(gv), GvNAME(gv),
2480                                           GvNAMELEN(gv), FALSE);
2481                     if (autogv && (cv = GvCV(autogv)))
2482                         goto retry;
2483                     tmpstr = sv_newmortal();
2484                     gv_efullname3(tmpstr, gv, NULL);
2485                     DIE(aTHX_ "Goto undefined subroutine &%"SVf"", SVfARG(tmpstr));
2486                 }
2487                 DIE(aTHX_ "Goto undefined subroutine");
2488             }
2489
2490             /* First do some returnish stuff. */
2491             SvREFCNT_inc_simple_void(cv); /* avoid premature free during unwind */
2492             FREETMPS;
2493             cxix = dopoptosub(cxstack_ix);
2494             if (cxix < 0)
2495                 DIE(aTHX_ "Can't goto subroutine outside a subroutine");
2496             if (cxix < cxstack_ix)
2497                 dounwind(cxix);
2498             TOPBLOCK(cx);
2499             SPAGAIN;
2500             /* ban goto in eval: see <20050521150056.GC20213@iabyn.com> */
2501             if (CxTYPE(cx) == CXt_EVAL) {
2502                 if (CxREALEVAL(cx))
2503                     DIE(aTHX_ "Can't goto subroutine from an eval-string");
2504                 else
2505                     DIE(aTHX_ "Can't goto subroutine from an eval-block");
2506             }
2507             else if (CxMULTICALL(cx))
2508                 DIE(aTHX_ "Can't goto subroutine from a sort sub (or similar callback)");
2509             if (CxTYPE(cx) == CXt_SUB && CxHASARGS(cx)) {
2510                 /* put @_ back onto stack */
2511                 AV* av = cx->blk_sub.argarray;
2512
2513                 items = AvFILLp(av) + 1;
2514                 EXTEND(SP, items+1); /* @_ could have been extended. */
2515                 Copy(AvARRAY(av), SP + 1, items, SV*);
2516                 SvREFCNT_dec(GvAV(PL_defgv));
2517                 GvAV(PL_defgv) = cx->blk_sub.savearray;
2518                 CLEAR_ARGARRAY(av);
2519                 /* abandon @_ if it got reified */
2520                 if (AvREAL(av)) {
2521                     reified = 1;
2522                     SvREFCNT_dec(av);
2523                     av = newAV();
2524                     av_extend(av, items-1);
2525                     AvREIFY_only(av);
2526                     PAD_SVl(0) = MUTABLE_SV(cx->blk_sub.argarray = av);
2527                 }
2528             }
2529             else if (CvISXSUB(cv)) {    /* put GvAV(defgv) back onto stack */
2530                 AV* const av = GvAV(PL_defgv);
2531                 items = AvFILLp(av) + 1;
2532                 EXTEND(SP, items+1); /* @_ could have been extended. */
2533                 Copy(AvARRAY(av), SP + 1, items, SV*);
2534             }
2535             mark = SP;
2536             SP += items;
2537             if (CxTYPE(cx) == CXt_SUB &&
2538                 !(CvDEPTH(cx->blk_sub.cv) = cx->blk_sub.olddepth))
2539                 SvREFCNT_dec(cx->blk_sub.cv);
2540             oldsave = PL_scopestack[PL_scopestack_ix - 1];
2541             LEAVE_SCOPE(oldsave);
2542
2543             /* Now do some callish stuff. */
2544             SAVETMPS;
2545             SAVEFREESV(cv); /* later, undo the 'avoid premature free' hack */
2546             if (CvISXSUB(cv)) {
2547                 OP* const retop = cx->blk_sub.retop;
2548                 SV **newsp;
2549                 I32 gimme;
2550                 if (reified) {
2551                     I32 index;
2552                     for (index=0; index<items; index++)
2553                         sv_2mortal(SP[-index]);
2554                 }
2555
2556                 /* XS subs don't have a CxSUB, so pop it */
2557                 POPBLOCK(cx, PL_curpm);
2558                 /* Push a mark for the start of arglist */
2559                 PUSHMARK(mark);
2560                 PUTBACK;
2561                 (void)(*CvXSUB(cv))(aTHX_ cv);
2562                 LEAVE_with_name("sub");
2563                 return retop;
2564             }
2565             else {
2566                 AV* const padlist = CvPADLIST(cv);
2567                 if (CxTYPE(cx) == CXt_EVAL) {
2568                     PL_in_eval = CxOLD_IN_EVAL(cx);
2569                     PL_eval_root = cx->blk_eval.old_eval_root;
2570                     cx->cx_type = CXt_SUB;
2571                 }
2572                 cx->blk_sub.cv = cv;
2573                 cx->blk_sub.olddepth = CvDEPTH(cv);
2574
2575                 CvDEPTH(cv)++;
2576                 if (CvDEPTH(cv) < 2)
2577                     SvREFCNT_inc_simple_void_NN(cv);
2578                 else {
2579                     if (CvDEPTH(cv) == PERL_SUB_DEPTH_WARN && ckWARN(WARN_RECURSION))
2580                         sub_crush_depth(cv);
2581                     pad_push(padlist, CvDEPTH(cv));
2582                 }
2583                 SAVECOMPPAD();
2584                 PAD_SET_CUR_NOSAVE(padlist, CvDEPTH(cv));
2585                 if (CxHASARGS(cx))
2586                 {
2587                     AV *const av = MUTABLE_AV(PAD_SVl(0));
2588
2589                     cx->blk_sub.savearray = GvAV(PL_defgv);
2590                     GvAV(PL_defgv) = MUTABLE_AV(SvREFCNT_inc_simple(av));
2591                     CX_CURPAD_SAVE(cx->blk_sub);
2592                     cx->blk_sub.argarray = av;
2593
2594                     if (items >= AvMAX(av) + 1) {
2595                         SV **ary = AvALLOC(av);
2596                         if (AvARRAY(av) != ary) {
2597                             AvMAX(av) += AvARRAY(av) - AvALLOC(av);
2598                             AvARRAY(av) = ary;
2599                         }
2600                         if (items >= AvMAX(av) + 1) {
2601                             AvMAX(av) = items - 1;
2602                             Renew(ary,items+1,SV*);
2603                             AvALLOC(av) = ary;
2604                             AvARRAY(av) = ary;
2605                         }
2606                     }
2607                     ++mark;
2608                     Copy(mark,AvARRAY(av),items,SV*);
2609                     AvFILLp(av) = items - 1;
2610                     assert(!AvREAL(av));
2611                     if (reified) {
2612                         /* transfer 'ownership' of refcnts to new @_ */
2613                         AvREAL_on(av);
2614                         AvREIFY_off(av);
2615                     }
2616                     while (items--) {
2617                         if (*mark)
2618                             SvTEMP_off(*mark);
2619                         mark++;
2620                     }
2621                 }
2622                 if (PERLDB_SUB) {       /* Checking curstash breaks DProf. */
2623                     Perl_get_db_sub(aTHX_ NULL, cv);
2624                     if (PERLDB_GOTO) {
2625                         CV * const gotocv = get_cvs("DB::goto", 0);
2626                         if (gotocv) {
2627                             PUSHMARK( PL_stack_sp );
2628                             call_sv(MUTABLE_SV(gotocv), G_SCALAR | G_NODEBUG);
2629                             PL_stack_sp--;
2630                         }
2631                     }
2632                 }
2633                 RETURNOP(CvSTART(cv));
2634             }
2635         }
2636         else {
2637             label = SvPV_nolen_const(sv);
2638             if (!(do_dump || *label))
2639                 DIE(aTHX_ must_have_label);
2640         }
2641     }
2642     else if (PL_op->op_flags & OPf_SPECIAL) {
2643         if (! do_dump)
2644             DIE(aTHX_ must_have_label);
2645     }
2646     else
2647         label = cPVOP->op_pv;
2648
2649     if (label && *label) {
2650         OP *gotoprobe = NULL;
2651         bool leaving_eval = FALSE;
2652         bool in_block = FALSE;
2653         PERL_CONTEXT *last_eval_cx = NULL;
2654
2655         /* find label */
2656
2657         PL_lastgotoprobe = NULL;
2658         *enterops = 0;
2659         for (ix = cxstack_ix; ix >= 0; ix--) {
2660             cx = &cxstack[ix];
2661             switch (CxTYPE(cx)) {
2662             case CXt_EVAL:
2663                 leaving_eval = TRUE;
2664                 if (!CxTRYBLOCK(cx)) {
2665                     gotoprobe = (last_eval_cx ?
2666                                 last_eval_cx->blk_eval.old_eval_root :
2667                                 PL_eval_root);
2668                     last_eval_cx = cx;
2669                     break;
2670                 }
2671                 /* else fall through */
2672             case CXt_LOOP_LAZYIV:
2673             case CXt_LOOP_LAZYSV:
2674             case CXt_LOOP_FOR:
2675             case CXt_LOOP_PLAIN:
2676             case CXt_GIVEN:
2677             case CXt_WHEN:
2678                 gotoprobe = cx->blk_oldcop->op_sibling;
2679                 break;
2680             case CXt_SUBST:
2681                 continue;
2682             case CXt_BLOCK:
2683                 if (ix) {
2684                     gotoprobe = cx->blk_oldcop->op_sibling;
2685                     in_block = TRUE;
2686                 } else
2687                     gotoprobe = PL_main_root;
2688                 break;
2689             case CXt_SUB:
2690                 if (CvDEPTH(cx->blk_sub.cv) && !CxMULTICALL(cx)) {
2691                     gotoprobe = CvROOT(cx->blk_sub.cv);
2692                     break;
2693                 }
2694                 /* FALL THROUGH */
2695             case CXt_FORMAT:
2696             case CXt_NULL:
2697                 DIE(aTHX_ "Can't \"goto\" out of a pseudo block");
2698             default:
2699                 if (ix)
2700                     DIE(aTHX_ "panic: goto");
2701                 gotoprobe = PL_main_root;
2702                 break;
2703             }
2704             if (gotoprobe) {
2705                 retop = dofindlabel(gotoprobe, label,
2706                                     enterops, enterops + GOTO_DEPTH);
2707                 if (retop)
2708                     break;
2709             }
2710             PL_lastgotoprobe = gotoprobe;
2711         }
2712         if (!retop)
2713             DIE(aTHX_ "Can't find label %s", label);
2714
2715         /* if we're leaving an eval, check before we pop any frames
2716            that we're not going to punt, otherwise the error
2717            won't be caught */
2718
2719         if (leaving_eval && *enterops && enterops[1]) {
2720             I32 i;
2721             for (i = 1; enterops[i]; i++)
2722                 if (enterops[i]->op_type == OP_ENTERITER)
2723                     DIE(aTHX_ "Can't \"goto\" into the middle of a foreach loop");
2724         }
2725
2726         if (*enterops && enterops[1]) {
2727             I32 i = enterops[1]->op_type == OP_ENTER && in_block ? 2 : 1;
2728             if (enterops[i])
2729                 deprecate("\"goto\" to jump into a construct");
2730         }
2731
2732         /* pop unwanted frames */
2733
2734         if (ix < cxstack_ix) {
2735             I32 oldsave;
2736
2737             if (ix < 0)
2738                 ix = 0;
2739             dounwind(ix);
2740             TOPBLOCK(cx);
2741             oldsave = PL_scopestack[PL_scopestack_ix];
2742             LEAVE_SCOPE(oldsave);
2743         }
2744
2745         /* push wanted frames */
2746
2747         if (*enterops && enterops[1]) {
2748             OP * const oldop = PL_op;
2749             ix = enterops[1]->op_type == OP_ENTER && in_block ? 2 : 1;
2750             for (; enterops[ix]; ix++) {
2751                 PL_op = enterops[ix];
2752                 /* Eventually we may want to stack the needed arguments
2753                  * for each op.  For now, we punt on the hard ones. */
2754                 if (PL_op->op_type == OP_ENTERITER)
2755                     DIE(aTHX_ "Can't \"goto\" into the middle of a foreach loop");
2756                 CALL_FPTR(PL_op->op_ppaddr)(aTHX);
2757             }
2758             PL_op = oldop;
2759         }
2760     }
2761
2762     if (do_dump) {
2763 #ifdef VMS
2764         if (!retop) retop = PL_main_start;
2765 #endif
2766         PL_restartop = retop;
2767         PL_do_undump = TRUE;
2768
2769         my_unexec();
2770
2771         PL_restartop = 0;               /* hmm, must be GNU unexec().. */
2772         PL_do_undump = FALSE;
2773     }
2774
2775     RETURNOP(retop);
2776 }
2777
2778 PP(pp_exit)
2779 {
2780     dVAR;
2781     dSP;
2782     I32 anum;
2783
2784     if (MAXARG < 1)
2785         anum = 0;
2786     else {
2787         anum = SvIVx(POPs);
2788 #ifdef VMS
2789         if (anum == 1 && (PL_op->op_private & OPpEXIT_VMSISH))
2790             anum = 0;
2791         VMSISH_HUSHED  = VMSISH_HUSHED || (PL_op->op_private & OPpHUSH_VMSISH);
2792 #endif
2793     }
2794     PL_exit_flags |= PERL_EXIT_EXPECTED;
2795 #ifdef PERL_MAD
2796     /* KLUDGE: disable exit 0 in BEGIN blocks when we're just compiling */
2797     if (anum || !(PL_minus_c && PL_madskills))
2798         my_exit(anum);
2799 #else
2800     my_exit(anum);
2801 #endif
2802     PUSHs(&PL_sv_undef);
2803     RETURN;
2804 }
2805
2806 /* Eval. */
2807
2808 STATIC void
2809 S_save_lines(pTHX_ AV *array, SV *sv)
2810 {
2811     const char *s = SvPVX_const(sv);
2812     const char * const send = SvPVX_const(sv) + SvCUR(sv);
2813     I32 line = 1;
2814
2815     PERL_ARGS_ASSERT_SAVE_LINES;
2816
2817     while (s && s < send) {
2818         const char *t;
2819         SV * const tmpstr = newSV_type(SVt_PVMG);
2820
2821         t = (const char *)memchr(s, '\n', send - s);
2822         if (t)
2823             t++;
2824         else
2825             t = send;
2826
2827         sv_setpvn(tmpstr, s, t - s);
2828         av_store(array, line++, tmpstr);
2829         s = t;
2830     }
2831 }
2832
2833 STATIC OP *
2834 S_docatch(pTHX_ OP *o)
2835 {
2836     dVAR;
2837     int ret;
2838     OP * const oldop = PL_op;
2839     dJMPENV;
2840
2841 #ifdef DEBUGGING
2842     assert(CATCH_GET == TRUE);
2843 #endif
2844     PL_op = o;
2845
2846     JMPENV_PUSH(ret);
2847     switch (ret) {
2848     case 0:
2849         assert(cxstack_ix >= 0);
2850         assert(CxTYPE(&cxstack[cxstack_ix]) == CXt_EVAL);
2851         cxstack[cxstack_ix].blk_eval.cur_top_env = PL_top_env;
2852  redo_body:
2853         CALLRUNOPS(aTHX);
2854         break;
2855     case 3:
2856         /* die caught by an inner eval - continue inner loop */
2857
2858         /* NB XXX we rely on the old popped CxEVAL still being at the top
2859          * of the stack; the way die_where() currently works, this
2860          * assumption is valid. In theory The cur_top_env value should be
2861          * returned in another global, the way retop (aka PL_restartop)
2862          * is. */
2863         assert(CxTYPE(&cxstack[cxstack_ix+1]) == CXt_EVAL);
2864
2865         if (PL_restartop
2866             && cxstack[cxstack_ix+1].blk_eval.cur_top_env == PL_top_env)
2867         {
2868             PL_op = PL_restartop;
2869             PL_restartop = 0;
2870             goto redo_body;
2871         }
2872         /* FALL THROUGH */
2873     default:
2874         JMPENV_POP;
2875         PL_op = oldop;
2876         JMPENV_JUMP(ret);
2877         /* NOTREACHED */
2878     }
2879     JMPENV_POP;
2880     PL_op = oldop;
2881     return NULL;
2882 }
2883
2884 OP *
2885 Perl_sv_compile_2op(pTHX_ SV *sv, OP** startop, const char *code, PAD** padp)
2886 /* sv Text to convert to OP tree. */
2887 /* startop op_free() this to undo. */
2888 /* code Short string id of the caller. */
2889 {
2890     /* FIXME - how much of this code is common with pp_entereval?  */
2891     dVAR; dSP;                          /* Make POPBLOCK work. */
2892     PERL_CONTEXT *cx;
2893     SV **newsp;
2894     I32 gimme = G_VOID;
2895     I32 optype;
2896     OP dummy;
2897     char tbuf[TYPE_DIGITS(long) + 12 + 10];
2898     char *tmpbuf = tbuf;
2899     char *safestr;
2900     int runtime;
2901     CV* runcv = NULL;   /* initialise to avoid compiler warnings */
2902     STRLEN len;
2903
2904     PERL_ARGS_ASSERT_SV_COMPILE_2OP;
2905
2906     ENTER_with_name("eval");
2907     lex_start(sv, NULL, FALSE);
2908     SAVETMPS;
2909     /* switch to eval mode */
2910
2911     if (IN_PERL_COMPILETIME) {
2912         SAVECOPSTASH_FREE(&PL_compiling);
2913         CopSTASH_set(&PL_compiling, PL_curstash);
2914     }
2915     if (PERLDB_NAMEEVAL && CopLINE(PL_curcop)) {
2916         SV * const sv = sv_newmortal();
2917         Perl_sv_setpvf(aTHX_ sv, "_<(%.10seval %lu)[%s:%"IVdf"]",
2918                        code, (unsigned long)++PL_evalseq,
2919                        CopFILE(PL_curcop), (IV)CopLINE(PL_curcop));
2920         tmpbuf = SvPVX(sv);
2921         len = SvCUR(sv);
2922     }
2923     else
2924         len = my_snprintf(tmpbuf, sizeof(tbuf), "_<(%.10s_eval %lu)", code,
2925                           (unsigned long)++PL_evalseq);
2926     SAVECOPFILE_FREE(&PL_compiling);
2927     CopFILE_set(&PL_compiling, tmpbuf+2);
2928     SAVECOPLINE(&PL_compiling);
2929     CopLINE_set(&PL_compiling, 1);
2930     /* XXX For C<eval "...">s within BEGIN {} blocks, this ends up
2931        deleting the eval's FILEGV from the stash before gv_check() runs
2932        (i.e. before run-time proper). To work around the coredump that
2933        ensues, we always turn GvMULTI_on for any globals that were
2934        introduced within evals. See force_ident(). GSAR 96-10-12 */
2935     safestr = savepvn(tmpbuf, len);
2936     SAVEDELETE(PL_defstash, safestr, len);
2937     SAVEHINTS();
2938 #ifdef OP_IN_REGISTER
2939     PL_opsave = op;
2940 #else
2941     SAVEVPTR(PL_op);
2942 #endif
2943
2944     /* we get here either during compilation, or via pp_regcomp at runtime */
2945     runtime = IN_PERL_RUNTIME;
2946     if (runtime)
2947         runcv = find_runcv(NULL);
2948
2949     PL_op = &dummy;
2950     PL_op->op_type = OP_ENTEREVAL;
2951     PL_op->op_flags = 0;                        /* Avoid uninit warning. */
2952     PUSHBLOCK(cx, CXt_EVAL|(IN_PERL_COMPILETIME ? 0 : CXp_REAL), SP);
2953     PUSHEVAL(cx, 0);
2954
2955     if (runtime)
2956         (void) doeval(G_SCALAR, startop, runcv, PL_curcop->cop_seq);
2957     else
2958         (void) doeval(G_SCALAR, startop, PL_compcv, PL_cop_seqmax);
2959     POPBLOCK(cx,PL_curpm);
2960     POPEVAL(cx);
2961
2962     (*startop)->op_type = OP_NULL;
2963     (*startop)->op_ppaddr = PL_ppaddr[OP_NULL];
2964     lex_end();
2965     /* XXX DAPM do this properly one year */
2966     *padp = MUTABLE_AV(SvREFCNT_inc_simple(PL_comppad));
2967     LEAVE_with_name("eval");
2968     if (IN_PERL_COMPILETIME)
2969         CopHINTS_set(&PL_compiling, PL_hints);
2970 #ifdef OP_IN_REGISTER
2971     op = PL_opsave;
2972 #endif
2973     PERL_UNUSED_VAR(newsp);
2974     PERL_UNUSED_VAR(optype);
2975
2976     return PL_eval_start;
2977 }
2978
2979
2980 /*
2981 =for apidoc find_runcv
2982
2983 Locate the CV corresponding to the currently executing sub or eval.
2984 If db_seqp is non_null, skip CVs that are in the DB package and populate
2985 *db_seqp with the cop sequence number at the point that the DB:: code was
2986 entered. (allows debuggers to eval in the scope of the breakpoint rather
2987 than in the scope of the debugger itself).
2988
2989 =cut
2990 */
2991
2992 CV*
2993 Perl_find_runcv(pTHX_ U32 *db_seqp)
2994 {
2995     dVAR;
2996     PERL_SI      *si;
2997
2998     if (db_seqp)
2999         *db_seqp = PL_curcop->cop_seq;
3000     for (si = PL_curstackinfo; si; si = si->si_prev) {
3001         I32 ix;
3002         for (ix = si->si_cxix; ix >= 0; ix--) {
3003             const PERL_CONTEXT *cx = &(si->si_cxstack[ix]);
3004             if (CxTYPE(cx) == CXt_SUB || CxTYPE(cx) == CXt_FORMAT) {
3005                 CV * const cv = cx->blk_sub.cv;
3006                 /* skip DB:: code */
3007                 if (db_seqp && PL_debstash && CvSTASH(cv) == PL_debstash) {
3008                     *db_seqp = cx->blk_oldcop->cop_seq;
3009                     continue;
3010                 }
3011                 return cv;
3012             }
3013             else if (CxTYPE(cx) == CXt_EVAL && !CxTRYBLOCK(cx))
3014                 return PL_compcv;
3015         }
3016     }
3017     return PL_main_cv;
3018 }
3019
3020
3021 /* Compile a require/do, an eval '', or a /(?{...})/.
3022  * In the last case, startop is non-null, and contains the address of
3023  * a pointer that should be set to the just-compiled code.
3024  * outside is the lexically enclosing CV (if any) that invoked us.
3025  * Returns a bool indicating whether the compile was successful; if so,
3026  * PL_eval_start contains the first op of the compiled ocde; otherwise,
3027  * pushes undef (also croaks if startop != NULL).
3028  */
3029
3030 STATIC bool
3031 S_doeval(pTHX_ int gimme, OP** startop, CV* outside, U32 seq)
3032 {
3033     dVAR; dSP;
3034     OP * const saveop = PL_op;
3035
3036     PL_in_eval = ((saveop && saveop->op_type == OP_REQUIRE)
3037                   ? (EVAL_INREQUIRE | (PL_in_eval & EVAL_INEVAL))
3038                   : EVAL_INEVAL);
3039
3040     PUSHMARK(SP);
3041
3042     SAVESPTR(PL_compcv);
3043     PL_compcv = MUTABLE_CV(newSV_type(SVt_PVCV));
3044     CvEVAL_on(PL_compcv);
3045     assert(CxTYPE(&cxstack[cxstack_ix]) == CXt_EVAL);
3046     cxstack[cxstack_ix].blk_eval.cv = PL_compcv;
3047
3048     CvOUTSIDE_SEQ(PL_compcv) = seq;
3049     CvOUTSIDE(PL_compcv) = MUTABLE_CV(SvREFCNT_inc_simple(outside));
3050
3051     /* set up a scratch pad */
3052
3053     CvPADLIST(PL_compcv) = pad_new(padnew_SAVE);
3054     PL_op = NULL; /* avoid PL_op and PL_curpad referring to different CVs */
3055
3056
3057     if (!PL_madskills)
3058         SAVEMORTALIZESV(PL_compcv);     /* must remain until end of current statement */
3059
3060     /* make sure we compile in the right package */
3061
3062     if (CopSTASH_ne(PL_curcop, PL_curstash)) {
3063         SAVESPTR(PL_curstash);
3064         PL_curstash = CopSTASH(PL_curcop);
3065     }
3066     /* XXX:ajgo do we really need to alloc an AV for begin/checkunit */
3067     SAVESPTR(PL_beginav);
3068     PL_beginav = newAV();
3069     SAVEFREESV(PL_beginav);
3070     SAVESPTR(PL_unitcheckav);
3071     PL_unitcheckav = newAV();
3072     SAVEFREESV(PL_unitcheckav);
3073
3074 #ifdef PERL_MAD
3075     SAVEBOOL(PL_madskills);
3076     PL_madskills = 0;
3077 #endif
3078
3079     /* try to compile it */
3080
3081     PL_eval_root = NULL;
3082     PL_curcop = &PL_compiling;
3083     CopARYBASE_set(PL_curcop, 0);
3084     if (saveop && (saveop->op_type != OP_REQUIRE) && (saveop->op_flags & OPf_SPECIAL))
3085         PL_in_eval |= EVAL_KEEPERR;
3086     else
3087         CLEAR_ERRSV();
3088     if (yyparse() || PL_parser->error_count || !PL_eval_root) {
3089         SV **newsp;                     /* Used by POPBLOCK. */
3090         PERL_CONTEXT *cx = &cxstack[cxstack_ix];
3091         I32 optype = 0;                 /* Might be reset by POPEVAL. */
3092         const char *msg;
3093
3094         PL_op = saveop;
3095         if (PL_eval_root) {
3096             op_free(PL_eval_root);
3097             PL_eval_root = NULL;
3098         }
3099         SP = PL_stack_base + POPMARK;           /* pop original mark */
3100         if (!startop) {
3101             POPBLOCK(cx,PL_curpm);
3102             POPEVAL(cx);
3103         }
3104         lex_end();
3105         LEAVE_with_name("eval"); /* pp_entereval knows about this LEAVE.  */
3106
3107         msg = SvPVx_nolen_const(ERRSV);
3108         if (optype == OP_REQUIRE) {
3109             const SV * const nsv = cx->blk_eval.old_namesv;
3110             (void)hv_store(GvHVn(PL_incgv), SvPVX_const(nsv), SvCUR(nsv),
3111                           &PL_sv_undef, 0);
3112             Perl_croak(aTHX_ "%sCompilation failed in require",
3113                        *msg ? msg : "Unknown error\n");
3114         }
3115         else if (startop) {
3116             POPBLOCK(cx,PL_curpm);
3117             POPEVAL(cx);
3118             Perl_croak(aTHX_ "%sCompilation failed in regexp",
3119                        (*msg ? msg : "Unknown error\n"));
3120         }
3121         else {
3122             if (!*msg) {
3123                 sv_setpvs(ERRSV, "Compilation error");
3124             }
3125         }
3126         PERL_UNUSED_VAR(newsp);
3127         PUSHs(&PL_sv_undef);
3128         PUTBACK;
3129         return FALSE;
3130     }
3131     CopLINE_set(&PL_compiling, 0);
3132     if (startop) {
3133         *startop = PL_eval_root;
3134     } else
3135         SAVEFREEOP(PL_eval_root);
3136
3137     /* Set the context for this new optree.
3138      * Propagate the context from the eval(). */
3139     if ((gimme & G_WANT) == G_VOID)
3140         scalarvoid(PL_eval_root);
3141     else if ((gimme & G_WANT) == G_ARRAY)
3142         list(PL_eval_root);
3143     else
3144         scalar(PL_eval_root);
3145
3146     DEBUG_x(dump_eval());
3147
3148     /* Register with debugger: */
3149     if (PERLDB_INTER && saveop && saveop->op_type == OP_REQUIRE) {
3150         CV * const cv = get_cvs("DB::postponed", 0);
3151         if (cv) {
3152             dSP;
3153             PUSHMARK(SP);
3154             XPUSHs(MUTABLE_SV(CopFILEGV(&PL_compiling)));
3155             PUTBACK;
3156             call_sv(MUTABLE_SV(cv), G_DISCARD);
3157         }
3158     }
3159
3160     if (PL_unitcheckav)
3161         call_list(PL_scopestack_ix, PL_unitcheckav);
3162
3163     /* compiled okay, so do it */
3164
3165     CvDEPTH(PL_compcv) = 1;
3166     SP = PL_stack_base + POPMARK;               /* pop original mark */
3167     PL_op = saveop;                     /* The caller may need it. */
3168     PL_parser->lex_state = LEX_NOTPARSING;      /* $^S needs this. */
3169
3170     PUTBACK;
3171     return TRUE;
3172 }
3173
3174 STATIC PerlIO *
3175 S_check_type_and_open(pTHX_ const char *name)
3176 {
3177     Stat_t st;
3178     const int st_rc = PerlLIO_stat(name, &st);
3179
3180     PERL_ARGS_ASSERT_CHECK_TYPE_AND_OPEN;
3181
3182     if (st_rc < 0 || S_ISDIR(st.st_mode) || S_ISBLK(st.st_mode)) {
3183         return NULL;
3184     }
3185
3186     return PerlIO_open(name, PERL_SCRIPT_MODE);
3187 }
3188
3189 #ifndef PERL_DISABLE_PMC
3190 STATIC PerlIO *
3191 S_doopen_pm(pTHX_ const char *name, const STRLEN namelen)
3192 {
3193     PerlIO *fp;
3194
3195     PERL_ARGS_ASSERT_DOOPEN_PM;
3196
3197     if (namelen > 3 && memEQs(name + namelen - 3, 3, ".pm")) {
3198         SV *const pmcsv = newSV(namelen + 2);
3199         char *const pmc = SvPVX(pmcsv);
3200         Stat_t pmcstat;
3201
3202         memcpy(pmc, name, namelen);
3203         pmc[namelen] = 'c';
3204         pmc[namelen + 1] = '\0';
3205
3206         if (PerlLIO_stat(pmc, &pmcstat) < 0) {
3207             fp = check_type_and_open(name);
3208         }
3209         else {
3210             fp = check_type_and_open(pmc);
3211         }
3212         SvREFCNT_dec(pmcsv);
3213     }
3214     else {
3215         fp = check_type_and_open(name);
3216     }
3217     return fp;
3218 }
3219 #else
3220 #  define doopen_pm(name, namelen) check_type_and_open(name)
3221 #endif /* !PERL_DISABLE_PMC */
3222
3223 PP(pp_require)
3224 {
3225     dVAR; dSP;
3226     register PERL_CONTEXT *cx;
3227     SV *sv;
3228     const char *name;
3229     STRLEN len;
3230     char * unixname;
3231     STRLEN unixlen;
3232 #ifdef VMS
3233     int vms_unixname = 0;
3234 #endif
3235     const char *tryname = NULL;
3236     SV *namesv = NULL;
3237     const I32 gimme = GIMME_V;
3238     int filter_has_file = 0;
3239     PerlIO *tryrsfp = NULL;
3240     SV *filter_cache = NULL;
3241     SV *filter_state = NULL;
3242     SV *filter_sub = NULL;
3243     SV *hook_sv = NULL;
3244     SV *encoding;
3245     OP *op;
3246
3247     sv = POPs;
3248     if ( (SvNIOKp(sv) || SvVOK(sv)) && PL_op->op_type != OP_DOFILE) {
3249         sv = new_version(sv);
3250         if (!sv_derived_from(PL_patchlevel, "version"))
3251             upg_version(PL_patchlevel, TRUE);
3252         if (cUNOP->op_first->op_type == OP_CONST && cUNOP->op_first->op_private & OPpCONST_NOVER) {
3253             if ( vcmp(sv,PL_patchlevel) <= 0 )
3254                 DIE(aTHX_ "Perls since %"SVf" too modern--this is %"SVf", stopped",
3255                     SVfARG(vnormal(sv)), SVfARG(vnormal(PL_patchlevel)));
3256         }
3257         else {
3258             if ( vcmp(sv,PL_patchlevel) > 0 ) {
3259                 I32 first = 0;
3260                 AV *lav;
3261                 SV * const req = SvRV(sv);
3262                 SV * const pv = *hv_fetchs(MUTABLE_HV(req), "original", FALSE);
3263
3264                 /* get the left hand term */
3265                 lav = MUTABLE_AV(SvRV(*hv_fetchs(MUTABLE_HV(req), "version", FALSE)));
3266
3267                 first  = SvIV(*av_fetch(lav,0,0));
3268                 if (   first > (int)PERL_REVISION    /* probably 'use 6.0' */
3269                     || hv_exists(MUTABLE_HV(req), "qv", 2 ) /* qv style */
3270                     || av_len(lav) > 1               /* FP with > 3 digits */
3271                     || strstr(SvPVX(pv),".0")        /* FP with leading 0 */
3272                    ) {
3273                     DIE(aTHX_ "Perl %"SVf" required--this is only "
3274                         "%"SVf", stopped", SVfARG(vnormal(req)),
3275                         SVfARG(vnormal(PL_patchlevel)));
3276                 }
3277                 else { /* probably 'use 5.10' or 'use 5.8' */
3278                     SV * hintsv = newSV(0);
3279                     I32 second = 0;
3280
3281                     if (av_len(lav)>=1)
3282                         second = SvIV(*av_fetch(lav,1,0));
3283
3284                     second /= second >= 600  ? 100 : 10;
3285                     hintsv = Perl_newSVpvf(aTHX_ "v%d.%d.%d",
3286                         (int)first, (int)second,0);
3287                     upg_version(hintsv, TRUE);
3288
3289                     DIE(aTHX_ "Perl %"SVf" required (did you mean %"SVf"?)"
3290                         "--this is only %"SVf", stopped",
3291                         SVfARG(vnormal(req)),
3292                         SVfARG(vnormal(hintsv)),
3293                         SVfARG(vnormal(PL_patchlevel)));
3294                 }
3295             }
3296         }
3297
3298         /* We do this only with use, not require. */
3299         if (PL_compcv &&
3300           /* If we request a version >= 5.9.5, load feature.pm with the
3301            * feature bundle that corresponds to the required version. */
3302                 vcmp(sv, sv_2mortal(upg_version(newSVnv(5.009005), FALSE))) >= 0) {
3303             SV *const importsv = vnormal(sv);
3304             *SvPVX_mutable(importsv) = ':';
3305             ENTER_with_name("load_feature");
3306             Perl_load_module(aTHX_ 0, newSVpvs("feature"), NULL, importsv, NULL);
3307             LEAVE_with_name("load_feature");
3308         }
3309         /* If a version >= 5.11.0 is requested, strictures are on by default! */
3310         if (PL_compcv &&
3311                 vcmp(sv, sv_2mortal(upg_version(newSVnv(5.011000), FALSE))) >= 0) {
3312             PL_hints |= (HINT_STRICT_REFS | HINT_STRICT_SUBS | HINT_STRICT_VARS);
3313         }
3314
3315         RETPUSHYES;
3316     }
3317     name = SvPV_const(sv, len);
3318     if (!(name && len > 0 && *name))
3319         DIE(aTHX_ "Null filename used");
3320     TAINT_PROPER("require");
3321
3322
3323 #ifdef VMS
3324     /* The key in the %ENV hash is in the syntax of file passed as the argument
3325      * usually this is in UNIX format, but sometimes in VMS format, which
3326      * can result in a module being pulled in more than once.
3327      * To prevent this, the key must be stored in UNIX format if the VMS
3328      * name can be translated to UNIX.
3329      */
3330     if ((unixname = tounixspec(name, NULL)) != NULL) {
3331         unixlen = strlen(unixname);
3332         vms_unixname = 1;
3333     }
3334     else
3335 #endif
3336     {
3337         /* if not VMS or VMS name can not be translated to UNIX, pass it
3338          * through.
3339          */
3340         unixname = (char *) name;
3341         unixlen = len;
3342     }
3343     if (PL_op->op_type == OP_REQUIRE) {
3344         SV * const * const svp = hv_fetch(GvHVn(PL_incgv),
3345                                           unixname, unixlen, 0);
3346         if ( svp ) {
3347             if (*svp != &PL_sv_undef)
3348                 RETPUSHYES;
3349             else
3350                 DIE(aTHX_ "Attempt to reload %s aborted.\n"
3351                             "Compilation failed in require", unixname);
3352         }
3353     }
3354
3355     /* prepare to compile file */
3356
3357     if (path_is_absolute(name)) {
3358         tryname = name;
3359         tryrsfp = doopen_pm(name, len);
3360     }
3361     if (!tryrsfp) {
3362         AV * const ar = GvAVn(PL_incgv);
3363         I32 i;
3364 #ifdef VMS
3365         if (vms_unixname)
3366 #endif
3367         {
3368             namesv = newSV_type(SVt_PV);
3369             for (i = 0; i <= AvFILL(ar); i++) {
3370                 SV * const dirsv = *av_fetch(ar, i, TRUE);
3371
3372                 if (SvTIED_mg((const SV *)ar, PERL_MAGIC_tied))
3373                     mg_get(dirsv);
3374                 if (SvROK(dirsv)) {
3375                     int count;
3376                     SV **svp;
3377                     SV *loader = dirsv;
3378
3379                     if (SvTYPE(SvRV(loader)) == SVt_PVAV
3380                         && !sv_isobject(loader))
3381                     {
3382                         loader = *av_fetch(MUTABLE_AV(SvRV(loader)), 0, TRUE);
3383                     }
3384
3385                     Perl_sv_setpvf(aTHX_ namesv, "/loader/0x%"UVxf"/%s",
3386                                    PTR2UV(SvRV(dirsv)), name);
3387                     tryname = SvPVX_const(namesv);
3388                     tryrsfp = NULL;
3389
3390                     ENTER_with_name("call_INC");
3391                     SAVETMPS;
3392                     EXTEND(SP, 2);
3393
3394                     PUSHMARK(SP);
3395                     PUSHs(dirsv);
3396                     PUSHs(sv);
3397                     PUTBACK;
3398                     if (sv_isobject(loader))
3399                         count = call_method("INC", G_ARRAY);
3400                     else
3401                         count = call_sv(loader, G_ARRAY);
3402                     SPAGAIN;
3403
3404                     /* Adjust file name if the hook has set an %INC entry */
3405                     svp = hv_fetch(GvHVn(PL_incgv), name, len, 0);
3406                     if (svp)
3407                         tryname = SvPV_nolen_const(*svp);
3408
3409                     if (count > 0) {
3410                         int i = 0;
3411                         SV *arg;
3412
3413                         SP -= count - 1;
3414                         arg = SP[i++];
3415
3416                         if (SvROK(arg) && (SvTYPE(SvRV(arg)) <= SVt_PVLV)
3417                             && !isGV_with_GP(SvRV(arg))) {
3418                             filter_cache = SvRV(arg);
3419                             SvREFCNT_inc_simple_void_NN(filter_cache);
3420
3421                             if (i < count) {
3422                                 arg = SP[i++];
3423                             }
3424                         }
3425
3426                         if (SvROK(arg) && isGV_with_GP(SvRV(arg))) {
3427                             arg = SvRV(arg);
3428                         }
3429
3430                         if (isGV_with_GP(arg)) {
3431                             IO * const io = GvIO((const GV *)arg);
3432
3433                             ++filter_has_file;
3434
3435                             if (io) {
3436                                 tryrsfp = IoIFP(io);
3437                                 if (IoOFP(io) && IoOFP(io) != IoIFP(io)) {
3438                                     PerlIO_close(IoOFP(io));
3439                                 }
3440                                 IoIFP(io) = NULL;
3441                                 IoOFP(io) = NULL;
3442                             }
3443
3444                             if (i < count) {
3445                                 arg = SP[i++];
3446                             }
3447                         }
3448
3449                         if (SvROK(arg) && SvTYPE(SvRV(arg)) == SVt_PVCV) {
3450                             filter_sub = arg;
3451                             SvREFCNT_inc_simple_void_NN(filter_sub);
3452
3453                             if (i < count) {
3454                                 filter_state = SP[i];
3455                                 SvREFCNT_inc_simple_void(filter_state);
3456                             }
3457                         }
3458
3459                         if (!tryrsfp && (filter_cache || filter_sub)) {
3460                             tryrsfp = PerlIO_open(BIT_BUCKET,
3461                                                   PERL_SCRIPT_MODE);
3462                         }
3463                         SP--;
3464                     }
3465
3466                     PUTBACK;
3467                     FREETMPS;
3468                     LEAVE_with_name("call_INC");
3469
3470                     if (tryrsfp) {
3471                         hook_sv = dirsv;
3472                         break;
3473                     }
3474
3475                     filter_has_file = 0;
3476                     if (filter_cache) {
3477                         SvREFCNT_dec(filter_cache);
3478                         filter_cache = NULL;
3479                     }
3480                     if (filter_state) {
3481                         SvREFCNT_dec(filter_state);
3482                         filter_state = NULL;
3483                     }
3484                     if (filter_sub) {
3485                         SvREFCNT_dec(filter_sub);
3486                         filter_sub = NULL;
3487                     }
3488                 }
3489                 else {
3490                   if (!path_is_absolute(name)
3491                   ) {
3492                     const char *dir;
3493                     STRLEN dirlen;
3494
3495                     if (SvOK(dirsv)) {
3496                         dir = SvPV_const(dirsv, dirlen);
3497                     } else {
3498                         dir = "";
3499                         dirlen = 0;
3500                     }
3501
3502 #ifdef VMS
3503                     char *unixdir;
3504                     if ((unixdir = tounixpath(dir, NULL)) == NULL)
3505                         continue;
3506                     sv_setpv(namesv, unixdir);
3507                     sv_catpv(namesv, unixname);
3508 #else
3509 #  ifdef __SYMBIAN32__
3510                     if (PL_origfilename[0] &&
3511                         PL_origfilename[1] == ':' &&
3512                         !(dir[0] && dir[1] == ':'))
3513                         Perl_sv_setpvf(aTHX_ namesv,
3514                                        "%c:%s\\%s",
3515                                        PL_origfilename[0],
3516                                        dir, name);
3517                     else
3518                         Perl_sv_setpvf(aTHX_ namesv,
3519                                        "%s\\%s",
3520                                        dir, name);
3521 #  else
3522                     /* The equivalent of
3523                        Perl_sv_setpvf(aTHX_ namesv, "%s/%s", dir, name);
3524                        but without the need to parse the format string, or
3525                        call strlen on either pointer, and with the correct
3526                        allocation up front.  */
3527                     {
3528                         char *tmp = SvGROW(namesv, dirlen + len + 2);
3529
3530                         memcpy(tmp, dir, dirlen);
3531                         tmp +=dirlen;
3532                         *tmp++ = '/';
3533                         /* name came from an SV, so it will have a '\0' at the
3534                            end that we can copy as part of this memcpy().  */
3535                         memcpy(tmp, name, len + 1);
3536
3537                         SvCUR_set(namesv, dirlen + len + 1);
3538
3539                         /* Don't even actually have to turn SvPOK_on() as we
3540                            access it directly with SvPVX() below.  */
3541                     }
3542 #  endif
3543 #endif
3544                     TAINT_PROPER("require");
3545                     tryname = SvPVX_const(namesv);
3546                     tryrsfp = doopen_pm(tryname, SvCUR(namesv));
3547                     if (tryrsfp) {
3548                         if (tryname[0] == '.' && tryname[1] == '/') {
3549                             ++tryname;
3550                             while (*++tryname == '/');
3551                         }
3552                         break;
3553                     }
3554                     else if (errno == EMFILE)
3555                         /* no point in trying other paths if out of handles */
3556                         break;
3557                   }
3558                 }
3559             }
3560         }
3561     }
3562     SAVECOPFILE_FREE(&PL_compiling);
3563     CopFILE_set(&PL_compiling, tryrsfp ? tryname : name);
3564     SvREFCNT_dec(namesv);
3565     if (!tryrsfp) {
3566         if (PL_op->op_type == OP_REQUIRE) {
3567             const char *msgstr = name;
3568             if(errno == EMFILE) {
3569                 SV * const msg
3570                     = sv_2mortal(Perl_newSVpvf(aTHX_ "%s:   %s", msgstr,
3571                                                Strerror(errno)));
3572                 msgstr = SvPV_nolen_const(msg);
3573             } else {
3574                 if (namesv) {                   /* did we lookup @INC? */
3575                     AV * const ar = GvAVn(PL_incgv);
3576                     I32 i;
3577                     SV * const msg = sv_2mortal(Perl_newSVpvf(aTHX_
3578                         "%s in @INC%s%s (@INC contains:",
3579                         msgstr,
3580                         (instr(msgstr, ".h ")
3581                          ? " (change .h to .ph maybe?)" : ""),
3582                         (instr(msgstr, ".ph ")
3583                          ? " (did you run h2ph?)" : "")
3584                                                               ));
3585
3586                     for (i = 0; i <= AvFILL(ar); i++) {
3587                         sv_catpvs(msg, " ");
3588                         sv_catsv(msg, *av_fetch(ar, i, TRUE));
3589                     }
3590                     sv_catpvs(msg, ")");
3591                     msgstr = SvPV_nolen_const(msg);
3592                 }
3593             }
3594             DIE(aTHX_ "Can't locate %s", msgstr);
3595         }
3596
3597         RETPUSHUNDEF;
3598     }
3599     else
3600         SETERRNO(0, SS_NORMAL);
3601
3602     /* Assume success here to prevent recursive requirement. */
3603     /* name is never assigned to again, so len is still strlen(name)  */
3604     /* Check whether a hook in @INC has already filled %INC */
3605     if (!hook_sv) {
3606         (void)hv_store(GvHVn(PL_incgv),
3607                        unixname, unixlen, newSVpv(CopFILE(&PL_compiling),0),0);
3608     } else {
3609         SV** const svp = hv_fetch(GvHVn(PL_incgv), unixname, unixlen, 0);
3610         if (!svp)
3611             (void)hv_store(GvHVn(PL_incgv),
3612                            unixname, unixlen, SvREFCNT_inc_simple(hook_sv), 0 );
3613     }
3614
3615     ENTER_with_name("eval");
3616     SAVETMPS;
3617     lex_start(NULL, tryrsfp, TRUE);
3618
3619     SAVEHINTS();
3620     PL_hints = 0;
3621     hv_clear(GvHV(PL_hintgv));
3622
3623     SAVECOMPILEWARNINGS();
3624     if (PL_dowarn & G_WARN_ALL_ON)
3625         PL_compiling.cop_warnings = pWARN_ALL ;
3626     else if (PL_dowarn & G_WARN_ALL_OFF)
3627         PL_compiling.cop_warnings = pWARN_NONE ;
3628     else
3629         PL_compiling.cop_warnings = pWARN_STD ;
3630
3631     if (filter_sub || filter_cache) {
3632         /* We can use the SvPV of the filter PVIO itself as our cache, rather
3633            than hanging another SV from it. In turn, filter_add() optionally
3634            takes the SV to use as the filter (or creates a new SV if passed
3635            NULL), so simply pass in whatever value filter_cache has.  */
3636         SV * const datasv = filter_add(S_run_user_filter, filter_cache);
3637         IoLINES(datasv) = filter_has_file;
3638         IoTOP_GV(datasv) = MUTABLE_GV(filter_state);
3639         IoBOTTOM_GV(datasv) = MUTABLE_GV(filter_sub);
3640     }
3641
3642     /* switch to eval mode */
3643     PUSHBLOCK(cx, CXt_EVAL, SP);
3644     PUSHEVAL(cx, name);
3645     cx->blk_eval.retop = PL_op->op_next;
3646
3647     SAVECOPLINE(&PL_compiling);
3648     CopLINE_set(&PL_compiling, 0);
3649
3650     PUTBACK;
3651
3652     /* Store and reset encoding. */
3653     encoding = PL_encoding;
3654     PL_encoding = NULL;
3655
3656     if (doeval(gimme, NULL, NULL, PL_curcop->cop_seq))
3657         op = DOCATCH(PL_eval_start);
3658     else
3659         op = PL_op->op_next;
3660
3661     /* Restore encoding. */
3662     PL_encoding = encoding;
3663
3664     return op;
3665 }
3666
3667 /* This is a op added to hold the hints hash for
3668    pp_entereval. The hash can be modified by the code
3669    being eval'ed, so we return a copy instead. */
3670
3671 PP(pp_hintseval)
3672 {
3673     dVAR;
3674     dSP;
3675     mXPUSHs(MUTABLE_SV(Perl_hv_copy_hints_hv(aTHX_ MUTABLE_HV(cSVOP_sv))));
3676     RETURN;
3677 }
3678
3679
3680 PP(pp_entereval)
3681 {
3682     dVAR; dSP;
3683     register PERL_CONTEXT *cx;
3684     SV *sv;
3685     const I32 gimme = GIMME_V;
3686     const U32 was = PL_breakable_sub_gen;
3687     char tbuf[TYPE_DIGITS(long) + 12];
3688     char *tmpbuf = tbuf;
3689     STRLEN len;
3690     CV* runcv;
3691     U32 seq;
3692     HV *saved_hh = NULL;
3693
3694     if (PL_op->op_private & OPpEVAL_HAS_HH) {
3695         saved_hh = MUTABLE_HV(SvREFCNT_inc(POPs));
3696     }
3697     sv = POPs;
3698
3699     TAINT_IF(SvTAINTED(sv));
3700     TAINT_PROPER("eval");
3701
3702     ENTER_with_name("eval");
3703     lex_start(sv, NULL, FALSE);
3704     SAVETMPS;
3705
3706     /* switch to eval mode */
3707
3708     if (PERLDB_NAMEEVAL && CopLINE(PL_curcop)) {
3709         SV * const temp_sv = sv_newmortal();
3710         Perl_sv_setpvf(aTHX_ temp_sv, "_<(eval %lu)[%s:%"IVdf"]",
3711                        (unsigned long)++PL_evalseq,
3712                        CopFILE(PL_curcop), (IV)CopLINE(PL_curcop));
3713         tmpbuf = SvPVX(temp_sv);
3714         len = SvCUR(temp_sv);
3715     }
3716     else
3717         len = my_snprintf(tmpbuf, sizeof(tbuf), "_<(eval %lu)", (unsigned long)++PL_evalseq);
3718     SAVECOPFILE_FREE(&PL_compiling);
3719     CopFILE_set(&PL_compiling, tmpbuf+2);
3720     SAVECOPLINE(&PL_compiling);
3721     CopLINE_set(&PL_compiling, 1);
3722     /* XXX For C<eval "...">s within BEGIN {} blocks, this ends up
3723        deleting the eval's FILEGV from the stash before gv_check() runs
3724        (i.e. before run-time proper). To work around the coredump that
3725        ensues, we always turn GvMULTI_on for any globals that were
3726        introduced within evals. See force_ident(). GSAR 96-10-12 */
3727     SAVEHINTS();
3728     PL_hints = PL_op->op_targ;
3729     if (saved_hh) {
3730         /* SAVEHINTS created a new HV in PL_hintgv, which we need to GC */
3731         SvREFCNT_dec(GvHV(PL_hintgv));
3732         GvHV(PL_hintgv) = saved_hh;
3733     }
3734     SAVECOMPILEWARNINGS();
3735     PL_compiling.cop_warnings = DUP_WARNINGS(PL_curcop->cop_warnings);
3736     if (PL_compiling.cop_hints_hash) {
3737         Perl_refcounted_he_free(aTHX_ PL_compiling.cop_hints_hash);
3738     }
3739     PL_compiling.cop_hints_hash = PL_curcop->cop_hints_hash;
3740     if (PL_compiling.cop_hints_hash) {
3741         HINTS_REFCNT_LOCK;
3742         PL_compiling.cop_hints_hash->refcounted_he_refcnt++;
3743         HINTS_REFCNT_UNLOCK;
3744     }
3745     /* special case: an eval '' executed within the DB package gets lexically
3746      * placed in the first non-DB CV rather than the current CV - this
3747      * allows the debugger to execute code, find lexicals etc, in the
3748      * scope of the code being debugged. Passing &seq gets find_runcv
3749      * to do the dirty work for us */
3750     runcv = find_runcv(&seq);
3751
3752     PUSHBLOCK(cx, (CXt_EVAL|CXp_REAL), SP);
3753     PUSHEVAL(cx, 0);
3754     cx->blk_eval.retop = PL_op->op_next;
3755
3756     /* prepare to compile string */
3757
3758     if ((PERLDB_LINE || PERLDB_SAVESRC) && PL_curstash != PL_debstash)
3759         save_lines(CopFILEAV(&PL_compiling), PL_parser->linestr);
3760     PUTBACK;
3761
3762     if (doeval(gimme, NULL, runcv, seq)) {
3763         if (was != PL_breakable_sub_gen /* Some subs defined here. */
3764             ? (PERLDB_LINE || PERLDB_SAVESRC)
3765             :  PERLDB_SAVESRC_NOSUBS) {
3766             /* Retain the filegv we created.  */
3767         } else {
3768             char *const safestr = savepvn(tmpbuf, len);
3769             SAVEDELETE(PL_defstash, safestr, len);
3770         }
3771         return DOCATCH(PL_eval_start);
3772     } else {
3773         /* We have already left the scope set up earler thanks to the LEAVE
3774            in doeval().  */
3775         if (was != PL_breakable_sub_gen /* Some subs defined here. */
3776             ? (PERLDB_LINE || PERLDB_SAVESRC)
3777             :  PERLDB_SAVESRC_INVALID) {
3778             /* Retain the filegv we created.  */
3779         } else {
3780             (void)hv_delete(PL_defstash, tmpbuf, len, G_DISCARD);
3781         }
3782         return PL_op->op_next;
3783     }
3784 }
3785
3786 PP(pp_leaveeval)
3787 {
3788     dVAR; dSP;
3789     register SV **mark;
3790     SV **newsp;
3791     PMOP *newpm;
3792     I32 gimme;
3793     register PERL_CONTEXT *cx;
3794     OP *retop;
3795     const U8 save_flags = PL_op -> op_flags;
3796     I32 optype;
3797
3798     POPBLOCK(cx,newpm);
3799     POPEVAL(cx);
3800     retop = cx->blk_eval.retop;
3801
3802     TAINT_NOT;
3803     if (gimme == G_VOID)
3804         MARK = newsp;
3805     else if (gimme == G_SCALAR) {
3806         MARK = newsp + 1;
3807         if (MARK <= SP) {
3808             if (SvFLAGS(TOPs) & SVs_TEMP)
3809                 *MARK = TOPs;
3810             else
3811                 *MARK = sv_mortalcopy(TOPs);
3812         }
3813         else {
3814             MEXTEND(mark,0);
3815             *MARK = &PL_sv_undef;
3816         }
3817         SP = MARK;
3818     }
3819     else {
3820         /* in case LEAVE wipes old return values */
3821         for (mark = newsp + 1; mark <= SP; mark++) {
3822             if (!(SvFLAGS(*mark) & SVs_TEMP)) {
3823                 *mark = sv_mortalcopy(*mark);
3824                 TAINT_NOT;      /* Each item is independent */
3825             }
3826         }
3827     }
3828     PL_curpm = newpm;   /* Don't pop $1 et al till now */
3829
3830 #ifdef DEBUGGING
3831     assert(CvDEPTH(PL_compcv) == 1);
3832 #endif
3833     CvDEPTH(PL_compcv) = 0;
3834     lex_end();
3835
3836     if (optype == OP_REQUIRE &&
3837         !(gimme == G_SCALAR ? SvTRUE(*SP) : SP > newsp))
3838     {
3839         /* Unassume the success we assumed earlier. */
3840         SV * const nsv = cx->blk_eval.old_namesv;
3841         (void)hv_delete(GvHVn(PL_incgv), SvPVX_const(nsv), SvCUR(nsv), G_DISCARD);
3842         retop = Perl_die(aTHX_ "%"SVf" did not return a true value", SVfARG(nsv));
3843         /* die_where() did LEAVE, or we won't be here */
3844     }
3845     else {
3846         LEAVE_with_name("eval");
3847         if (!(save_flags & OPf_SPECIAL)) {
3848             CLEAR_ERRSV();
3849         }
3850     }
3851
3852     RETURNOP(retop);
3853 }
3854
3855 /* Common code for Perl_call_sv and Perl_fold_constants, put here to keep it
3856    close to the related Perl_create_eval_scope.  */
3857 void
3858 Perl_delete_eval_scope(pTHX)
3859 {
3860     SV **newsp;
3861     PMOP *newpm;
3862     I32 gimme;
3863     register PERL_CONTEXT *cx;
3864     I32 optype;
3865
3866     POPBLOCK(cx,newpm);
3867     POPEVAL(cx);
3868     PL_curpm = newpm;
3869     LEAVE_with_name("eval_scope");
3870     PERL_UNUSED_VAR(newsp);
3871     PERL_UNUSED_VAR(gimme);
3872     PERL_UNUSED_VAR(optype);
3873 }
3874
3875 /* Common-ish code salvaged from Perl_call_sv and pp_entertry, because it was
3876    also needed by Perl_fold_constants.  */
3877 PERL_CONTEXT *
3878 Perl_create_eval_scope(pTHX_ U32 flags)
3879 {
3880     PERL_CONTEXT *cx;
3881     const I32 gimme = GIMME_V;
3882
3883     ENTER_with_name("eval_scope");
3884     SAVETMPS;
3885
3886     PUSHBLOCK(cx, (CXt_EVAL|CXp_TRYBLOCK), PL_stack_sp);
3887     PUSHEVAL(cx, 0);
3888
3889     PL_in_eval = EVAL_INEVAL;
3890     if (flags & G_KEEPERR)
3891         PL_in_eval |= EVAL_KEEPERR;
3892     else
3893         CLEAR_ERRSV();
3894     if (flags & G_FAKINGEVAL) {
3895         PL_eval_root = PL_op; /* Only needed so that goto works right. */
3896     }
3897     return cx;
3898 }
3899
3900 PP(pp_entertry)
3901 {
3902     dVAR;
3903     PERL_CONTEXT * const cx = create_eval_scope(0);
3904     cx->blk_eval.retop = cLOGOP->op_other->op_next;
3905     return DOCATCH(PL_op->op_next);
3906 }
3907
3908 PP(pp_leavetry)
3909 {
3910     dVAR; dSP;
3911     SV **newsp;
3912     PMOP *newpm;
3913     I32 gimme;
3914     register PERL_CONTEXT *cx;
3915     I32 optype;
3916
3917     POPBLOCK(cx,newpm);
3918     POPEVAL(cx);
3919     PERL_UNUSED_VAR(optype);
3920
3921     TAINT_NOT;
3922     if (gimme == G_VOID)
3923         SP = newsp;
3924     else if (gimme == G_SCALAR) {
3925         register SV **mark;
3926         MARK = newsp + 1;
3927         if (MARK <= SP) {
3928             if (SvFLAGS(TOPs) & (SVs_PADTMP|SVs_TEMP))
3929                 *MARK = TOPs;
3930             else
3931                 *MARK = sv_mortalcopy(TOPs);
3932         }
3933         else {
3934             MEXTEND(mark,0);
3935             *MARK = &PL_sv_undef;
3936         }
3937         SP = MARK;
3938     }
3939     else {
3940         /* in case LEAVE wipes old return values */
3941         register SV **mark;
3942         for (mark = newsp + 1; mark <= SP; mark++) {
3943             if (!(SvFLAGS(*mark) & (SVs_PADTMP|SVs_TEMP))) {
3944                 *mark = sv_mortalcopy(*mark);
3945                 TAINT_NOT;      /* Each item is independent */
3946             }
3947         }
3948     }
3949     PL_curpm = newpm;   /* Don't pop $1 et al till now */
3950
3951     LEAVE_with_name("eval_scope");
3952     CLEAR_ERRSV();
3953     RETURN;
3954 }
3955
3956 PP(pp_entergiven)
3957 {
3958     dVAR; dSP;
3959     register PERL_CONTEXT *cx;
3960     const I32 gimme = GIMME_V;
3961
3962     ENTER_with_name("given");
3963     SAVETMPS;
3964
3965     sv_setsv(PAD_SV(PL_op->op_targ), POPs);
3966
3967     PUSHBLOCK(cx, CXt_GIVEN, SP);
3968     PUSHGIVEN(cx);
3969
3970     RETURN;
3971 }
3972
3973 PP(pp_leavegiven)
3974 {
3975     dVAR; dSP;
3976     register PERL_CONTEXT *cx;
3977     I32 gimme;
3978     SV **newsp;
3979     PMOP *newpm;
3980     PERL_UNUSED_CONTEXT;
3981
3982     POPBLOCK(cx,newpm);
3983     assert(CxTYPE(cx) == CXt_GIVEN);
3984
3985     SP = newsp;
3986     PUTBACK;
3987
3988     PL_curpm = newpm;   /* pop $1 et al */
3989
3990     LEAVE_with_name("given");
3991
3992     return NORMAL;
3993 }
3994
3995 /* Helper routines used by pp_smartmatch */
3996 STATIC PMOP *
3997 S_make_matcher(pTHX_ REGEXP *re)
3998 {
3999     dVAR;
4000     PMOP *matcher = (PMOP *) newPMOP(OP_MATCH, OPf_WANT_SCALAR | OPf_STACKED);
4001
4002     PERL_ARGS_ASSERT_MAKE_MATCHER;
4003
4004     PM_SETRE(matcher, ReREFCNT_inc(re));
4005
4006     SAVEFREEOP((OP *) matcher);
4007     ENTER_with_name("matcher"); SAVETMPS;
4008     SAVEOP();
4009     return matcher;
4010 }
4011
4012 STATIC bool
4013 S_matcher_matches_sv(pTHX_ PMOP *matcher, SV *sv)
4014 {
4015     dVAR;
4016     dSP;
4017
4018     PERL_ARGS_ASSERT_MATCHER_MATCHES_SV;
4019
4020     PL_op = (OP *) matcher;
4021     XPUSHs(sv);
4022     PUTBACK;
4023     (void) pp_match();
4024     SPAGAIN;
4025     return (SvTRUEx(POPs));
4026 }
4027
4028 STATIC void
4029 S_destroy_matcher(pTHX_ PMOP *matcher)
4030 {
4031     dVAR;
4032
4033     PERL_ARGS_ASSERT_DESTROY_MATCHER;
4034     PERL_UNUSED_ARG(matcher);
4035
4036     FREETMPS;
4037     LEAVE_with_name("matcher");
4038 }
4039
4040 /* Do a smart match */
4041 PP(pp_smartmatch)
4042 {
4043     DEBUG_M(Perl_deb(aTHX_ "Starting smart match resolution\n"));
4044     return do_smartmatch(NULL, NULL);
4045 }
4046
4047 /* This version of do_smartmatch() implements the
4048  * table of smart matches that is found in perlsyn.
4049  */
4050 STATIC OP *
4051 S_do_smartmatch(pTHX_ HV *seen_this, HV *seen_other)
4052 {
4053     dVAR;
4054     dSP;
4055
4056     bool object_on_left = FALSE;
4057     SV *e = TOPs;       /* e is for 'expression' */
4058     SV *d = TOPm1s;     /* d is for 'default', as in PL_defgv */
4059
4060     /* First of all, handle overload magic of the rightmost argument */
4061     if (SvAMAGIC(e)) {
4062         SV * tmpsv;
4063         DEBUG_M(Perl_deb(aTHX_ "    applying rule Any-Object\n"));
4064         DEBUG_M(Perl_deb(aTHX_ "        attempting overload\n"));
4065
4066         tmpsv = amagic_call(d, e, smart_amg, 0);
4067         if (tmpsv) {
4068             SPAGAIN;
4069             (void)POPs;
4070             SETs(tmpsv);
4071             RETURN;
4072         }
4073         DEBUG_M(Perl_deb(aTHX_ "        failed to run overload method; continuing...\n"));
4074     }
4075
4076     SP -= 2;    /* Pop the values */
4077
4078     /* Take care only to invoke mg_get() once for each argument.
4079      * Currently we do this by copying the SV if it's magical. */
4080     if (d) {
4081         if (SvGMAGICAL(d))
4082             d = sv_mortalcopy(d);
4083     }
4084     else
4085         d = &PL_sv_undef;
4086
4087     assert(e);
4088     if (SvGMAGICAL(e))
4089         e = sv_mortalcopy(e);
4090
4091     /* ~~ undef */
4092     if (!SvOK(e)) {
4093         DEBUG_M(Perl_deb(aTHX_ "    applying rule Any-undef\n"));
4094         if (SvOK(d))
4095             RETPUSHNO;
4096         else
4097             RETPUSHYES;
4098     }
4099
4100     if (sv_isobject(e) && (SvTYPE(SvRV(e)) != SVt_REGEXP)) {
4101         DEBUG_M(Perl_deb(aTHX_ "    applying rule Any-Object\n"));
4102         Perl_croak(aTHX_ "Smart matching a non-overloaded object breaks encapsulation");
4103     }
4104     if (sv_isobject(d) && (SvTYPE(SvRV(d)) != SVt_REGEXP))
4105         object_on_left = TRUE;
4106
4107     /* ~~ sub */
4108     if (SvROK(e) && SvTYPE(SvRV(e)) == SVt_PVCV) {
4109         I32 c;
4110         if (object_on_left) {
4111             goto sm_any_sub; /* Treat objects like scalars */
4112         }
4113         else if (SvROK(d) && SvTYPE(SvRV(d)) == SVt_PVHV) {
4114             /* Test sub truth for each key */
4115             HE *he;
4116             bool andedresults = TRUE;
4117             HV *hv = (HV*) SvRV(d);
4118             I32 numkeys = hv_iterinit(hv);
4119             DEBUG_M(Perl_deb(aTHX_ "    applying rule Hash-CodeRef\n"));
4120             if (numkeys == 0)
4121                 RETPUSHYES;
4122             while ( (he = hv_iternext(hv)) ) {
4123                 DEBUG_M(Perl_deb(aTHX_ "        testing hash key...\n"));
4124                 ENTER_with_name("smartmatch_hash_key_test");
4125                 SAVETMPS;
4126                 PUSHMARK(SP);
4127                 PUSHs(hv_iterkeysv(he));
4128                 PUTBACK;
4129                 c = call_sv(e, G_SCALAR);
4130                 SPAGAIN;
4131                 if (c == 0)
4132                     andedresults = FALSE;
4133                 else
4134                     andedresults = SvTRUEx(POPs) && andedresults;
4135                 FREETMPS;
4136                 LEAVE_with_name("smartmatch_hash_key_test");
4137             }
4138             if (andedresults)
4139                 RETPUSHYES;
4140             else
4141                 RETPUSHNO;
4142         }
4143         else if (SvROK(d) && SvTYPE(SvRV(d)) == SVt_PVAV) {
4144             /* Test sub truth for each element */
4145             I32 i;
4146             bool andedresults = TRUE;
4147             AV *av = (AV*) SvRV(d);
4148             const I32 len = av_len(av);
4149             DEBUG_M(Perl_deb(aTHX_ "    applying rule Array-CodeRef\n"));
4150             if (len == -1)
4151                 RETPUSHYES;
4152             for (i = 0; i <= len; ++i) {
4153                 SV * const * const svp = av_fetch(av, i, FALSE);
4154                 DEBUG_M(Perl_deb(aTHX_ "        testing array element...\n"));
4155                 ENTER_with_name("smartmatch_array_elem_test");
4156                 SAVETMPS;
4157                 PUSHMARK(SP);
4158                 if (svp)
4159                     PUSHs(*svp);
4160                 PUTBACK;
4161                 c = call_sv(e, G_SCALAR);
4162                 SPAGAIN;
4163                 if (c == 0)
4164                     andedresults = FALSE;
4165                 else
4166                     andedresults = SvTRUEx(POPs) && andedresults;
4167                 FREETMPS;
4168                 LEAVE_with_name("smartmatch_array_elem_test");
4169             }
4170             if (andedresults)
4171                 RETPUSHYES;
4172             else
4173                 RETPUSHNO;
4174         }
4175         else {
4176           sm_any_sub:
4177             DEBUG_M(Perl_deb(aTHX_ "    applying rule Any-CodeRef\n"));
4178             ENTER_with_name("smartmatch_coderef");
4179             SAVETMPS;
4180             PUSHMARK(SP);
4181             PUSHs(d);
4182             PUTBACK;
4183             c = call_sv(e, G_SCALAR);
4184             SPAGAIN;
4185             if (c == 0)
4186                 PUSHs(&PL_sv_no);
4187             else if (SvTEMP(TOPs))
4188                 SvREFCNT_inc_void(TOPs);
4189             FREETMPS;
4190             LEAVE_with_name("smartmatch_coderef");
4191             RETURN;
4192         }
4193     }
4194     /* ~~ %hash */
4195     else if (SvROK(e) && SvTYPE(SvRV(e)) == SVt_PVHV) {
4196         if (object_on_left) {
4197             goto sm_any_hash; /* Treat objects like scalars */
4198         }
4199         else if (!SvOK(d)) {
4200             DEBUG_M(Perl_deb(aTHX_ "    applying rule Any-Hash ($a undef)\n"));
4201             RETPUSHNO;
4202         }
4203         else if (SvROK(d) && SvTYPE(SvRV(d)) == SVt_PVHV) {
4204             /* Check that the key-sets are identical */
4205             HE *he;
4206             HV *other_hv = MUTABLE_HV(SvRV(d));
4207             bool tied = FALSE;
4208             bool other_tied = FALSE;
4209             U32 this_key_count  = 0,
4210                 other_key_count = 0;
4211             HV *hv = MUTABLE_HV(SvRV(e));
4212
4213             DEBUG_M(Perl_deb(aTHX_ "    applying rule Hash-Hash\n"));
4214             /* Tied hashes don't know how many keys they have. */
4215             if (SvTIED_mg((SV*)hv, PERL_MAGIC_tied)) {
4216                 tied = TRUE;
4217             }
4218             else if (SvTIED_mg((const SV *)other_hv, PERL_MAGIC_tied)) {
4219                 HV * const temp = other_hv;
4220                 other_hv = hv;
4221                 hv = temp;
4222                 tied = TRUE;
4223             }
4224             if (SvTIED_mg((const SV *)other_hv, PERL_MAGIC_tied))
4225                 other_tied = TRUE;
4226
4227             if (!tied && HvUSEDKEYS((const HV *) hv) != HvUSEDKEYS(other_hv))
4228                 RETPUSHNO;
4229
4230             /* The hashes have the same number of keys, so it suffices
4231                to check that one is a subset of the other. */
4232             (void) hv_iterinit(hv);
4233             while ( (he = hv_iternext(hv)) ) {
4234                 SV *key = hv_iterkeysv(he);
4235
4236                 DEBUG_M(Perl_deb(aTHX_ "        comparing hash key...\n"));
4237                 ++ this_key_count;
4238
4239                 if(!hv_exists_ent(other_hv, key, 0)) {
4240                     (void) hv_iterinit(hv);     /* reset iterator */
4241                     RETPUSHNO;
4242                 }
4243             }
4244
4245             if (other_tied) {
4246                 (void) hv_iterinit(other_hv);
4247                 while ( hv_iternext(other_hv) )
4248                     ++other_key_count;
4249             }
4250             else
4251                 other_key_count = HvUSEDKEYS(other_hv);
4252
4253             if (this_key_count != other_key_count)
4254                 RETPUSHNO;
4255             else
4256                 RETPUSHYES;
4257         }
4258         else if (SvROK(d) && SvTYPE(SvRV(d)) == SVt_PVAV) {
4259             AV * const other_av = MUTABLE_AV(SvRV(d));
4260             const I32 other_len = av_len(other_av) + 1;
4261             I32 i;
4262             HV *hv = MUTABLE_HV(SvRV(e));
4263
4264             DEBUG_M(Perl_deb(aTHX_ "    applying rule Array-Hash\n"));
4265             for (i = 0; i < other_len; ++i) {
4266                 SV ** const svp = av_fetch(other_av, i, FALSE);
4267                 DEBUG_M(Perl_deb(aTHX_ "        checking for key existence...\n"));
4268                 if (svp) {      /* ??? When can this not happen? */
4269                     if (hv_exists_ent(hv, *svp, 0))
4270                         RETPUSHYES;
4271                 }
4272             }
4273             RETPUSHNO;
4274         }
4275         else if (SvROK(d) && SvTYPE(SvRV(d)) == SVt_REGEXP) {
4276             DEBUG_M(Perl_deb(aTHX_ "    applying rule Regex-Hash\n"));
4277           sm_regex_hash:
4278             {
4279                 PMOP * const matcher = make_matcher((REGEXP*) SvRV(d));
4280                 HE *he;
4281                 HV *hv = MUTABLE_HV(SvRV(e));
4282
4283                 (void) hv_iterinit(hv);
4284                 while ( (he = hv_iternext(hv)) ) {
4285                     DEBUG_M(Perl_deb(aTHX_ "        testing key against pattern...\n"));
4286                     if (matcher_matches_sv(matcher, hv_iterkeysv(he))) {
4287                         (void) hv_iterinit(hv);
4288                         destroy_matcher(matcher);
4289                         RETPUSHYES;
4290                     }
4291                 }
4292                 destroy_matcher(matcher);
4293                 RETPUSHNO;
4294             }
4295         }
4296         else {
4297           sm_any_hash:
4298             DEBUG_M(Perl_deb(aTHX_ "    applying rule Any-Hash\n"));
4299             if (hv_exists_ent(MUTABLE_HV(SvRV(e)), d, 0))
4300                 RETPUSHYES;
4301             else
4302                 RETPUSHNO;
4303         }
4304     }
4305     /* ~~ @array */
4306     else if (SvROK(e) && SvTYPE(SvRV(e)) == SVt_PVAV) {
4307         if (object_on_left) {
4308             goto sm_any_array; /* Treat objects like scalars */
4309         }
4310         else if (SvROK(d) && SvTYPE(SvRV(d)) == SVt_PVHV) {
4311             AV * const other_av = MUTABLE_AV(SvRV(e));
4312             const I32 other_len = av_len(other_av) + 1;
4313             I32 i;
4314
4315             DEBUG_M(Perl_deb(aTHX_ "    applying rule Hash-Array\n"));
4316             for (i = 0; i < other_len; ++i) {
4317                 SV ** const svp = av_fetch(other_av, i, FALSE);
4318
4319                 DEBUG_M(Perl_deb(aTHX_ "        testing for key existence...\n"));
4320                 if (svp) {      /* ??? When can this not happen? */
4321                     if (hv_exists_ent(MUTABLE_HV(SvRV(d)), *svp, 0))
4322                         RETPUSHYES;
4323                 }
4324             }
4325             RETPUSHNO;
4326         }
4327         if (SvROK(d) && SvTYPE(SvRV(d)) == SVt_PVAV) {
4328             AV *other_av = MUTABLE_AV(SvRV(d));
4329             DEBUG_M(Perl_deb(aTHX_ "    applying rule Array-Array\n"));
4330             if (av_len(MUTABLE_AV(SvRV(e))) != av_len(other_av))
4331                 RETPUSHNO;
4332             else {
4333                 I32 i;
4334                 const I32 other_len = av_len(other_av);
4335
4336                 if (NULL == seen_this) {
4337                     seen_this = newHV();
4338                     (void) sv_2mortal(MUTABLE_SV(seen_this));
4339                 }
4340                 if (NULL == seen_other) {
4341                     seen_other = newHV();
4342                     (void) sv_2mortal(MUTABLE_SV(seen_other));
4343                 }
4344                 for(i = 0; i <= other_len; ++i) {
4345                     SV * const * const this_elem = av_fetch(MUTABLE_AV(SvRV(e)), i, FALSE);
4346                     SV * const * const other_elem = av_fetch(other_av, i, FALSE);
4347
4348                     if (!this_elem || !other_elem) {
4349                         if ((this_elem && SvOK(*this_elem))
4350                                 || (other_elem && SvOK(*other_elem)))
4351                             RETPUSHNO;
4352                     }
4353                     else if (hv_exists_ent(seen_this,
4354                                 sv_2mortal(newSViv(PTR2IV(*this_elem))), 0) ||
4355                             hv_exists_ent(seen_other,
4356                                 sv_2mortal(newSViv(PTR2IV(*other_elem))), 0))
4357                     {
4358                         if (*this_elem != *other_elem)
4359                             RETPUSHNO;
4360                     }
4361                     else {
4362                         (void)hv_store_ent(seen_this,
4363                                 sv_2mortal(newSViv(PTR2IV(*this_elem))),
4364                                 &PL_sv_undef, 0);
4365                         (void)hv_store_ent(seen_other,
4366                                 sv_2mortal(newSViv(PTR2IV(*other_elem))),
4367                                 &PL_sv_undef, 0);
4368                         PUSHs(*other_elem);
4369                         PUSHs(*this_elem);
4370
4371                         PUTBACK;
4372                         DEBUG_M(Perl_deb(aTHX_ "        recursively comparing array element...\n"));
4373                         (void) do_smartmatch(seen_this, seen_other);
4374                         SPAGAIN;
4375                         DEBUG_M(Perl_deb(aTHX_ "        recursion finished\n"));
4376
4377                         if (!SvTRUEx(POPs))
4378                             RETPUSHNO;
4379                     }
4380                 }
4381                 RETPUSHYES;
4382             }
4383         }
4384         else if (SvROK(d) && SvTYPE(SvRV(d)) == SVt_REGEXP) {
4385             DEBUG_M(Perl_deb(aTHX_ "    applying rule Regex-Array\n"));
4386           sm_regex_array:
4387             {
4388                 PMOP * const matcher = make_matcher((REGEXP*) SvRV(d));
4389                 const I32 this_len = av_len(MUTABLE_AV(SvRV(e)));
4390                 I32 i;
4391
4392                 for(i = 0; i <= this_len; ++i) {
4393                     SV * const * const svp = av_fetch(MUTABLE_AV(SvRV(e)), i, FALSE);
4394                     DEBUG_M(Perl_deb(aTHX_ "        testing element against pattern...\n"));
4395                     if (svp && matcher_matches_sv(matcher, *svp)) {
4396                         destroy_matcher(matcher);
4397                         RETPUSHYES;
4398                     }
4399                 }
4400                 destroy_matcher(matcher);
4401                 RETPUSHNO;
4402             }
4403         }
4404         else if (!SvOK(d)) {
4405             /* undef ~~ array */
4406             const I32 this_len = av_len(MUTABLE_AV(SvRV(e)));
4407             I32 i;
4408
4409             DEBUG_M(Perl_deb(aTHX_ "    applying rule Undef-Array\n"));
4410             for (i = 0; i <= this_len; ++i) {
4411                 SV * const * const svp = av_fetch(MUTABLE_AV(SvRV(e)), i, FALSE);
4412                 DEBUG_M(Perl_deb(aTHX_ "        testing for undef element...\n"));
4413                 if (!svp || !SvOK(*svp))
4414                     RETPUSHYES;
4415             }
4416             RETPUSHNO;
4417         }
4418         else {
4419           sm_any_array:
4420             {
4421                 I32 i;
4422                 const I32 this_len = av_len(MUTABLE_AV(SvRV(e)));
4423
4424                 DEBUG_M(Perl_deb(aTHX_ "    applying rule Any-Array\n"));
4425                 for (i = 0; i <= this_len; ++i) {
4426                     SV * const * const svp = av_fetch(MUTABLE_AV(SvRV(e)), i, FALSE);
4427                     if (!svp)
4428                         continue;
4429
4430                     PUSHs(d);
4431                     PUSHs(*svp);
4432                     PUTBACK;
4433                     /* infinite recursion isn't supposed to happen here */
4434                     DEBUG_M(Perl_deb(aTHX_ "        recursively testing array element...\n"));
4435                     (void) do_smartmatch(NULL, NULL);
4436                     SPAGAIN;
4437                     DEBUG_M(Perl_deb(aTHX_ "        recursion finished\n"));
4438                     if (SvTRUEx(POPs))
4439                         RETPUSHYES;
4440                 }
4441                 RETPUSHNO;
4442             }
4443         }
4444     }
4445     /* ~~ qr// */
4446     else if (SvROK(e) && SvTYPE(SvRV(e)) == SVt_REGEXP) {
4447         if (!object_on_left && SvROK(d) && SvTYPE(SvRV(d)) == SVt_PVHV) {
4448             SV *t = d; d = e; e = t;
4449             DEBUG_M(Perl_deb(aTHX_ "    applying rule Hash-Regex\n"));
4450             goto sm_regex_hash;
4451         }
4452         else if (!object_on_left && SvROK(d) && SvTYPE(SvRV(d)) == SVt_PVAV) {
4453             SV *t = d; d = e; e = t;
4454             DEBUG_M(Perl_deb(aTHX_ "    applying rule Array-Regex\n"));
4455             goto sm_regex_array;
4456         }
4457         else {
4458             PMOP * const matcher = make_matcher((REGEXP*) SvRV(e));
4459
4460             DEBUG_M(Perl_deb(aTHX_ "    applying rule Any-Regex\n"));
4461             PUTBACK;
4462             PUSHs(matcher_matches_sv(matcher, d)
4463                     ? &PL_sv_yes
4464                     : &PL_sv_no);
4465             destroy_matcher(matcher);
4466             RETURN;
4467         }
4468     }
4469     /* ~~ scalar */
4470     /* See if there is overload magic on left */
4471     else if (object_on_left && SvAMAGIC(d)) {
4472         SV *tmpsv;
4473         DEBUG_M(Perl_deb(aTHX_ "    applying rule Object-Any\n"));
4474         DEBUG_M(Perl_deb(aTHX_ "        attempting overload\n"));
4475         PUSHs(d); PUSHs(e);
4476         PUTBACK;
4477         tmpsv = amagic_call(d, e, smart_amg, AMGf_noright);
4478         if (tmpsv) {
4479             SPAGAIN;
4480             (void)POPs;
4481             SETs(tmpsv);
4482             RETURN;
4483         }
4484         SP -= 2;
4485         DEBUG_M(Perl_deb(aTHX_ "        failed to run overload method; falling back...\n"));
4486         goto sm_any_scalar;
4487     }
4488     else if (!SvOK(d)) {
4489         /* undef ~~ scalar ; we already know that the scalar is SvOK */
4490         DEBUG_M(Perl_deb(aTHX_ "    applying rule undef-Any\n"));
4491         RETPUSHNO;
4492     }
4493     else
4494   sm_any_scalar:
4495     if (SvNIOK(e) || (SvPOK(e) && looks_like_number(e) && SvNIOK(d))) {
4496         DEBUG_M(if (SvNIOK(e))
4497                     Perl_deb(aTHX_ "    applying rule Any-Num\n");
4498                 else
4499                     Perl_deb(aTHX_ "    applying rule Num-numish\n");
4500         );
4501         /* numeric comparison */
4502         PUSHs(d); PUSHs(e);
4503         PUTBACK;
4504         if (CopHINTS_get(PL_curcop) & HINT_INTEGER)
4505             (void) pp_i_eq();
4506         else
4507             (void) pp_eq();
4508         SPAGAIN;
4509         if (SvTRUEx(POPs))
4510             RETPUSHYES;
4511         else
4512             RETPUSHNO;
4513     }
4514
4515     /* As a last resort, use string comparison */
4516     DEBUG_M(Perl_deb(aTHX_ "    applying rule Any-Any\n"));
4517     PUSHs(d); PUSHs(e);
4518     PUTBACK;
4519     return pp_seq();
4520 }
4521
4522 PP(pp_enterwhen)
4523 {
4524     dVAR; dSP;
4525     register PERL_CONTEXT *cx;
4526     const I32 gimme = GIMME_V;
4527
4528     /* This is essentially an optimization: if the match
4529        fails, we don't want to push a context and then
4530        pop it again right away, so we skip straight
4531        to the op that follows the leavewhen.
4532     */
4533     if ((0 == (PL_op->op_flags & OPf_SPECIAL)) && !SvTRUEx(POPs))
4534         return cLOGOP->op_other->op_next;
4535
4536     ENTER_with_name("eval");
4537     SAVETMPS;
4538
4539     PUSHBLOCK(cx, CXt_WHEN, SP);
4540     PUSHWHEN(cx);
4541
4542     RETURN;
4543 }
4544
4545 PP(pp_leavewhen)
4546 {
4547     dVAR; dSP;
4548     register PERL_CONTEXT *cx;
4549     I32 gimme;
4550     SV **newsp;
4551     PMOP *newpm;
4552
4553     POPBLOCK(cx,newpm);
4554     assert(CxTYPE(cx) == CXt_WHEN);
4555
4556     SP = newsp;
4557     PUTBACK;
4558
4559     PL_curpm = newpm;   /* pop $1 et al */
4560
4561     LEAVE_with_name("eval");
4562     return NORMAL;
4563 }
4564
4565 PP(pp_continue)
4566 {
4567     dVAR;
4568     I32 cxix;
4569     register PERL_CONTEXT *cx;
4570     I32 inner;
4571
4572     cxix = dopoptowhen(cxstack_ix);
4573     if (cxix < 0)
4574         DIE(aTHX_ "Can't \"continue\" outside a when block");
4575     if (cxix < cxstack_ix)
4576         dounwind(cxix);
4577
4578     /* clear off anything above the scope we're re-entering */
4579     inner = PL_scopestack_ix;
4580     TOPBLOCK(cx);
4581     if (PL_scopestack_ix < inner)
4582         leave_scope(PL_scopestack[PL_scopestack_ix]);
4583     PL_curcop = cx->blk_oldcop;
4584     return cx->blk_givwhen.leave_op;
4585 }
4586
4587 PP(pp_break)
4588 {
4589     dVAR;
4590     I32 cxix;
4591     register PERL_CONTEXT *cx;
4592     I32 inner;
4593
4594     cxix = dopoptogiven(cxstack_ix);
4595     if (cxix < 0) {
4596         if (PL_op->op_flags & OPf_SPECIAL)
4597             DIE(aTHX_ "Can't use when() outside a topicalizer");
4598         else
4599             DIE(aTHX_ "Can't \"break\" outside a given block");
4600     }
4601     if (CxFOREACH(&cxstack[cxix]) && (0 == (PL_op->op_flags & OPf_SPECIAL)))
4602         DIE(aTHX_ "Can't \"break\" in a loop topicalizer");
4603
4604     if (cxix < cxstack_ix)
4605         dounwind(cxix);
4606
4607     /* clear off anything above the scope we're re-entering */
4608     inner = PL_scopestack_ix;
4609     TOPBLOCK(cx);
4610     if (PL_scopestack_ix < inner)
4611         leave_scope(PL_scopestack[PL_scopestack_ix]);
4612     PL_curcop = cx->blk_oldcop;
4613
4614     if (CxFOREACH(cx))
4615         return CX_LOOP_NEXTOP_GET(cx);
4616     else
4617         return cx->blk_givwhen.leave_op;
4618 }
4619
4620 STATIC OP *
4621 S_doparseform(pTHX_ SV *sv)
4622 {
4623     STRLEN len;
4624     register char *s = SvPV_force(sv, len);
4625     register char * const send = s + len;
4626     register char *base = NULL;
4627     register I32 skipspaces = 0;
4628     bool noblank   = FALSE;
4629     bool repeat    = FALSE;
4630     bool postspace = FALSE;
4631     U32 *fops;
4632     register U32 *fpc;
4633     U32 *linepc = NULL;
4634     register I32 arg;
4635     bool ischop;
4636     bool unchopnum = FALSE;
4637     int maxops = 12; /* FF_LINEMARK + FF_END + 10 (\0 without preceding \n) */
4638
4639     PERL_ARGS_ASSERT_DOPARSEFORM;
4640
4641     if (len == 0)
4642         Perl_croak(aTHX_ "Null picture in formline");
4643
4644     /* estimate the buffer size needed */
4645     for (base = s; s <= send; s++) {
4646         if (*s == '\n' || *s == '@' || *s == '^')
4647             maxops += 10;
4648     }
4649     s = base;
4650     base = NULL;
4651
4652     Newx(fops, maxops, U32);
4653     fpc = fops;
4654
4655     if (s < send) {
4656         linepc = fpc;
4657         *fpc++ = FF_LINEMARK;
4658         noblank = repeat = FALSE;
4659         base = s;
4660     }
4661
4662     while (s <= send) {
4663         switch (*s++) {
4664         default:
4665             skipspaces = 0;
4666             continue;
4667
4668         case '~':
4669             if (*s == '~') {
4670                 repeat = TRUE;
4671                 *s = ' ';
4672             }
4673             noblank = TRUE;
4674             s[-1] = ' ';
4675             /* FALL THROUGH */
4676         case ' ': case '\t':
4677             skipspaces++;
4678             continue;
4679         case 0:
4680             if (s < send) {
4681                 skipspaces = 0;
4682                 continue;
4683             } /* else FALL THROUGH */
4684         case '\n':
4685             arg = s - base;
4686             skipspaces++;
4687             arg -= skipspaces;
4688             if (arg) {
4689                 if (postspace)
4690                     *fpc++ = FF_SPACE;
4691                 *fpc++ = FF_LITERAL;
4692                 *fpc++ = (U16)arg;
4693             }
4694             postspace = FALSE;
4695             if (s <= send)
4696                 skipspaces--;
4697             if (skipspaces) {
4698                 *fpc++ = FF_SKIP;
4699                 *fpc++ = (U16)skipspaces;
4700             }
4701             skipspaces = 0;
4702             if (s <= send)
4703                 *fpc++ = FF_NEWLINE;
4704             if (noblank) {
4705                 *fpc++ = FF_BLANK;
4706                 if (repeat)
4707                     arg = fpc - linepc + 1;
4708                 else
4709                     arg = 0;
4710                 *fpc++ = (U16)arg;
4711             }
4712             if (s < send) {
4713                 linepc = fpc;
4714                 *fpc++ = FF_LINEMARK;
4715                 noblank = repeat = FALSE;
4716                 base = s;
4717             }
4718             else
4719                 s++;
4720             continue;
4721
4722         case '@':
4723         case '^':
4724             ischop = s[-1] == '^';
4725
4726             if (postspace) {
4727                 *fpc++ = FF_SPACE;
4728                 postspace = FALSE;
4729             }
4730             arg = (s - base) - 1;
4731             if (arg) {
4732                 *fpc++ = FF_LITERAL;
4733                 *fpc++ = (U16)arg;
4734             }
4735
4736             base = s - 1;
4737             *fpc++ = FF_FETCH;
4738             if (*s == '*') {
4739                 s++;
4740                 *fpc++ = 2;  /* skip the @* or ^* */
4741                 if (ischop) {
4742                     *fpc++ = FF_LINESNGL;
4743                     *fpc++ = FF_CHOP;
4744                 } else
4745                     *fpc++ = FF_LINEGLOB;
4746             }
4747             else if (*s == '#' || (*s == '.' && s[1] == '#')) {
4748                 arg = ischop ? 512 : 0;
4749                 base = s - 1;
4750                 while (*s == '#')
4751                     s++;
4752                 if (*s == '.') {
4753                     const char * const f = ++s;
4754                     while (*s == '#')
4755                         s++;
4756                     arg |= 256 + (s - f);
4757                 }
4758                 *fpc++ = s - base;              /* fieldsize for FETCH */
4759                 *fpc++ = FF_DECIMAL;
4760                 *fpc++ = (U16)arg;
4761                 unchopnum |= ! ischop;
4762             }
4763             else if (*s == '0' && s[1] == '#') {  /* Zero padded decimals */
4764                 arg = ischop ? 512 : 0;
4765                 base = s - 1;
4766                 s++;                                /* skip the '0' first */
4767                 while (*s == '#')
4768                     s++;
4769                 if (*s == '.') {
4770                     const char * const f = ++s;
4771                     while (*s == '#')
4772                         s++;
4773                     arg |= 256 + (s - f);
4774                 }
4775                 *fpc++ = s - base;                /* fieldsize for FETCH */
4776                 *fpc++ = FF_0DECIMAL;
4777                 *fpc++ = (U16)arg;
4778                 unchopnum |= ! ischop;
4779             }
4780             else {
4781                 I32 prespace = 0;
4782                 bool ismore = FALSE;
4783
4784                 if (*s == '>') {
4785                     while (*++s == '>') ;
4786                     prespace = FF_SPACE;
4787                 }
4788                 else if (*s == '|') {
4789                     while (*++s == '|') ;
4790                     prespace = FF_HALFSPACE;
4791                     postspace = TRUE;
4792                 }
4793                 else {
4794                     if (*s == '<')
4795                         while (*++s == '<') ;
4796                     postspace = TRUE;
4797                 }
4798                 if (*s == '.' && s[1] == '.' && s[2] == '.') {
4799                     s += 3;
4800                     ismore = TRUE;
4801                 }
4802                 *fpc++ = s - base;              /* fieldsize for FETCH */
4803
4804                 *fpc++ = ischop ? FF_CHECKCHOP : FF_CHECKNL;
4805
4806                 if (prespace)
4807                     *fpc++ = (U16)prespace;
4808                 *fpc++ = FF_ITEM;
4809                 if (ismore)
4810                     *fpc++ = FF_MORE;
4811                 if (ischop)
4812                     *fpc++ = FF_CHOP;
4813             }
4814             base = s;
4815             skipspaces = 0;
4816             continue;
4817         }
4818     }
4819     *fpc++ = FF_END;
4820
4821     assert (fpc <= fops + maxops); /* ensure our buffer estimate was valid */
4822     arg = fpc - fops;
4823     { /* need to jump to the next word */
4824         int z;
4825         z = WORD_ALIGN - SvCUR(sv) % WORD_ALIGN;
4826         SvGROW(sv, SvCUR(sv) + z + arg * sizeof(U32) + 4);
4827         s = SvPVX(sv) + SvCUR(sv) + z;
4828     }
4829     Copy(fops, s, arg, U32);
4830     Safefree(fops);
4831     sv_magic(sv, NULL, PERL_MAGIC_fm, NULL, 0);
4832     SvCOMPILED_on(sv);
4833
4834     if (unchopnum && repeat)
4835         DIE(aTHX_ "Repeated format line will never terminate (~~ and @#)");
4836     return 0;
4837 }
4838
4839
4840 STATIC bool
4841 S_num_overflow(NV value, I32 fldsize, I32 frcsize)
4842 {
4843     /* Can value be printed in fldsize chars, using %*.*f ? */
4844     NV pwr = 1;
4845     NV eps = 0.5;
4846     bool res = FALSE;
4847     int intsize = fldsize - (value < 0 ? 1 : 0);
4848
4849     if (frcsize & 256)
4850         intsize--;
4851     frcsize &= 255;
4852     intsize -= frcsize;
4853
4854     while (intsize--) pwr *= 10.0;
4855     while (frcsize--) eps /= 10.0;
4856
4857     if( value >= 0 ){
4858         if (value + eps >= pwr)
4859             res = TRUE;
4860     } else {
4861         if (value - eps <= -pwr)
4862             res = TRUE;
4863     }
4864     return res;
4865 }
4866
4867 static I32
4868 S_run_user_filter(pTHX_ int idx, SV *buf_sv, int maxlen)
4869 {
4870     dVAR;
4871     SV * const datasv = FILTER_DATA(idx);
4872     const int filter_has_file = IoLINES(datasv);
4873     SV * const filter_state = MUTABLE_SV(IoTOP_GV(datasv));
4874     SV * const filter_sub = MUTABLE_SV(IoBOTTOM_GV(datasv));
4875     int status = 0;
4876     SV *upstream;
4877     STRLEN got_len;
4878     char *got_p = NULL;
4879     char *prune_from = NULL;
4880     bool read_from_cache = FALSE;
4881     STRLEN umaxlen;
4882
4883     PERL_ARGS_ASSERT_RUN_USER_FILTER;
4884
4885     assert(maxlen >= 0);
4886     umaxlen = maxlen;
4887
4888     /* I was having segfault trouble under Linux 2.2.5 after a
4889        parse error occured.  (Had to hack around it with a test
4890        for PL_parser->error_count == 0.)  Solaris doesn't segfault --
4891        not sure where the trouble is yet.  XXX */
4892
4893     {
4894         SV *const cache = datasv;
4895         if (SvOK(cache)) {
4896             STRLEN cache_len;
4897             const char *cache_p = SvPV(cache, cache_len);
4898             STRLEN take = 0;
4899
4900             if (umaxlen) {
4901                 /* Running in block mode and we have some cached data already.
4902                  */
4903                 if (cache_len >= umaxlen) {
4904                     /* In fact, so much data we don't even need to call
4905                        filter_read.  */
4906                     take = umaxlen;
4907                 }
4908             } else {
4909                 const char *const first_nl =
4910                     (const char *)memchr(cache_p, '\n', cache_len);
4911                 if (first_nl) {
4912                     take = first_nl + 1 - cache_p;
4913                 }
4914             }
4915             if (take) {
4916                 sv_catpvn(buf_sv, cache_p, take);
4917                 sv_chop(cache, cache_p + take);
4918                 /* Definately not EOF  */
4919                 return 1;
4920             }
4921
4922             sv_catsv(buf_sv, cache);
4923             if (umaxlen) {
4924                 umaxlen -= cache_len;
4925             }
4926             SvOK_off(cache);
4927             read_from_cache = TRUE;
4928         }
4929     }
4930
4931     /* Filter API says that the filter appends to the contents of the buffer.
4932        Usually the buffer is "", so the details don't matter. But if it's not,
4933        then clearly what it contains is already filtered by this filter, so we
4934        don't want to pass it in a second time.
4935        I'm going to use a mortal in case the upstream filter croaks.  */
4936     upstream = ((SvOK(buf_sv) && sv_len(buf_sv)) || SvGMAGICAL(buf_sv))
4937         ? sv_newmortal() : buf_sv;
4938     SvUPGRADE(upstream, SVt_PV);
4939
4940     if (filter_has_file) {
4941         status = FILTER_READ(idx+1, upstream, 0);
4942     }
4943
4944     if (filter_sub && status >= 0) {
4945         dSP;
4946         int count;
4947
4948         ENTER_with_name("call_filter_sub");
4949         SAVE_DEFSV;
4950         SAVETMPS;
4951         EXTEND(SP, 2);
4952
4953         DEFSV_set(upstream);
4954         PUSHMARK(SP);
4955         mPUSHi(0);
4956         if (filter_state) {
4957             PUSHs(filter_state);
4958         }
4959         PUTBACK;
4960         count = call_sv(filter_sub, G_SCALAR);
4961         SPAGAIN;
4962
4963         if (count > 0) {
4964             SV *out = POPs;
4965             if (SvOK(out)) {
4966                 status = SvIV(out);
4967             }
4968         }
4969
4970         PUTBACK;
4971         FREETMPS;
4972         LEAVE_with_name("call_filter_sub");
4973     }
4974
4975     if(SvOK(upstream)) {
4976         got_p = SvPV(upstream, got_len);
4977         if (umaxlen) {
4978             if (got_len > umaxlen) {
4979                 prune_from = got_p + umaxlen;
4980             }
4981         } else {
4982             char *const first_nl = (char *)memchr(got_p, '\n', got_len);
4983             if (first_nl && first_nl + 1 < got_p + got_len) {
4984                 /* There's a second line here... */
4985                 prune_from = first_nl + 1;
4986             }
4987         }
4988     }
4989     if (prune_from) {
4990         /* Oh. Too long. Stuff some in our cache.  */
4991         STRLEN cached_len = got_p + got_len - prune_from;
4992         SV *const cache = datasv;
4993
4994         if (SvOK(cache)) {
4995             /* Cache should be empty.  */
4996             assert(!SvCUR(cache));
4997         }
4998
4999         sv_setpvn(cache, prune_from, cached_len);
5000         /* If you ask for block mode, you may well split UTF-8 characters.
5001            "If it breaks, you get to keep both parts"
5002            (Your code is broken if you  don't put them back together again
5003            before something notices.) */
5004         if (SvUTF8(upstream)) {
5005             SvUTF8_on(cache);
5006         }
5007         SvCUR_set(upstream, got_len - cached_len);
5008         *prune_from = 0;
5009         /* Can't yet be EOF  */
5010         if (status == 0)
5011             status = 1;
5012     }
5013
5014     /* If they are at EOF but buf_sv has something in it, then they may never
5015        have touched the SV upstream, so it may be undefined.  If we naively
5016        concatenate it then we get a warning about use of uninitialised value.
5017     */
5018     if (upstream != buf_sv && (SvOK(upstream) || SvGMAGICAL(upstream))) {
5019         sv_catsv(buf_sv, upstream);
5020     }
5021
5022     if (status <= 0) {
5023         IoLINES(datasv) = 0;
5024         if (filter_state) {
5025             SvREFCNT_dec(filter_state);
5026             IoTOP_GV(datasv) = NULL;
5027         }
5028         if (filter_sub) {
5029             SvREFCNT_dec(filter_sub);
5030             IoBOTTOM_GV(datasv) = NULL;
5031         }
5032         filter_del(S_run_user_filter);
5033     }
5034     if (status == 0 && read_from_cache) {
5035         /* If we read some data from the cache (and by getting here it implies
5036            that we emptied the cache) then we aren't yet at EOF, and mustn't
5037            report that to our caller.  */
5038         return 1;
5039     }
5040     return status;
5041 }
5042
5043 /* perhaps someone can come up with a better name for
5044    this?  it is not really "absolute", per se ... */
5045 static bool
5046 S_path_is_absolute(const char *name)
5047 {
5048     PERL_ARGS_ASSERT_PATH_IS_ABSOLUTE;
5049
5050     if (PERL_FILE_IS_ABSOLUTE(name)
5051 #ifdef WIN32
5052         || (*name == '.' && ((name[1] == '/' ||
5053                              (name[1] == '.' && name[2] == '/'))
5054                          || (name[1] == '\\' ||
5055                              ( name[1] == '.' && name[2] == '\\')))
5056             )
5057 #else
5058         || (*name == '.' && (name[1] == '/' ||
5059                              (name[1] == '.' && name[2] == '/')))
5060 #endif
5061          )
5062     {
5063         return TRUE;
5064     }
5065     else
5066         return FALSE;
5067 }
5068
5069 /*
5070  * Local variables:
5071  * c-indentation-style: bsd
5072  * c-basic-offset: 4
5073  * indent-tabs-mode: t
5074  * End:
5075  *
5076  * ex: set ts=8 sts=4 sw=4 noet:
5077  */