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