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