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