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