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