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     "when",
1255     NULL, /* CXt_BLOCK never actually needs "block" */
1256     "given",
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         case CXt_GIVEN:
1284         case CXt_WHEN:
1285             if (ckWARN(WARN_EXITING))
1286                 Perl_warner(aTHX_ packWARN(WARN_EXITING), "Exiting %s via %s",
1287                         context_name[CxTYPE(cx)], OP_NAME(PL_op));
1288             if (CxTYPE(cx) == CXt_NULL)
1289                 return -1;
1290             break;
1291         case CXt_LOOP_LAZYIV:
1292         case CXt_LOOP_LAZYSV:
1293         case CXt_LOOP_FOR:
1294         case CXt_LOOP_PLAIN:
1295             if ( !CxLABEL(cx) || strNE(label, CxLABEL(cx)) ) {
1296                 DEBUG_l(Perl_deb(aTHX_ "(Skipping label #%ld %s)\n",
1297                         (long)i, CxLABEL(cx)));
1298                 continue;
1299             }
1300             DEBUG_l( Perl_deb(aTHX_ "(Found label #%ld %s)\n", (long)i, label));
1301             return i;
1302         }
1303     }
1304     return i;
1305 }
1306
1307
1308
1309 I32
1310 Perl_dowantarray(pTHX)
1311 {
1312     dVAR;
1313     const I32 gimme = block_gimme();
1314     return (gimme == G_VOID) ? G_SCALAR : gimme;
1315 }
1316
1317 I32
1318 Perl_block_gimme(pTHX)
1319 {
1320     dVAR;
1321     const I32 cxix = dopoptosub(cxstack_ix);
1322     if (cxix < 0)
1323         return G_VOID;
1324
1325     switch (cxstack[cxix].blk_gimme) {
1326     case G_VOID:
1327         return G_VOID;
1328     case G_SCALAR:
1329         return G_SCALAR;
1330     case G_ARRAY:
1331         return G_ARRAY;
1332     default:
1333         Perl_croak(aTHX_ "panic: bad gimme: %d\n", cxstack[cxix].blk_gimme);
1334         /* NOTREACHED */
1335         return 0;
1336     }
1337 }
1338
1339 I32
1340 Perl_is_lvalue_sub(pTHX)
1341 {
1342     dVAR;
1343     const I32 cxix = dopoptosub(cxstack_ix);
1344     assert(cxix >= 0);  /* We should only be called from inside subs */
1345
1346     if (CxLVAL(cxstack + cxix) && CvLVALUE(cxstack[cxix].blk_sub.cv))
1347         return CxLVAL(cxstack + cxix);
1348     else
1349         return 0;
1350 }
1351
1352 STATIC I32
1353 S_dopoptosub_at(pTHX_ const PERL_CONTEXT *cxstk, I32 startingblock)
1354 {
1355     dVAR;
1356     I32 i;
1357
1358     PERL_ARGS_ASSERT_DOPOPTOSUB_AT;
1359
1360     for (i = startingblock; i >= 0; i--) {
1361         register const PERL_CONTEXT * const cx = &cxstk[i];
1362         switch (CxTYPE(cx)) {
1363         default:
1364             continue;
1365         case CXt_EVAL:
1366         case CXt_SUB:
1367         case CXt_FORMAT:
1368             DEBUG_l( Perl_deb(aTHX_ "(Found sub #%ld)\n", (long)i));
1369             return i;
1370         }
1371     }
1372     return i;
1373 }
1374
1375 STATIC I32
1376 S_dopoptoeval(pTHX_ I32 startingblock)
1377 {
1378     dVAR;
1379     I32 i;
1380     for (i = startingblock; i >= 0; i--) {
1381         register const PERL_CONTEXT *cx = &cxstack[i];
1382         switch (CxTYPE(cx)) {
1383         default:
1384             continue;
1385         case CXt_EVAL:
1386             DEBUG_l( Perl_deb(aTHX_ "(Found eval #%ld)\n", (long)i));
1387             return i;
1388         }
1389     }
1390     return i;
1391 }
1392
1393 STATIC I32
1394 S_dopoptoloop(pTHX_ I32 startingblock)
1395 {
1396     dVAR;
1397     I32 i;
1398     for (i = startingblock; i >= 0; i--) {
1399         register const PERL_CONTEXT * const cx = &cxstack[i];
1400         switch (CxTYPE(cx)) {
1401         case CXt_SUBST:
1402         case CXt_SUB:
1403         case CXt_FORMAT:
1404         case CXt_EVAL:
1405         case CXt_NULL:
1406             if (ckWARN(WARN_EXITING))
1407                 Perl_warner(aTHX_ packWARN(WARN_EXITING), "Exiting %s via %s",
1408                         context_name[CxTYPE(cx)], OP_NAME(PL_op));
1409             if ((CxTYPE(cx)) == CXt_NULL)
1410                 return -1;
1411             break;
1412         case CXt_LOOP_LAZYIV:
1413         case CXt_LOOP_LAZYSV:
1414         case CXt_LOOP_FOR:
1415         case CXt_LOOP_PLAIN:
1416             DEBUG_l( Perl_deb(aTHX_ "(Found loop #%ld)\n", (long)i));
1417             return i;
1418         }
1419     }
1420     return i;
1421 }
1422
1423 STATIC I32
1424 S_dopoptogiven(pTHX_ I32 startingblock)
1425 {
1426     dVAR;
1427     I32 i;
1428     for (i = startingblock; i >= 0; i--) {
1429         register const PERL_CONTEXT *cx = &cxstack[i];
1430         switch (CxTYPE(cx)) {
1431         default:
1432             continue;
1433         case CXt_GIVEN:
1434             DEBUG_l( Perl_deb(aTHX_ "(Found given #%ld)\n", (long)i));
1435             return i;
1436         case CXt_LOOP_PLAIN:
1437             assert(!CxFOREACHDEF(cx));
1438             break;
1439         case CXt_LOOP_LAZYIV:
1440         case CXt_LOOP_LAZYSV:
1441         case CXt_LOOP_FOR:
1442             if (CxFOREACHDEF(cx)) {
1443                 DEBUG_l( Perl_deb(aTHX_ "(Found foreach #%ld)\n", (long)i));
1444                 return i;
1445             }
1446         }
1447     }
1448     return i;
1449 }
1450
1451 STATIC I32
1452 S_dopoptowhen(pTHX_ I32 startingblock)
1453 {
1454     dVAR;
1455     I32 i;
1456     for (i = startingblock; i >= 0; i--) {
1457         register const PERL_CONTEXT *cx = &cxstack[i];
1458         switch (CxTYPE(cx)) {
1459         default:
1460             continue;
1461         case CXt_WHEN:
1462             DEBUG_l( Perl_deb(aTHX_ "(Found when #%ld)\n", (long)i));
1463             return i;
1464         }
1465     }
1466     return i;
1467 }
1468
1469 void
1470 Perl_dounwind(pTHX_ I32 cxix)
1471 {
1472     dVAR;
1473     I32 optype;
1474
1475     while (cxstack_ix > cxix) {
1476         SV *sv;
1477         register PERL_CONTEXT *cx = &cxstack[cxstack_ix];
1478         DEBUG_l(PerlIO_printf(Perl_debug_log, "Unwinding block %ld, type %s\n",
1479                               (long) cxstack_ix, PL_block_type[CxTYPE(cx)]));
1480         /* Note: we don't need to restore the base context info till the end. */
1481         switch (CxTYPE(cx)) {
1482         case CXt_SUBST:
1483             POPSUBST(cx);
1484             continue;  /* not break */
1485         case CXt_SUB:
1486             POPSUB(cx,sv);
1487             LEAVESUB(sv);
1488             break;
1489         case CXt_EVAL:
1490             POPEVAL(cx);
1491             break;
1492         case CXt_LOOP_LAZYIV:
1493         case CXt_LOOP_LAZYSV:
1494         case CXt_LOOP_FOR:
1495         case CXt_LOOP_PLAIN:
1496             POPLOOP(cx);
1497             break;
1498         case CXt_NULL:
1499             break;
1500         case CXt_FORMAT:
1501             POPFORMAT(cx);
1502             break;
1503         }
1504         cxstack_ix--;
1505     }
1506     PERL_UNUSED_VAR(optype);
1507 }
1508
1509 void
1510 Perl_qerror(pTHX_ SV *err)
1511 {
1512     dVAR;
1513
1514     PERL_ARGS_ASSERT_QERROR;
1515
1516     if (PL_in_eval)
1517         sv_catsv(ERRSV, err);
1518     else if (PL_errors)
1519         sv_catsv(PL_errors, err);
1520     else
1521         Perl_warn(aTHX_ "%"SVf, SVfARG(err));
1522     if (PL_parser)
1523         ++PL_parser->error_count;
1524 }
1525
1526 OP *
1527 Perl_die_where(pTHX_ const char *message, STRLEN msglen)
1528 {
1529     dVAR;
1530
1531     if (PL_in_eval) {
1532         I32 cxix;
1533         I32 gimme;
1534
1535         if (message) {
1536             if (PL_in_eval & EVAL_KEEPERR) {
1537                 static const char prefix[] = "\t(in cleanup) ";
1538                 SV * const err = ERRSV;
1539                 const char *e = NULL;
1540                 if (!SvPOK(err))
1541                     sv_setpvs(err,"");
1542                 else if (SvCUR(err) >= sizeof(prefix)+msglen-1) {
1543                     STRLEN len;
1544                     e = SvPV_const(err, len);
1545                     e += len - msglen;
1546                     if (*e != *message || strNE(e,message))
1547                         e = NULL;
1548                 }
1549                 if (!e) {
1550                     SvGROW(err, SvCUR(err)+sizeof(prefix)+msglen);
1551                     sv_catpvn(err, prefix, sizeof(prefix)-1);
1552                     sv_catpvn(err, message, msglen);
1553                     if (ckWARN(WARN_MISC)) {
1554                         const STRLEN start = SvCUR(err)-msglen-sizeof(prefix)+1;
1555                         Perl_warner(aTHX_ packWARN(WARN_MISC), "%s",
1556                                 SvPVX_const(err)+start);
1557                     }
1558                 }
1559             }
1560             else {
1561                 sv_setpvn(ERRSV, message, msglen);
1562             }
1563         }
1564
1565         while ((cxix = dopoptoeval(cxstack_ix)) < 0
1566                && PL_curstackinfo->si_prev)
1567         {
1568             dounwind(-1);
1569             POPSTACK;
1570         }
1571
1572         if (cxix >= 0) {
1573             I32 optype;
1574             register PERL_CONTEXT *cx;
1575             SV **newsp;
1576
1577             if (cxix < cxstack_ix)
1578                 dounwind(cxix);
1579
1580             POPBLOCK(cx,PL_curpm);
1581             if (CxTYPE(cx) != CXt_EVAL) {
1582                 if (!message)
1583                     message = SvPVx_const(ERRSV, msglen);
1584                 PerlIO_write(Perl_error_log, (const char *)"panic: die ", 11);
1585                 PerlIO_write(Perl_error_log, message, msglen);
1586                 my_exit(1);
1587             }
1588             POPEVAL(cx);
1589
1590             if (gimme == G_SCALAR)
1591                 *++newsp = &PL_sv_undef;
1592             PL_stack_sp = newsp;
1593
1594             LEAVE;
1595
1596             /* LEAVE could clobber PL_curcop (see save_re_context())
1597              * XXX it might be better to find a way to avoid messing with
1598              * PL_curcop in save_re_context() instead, but this is a more
1599              * minimal fix --GSAR */
1600             PL_curcop = cx->blk_oldcop;
1601
1602             if (optype == OP_REQUIRE) {
1603                 const char* const msg = SvPVx_nolen_const(ERRSV);
1604                 SV * const nsv = cx->blk_eval.old_namesv;
1605                 (void)hv_store(GvHVn(PL_incgv), SvPVX_const(nsv), SvCUR(nsv),
1606                                &PL_sv_undef, 0);
1607                 DIE(aTHX_ "%sCompilation failed in require",
1608                     *msg ? msg : "Unknown error\n");
1609             }
1610             assert(CxTYPE(cx) == CXt_EVAL);
1611             return cx->blk_eval.retop;
1612         }
1613     }
1614     if (!message)
1615         message = SvPVx_const(ERRSV, msglen);
1616
1617     write_to_stderr(message, msglen);
1618     my_failure_exit();
1619     /* NOTREACHED */
1620     return 0;
1621 }
1622
1623 PP(pp_xor)
1624 {
1625     dVAR; dSP; dPOPTOPssrl;
1626     if (SvTRUE(left) != SvTRUE(right))
1627         RETSETYES;
1628     else
1629         RETSETNO;
1630 }
1631
1632 PP(pp_caller)
1633 {
1634     dVAR;
1635     dSP;
1636     register I32 cxix = dopoptosub(cxstack_ix);
1637     register const PERL_CONTEXT *cx;
1638     register const PERL_CONTEXT *ccstack = cxstack;
1639     const PERL_SI *top_si = PL_curstackinfo;
1640     I32 gimme;
1641     const char *stashname;
1642     I32 count = 0;
1643
1644     if (MAXARG)
1645         count = POPi;
1646
1647     for (;;) {
1648         /* we may be in a higher stacklevel, so dig down deeper */
1649         while (cxix < 0 && top_si->si_type != PERLSI_MAIN) {
1650             top_si = top_si->si_prev;
1651             ccstack = top_si->si_cxstack;
1652             cxix = dopoptosub_at(ccstack, top_si->si_cxix);
1653         }
1654         if (cxix < 0) {
1655             if (GIMME != G_ARRAY) {
1656                 EXTEND(SP, 1);
1657                 RETPUSHUNDEF;
1658             }
1659             RETURN;
1660         }
1661         /* caller() should not report the automatic calls to &DB::sub */
1662         if (PL_DBsub && GvCV(PL_DBsub) && cxix >= 0 &&
1663                 ccstack[cxix].blk_sub.cv == GvCV(PL_DBsub))
1664             count++;
1665         if (!count--)
1666             break;
1667         cxix = dopoptosub_at(ccstack, cxix - 1);
1668     }
1669
1670     cx = &ccstack[cxix];
1671     if (CxTYPE(cx) == CXt_SUB || CxTYPE(cx) == CXt_FORMAT) {
1672         const I32 dbcxix = dopoptosub_at(ccstack, cxix - 1);
1673         /* We expect that ccstack[dbcxix] is CXt_SUB, anyway, the
1674            field below is defined for any cx. */
1675         /* caller() should not report the automatic calls to &DB::sub */
1676         if (PL_DBsub && GvCV(PL_DBsub) && dbcxix >= 0 && ccstack[dbcxix].blk_sub.cv == GvCV(PL_DBsub))
1677             cx = &ccstack[dbcxix];
1678     }
1679
1680     stashname = CopSTASHPV(cx->blk_oldcop);
1681     if (GIMME != G_ARRAY) {
1682         EXTEND(SP, 1);
1683         if (!stashname)
1684             PUSHs(&PL_sv_undef);
1685         else {
1686             dTARGET;
1687             sv_setpv(TARG, stashname);
1688             PUSHs(TARG);
1689         }
1690         RETURN;
1691     }
1692
1693     EXTEND(SP, 11);
1694
1695     if (!stashname)
1696         PUSHs(&PL_sv_undef);
1697     else
1698         mPUSHs(newSVpv(stashname, 0));
1699     mPUSHs(newSVpv(OutCopFILE(cx->blk_oldcop), 0));
1700     mPUSHi((I32)CopLINE(cx->blk_oldcop));
1701     if (!MAXARG)
1702         RETURN;
1703     if (CxTYPE(cx) == CXt_SUB || CxTYPE(cx) == CXt_FORMAT) {
1704         GV * const cvgv = CvGV(ccstack[cxix].blk_sub.cv);
1705         /* So is ccstack[dbcxix]. */
1706         if (isGV(cvgv)) {
1707             SV * const sv = newSV(0);
1708             gv_efullname3(sv, cvgv, NULL);
1709             mPUSHs(sv);
1710             PUSHs(boolSV(CxHASARGS(cx)));
1711         }
1712         else {
1713             PUSHs(newSVpvs_flags("(unknown)", SVs_TEMP));
1714             PUSHs(boolSV(CxHASARGS(cx)));
1715         }
1716     }
1717     else {
1718         PUSHs(newSVpvs_flags("(eval)", SVs_TEMP));
1719         mPUSHi(0);
1720     }
1721     gimme = (I32)cx->blk_gimme;
1722     if (gimme == G_VOID)
1723         PUSHs(&PL_sv_undef);
1724     else
1725         PUSHs(boolSV((gimme & G_WANT) == G_ARRAY));
1726     if (CxTYPE(cx) == CXt_EVAL) {
1727         /* eval STRING */
1728         if (CxOLD_OP_TYPE(cx) == OP_ENTEREVAL) {
1729             PUSHs(cx->blk_eval.cur_text);
1730             PUSHs(&PL_sv_no);
1731         }
1732         /* require */
1733         else if (cx->blk_eval.old_namesv) {
1734             mPUSHs(newSVsv(cx->blk_eval.old_namesv));
1735             PUSHs(&PL_sv_yes);
1736         }
1737         /* eval BLOCK (try blocks have old_namesv == 0) */
1738         else {
1739             PUSHs(&PL_sv_undef);
1740             PUSHs(&PL_sv_undef);
1741         }
1742     }
1743     else {
1744         PUSHs(&PL_sv_undef);
1745         PUSHs(&PL_sv_undef);
1746     }
1747     if (CxTYPE(cx) == CXt_SUB && CxHASARGS(cx)
1748         && CopSTASH_eq(PL_curcop, PL_debstash))
1749     {
1750         AV * const ary = cx->blk_sub.argarray;
1751         const int off = AvARRAY(ary) - AvALLOC(ary);
1752
1753         if (!PL_dbargs) {
1754             GV* const tmpgv = gv_fetchpvs("DB::args", GV_ADD, SVt_PVAV);
1755             PL_dbargs = GvAV(gv_AVadd(tmpgv));
1756             GvMULTI_on(tmpgv);
1757             AvREAL_off(PL_dbargs);      /* XXX should be REIFY (see av.h) */
1758         }
1759
1760         if (AvMAX(PL_dbargs) < AvFILLp(ary) + off)
1761             av_extend(PL_dbargs, AvFILLp(ary) + off);
1762         Copy(AvALLOC(ary), AvARRAY(PL_dbargs), AvFILLp(ary) + 1 + off, SV*);
1763         AvFILLp(PL_dbargs) = AvFILLp(ary) + off;
1764     }
1765     /* XXX only hints propagated via op_private are currently
1766      * visible (others are not easily accessible, since they
1767      * use the global PL_hints) */
1768     mPUSHi(CopHINTS_get(cx->blk_oldcop));
1769     {
1770         SV * mask ;
1771         STRLEN * const old_warnings = cx->blk_oldcop->cop_warnings ;
1772
1773         if  (old_warnings == pWARN_NONE ||
1774                 (old_warnings == pWARN_STD && (PL_dowarn & G_WARN_ON) == 0))
1775             mask = newSVpvn(WARN_NONEstring, WARNsize) ;
1776         else if (old_warnings == pWARN_ALL ||
1777                   (old_warnings == pWARN_STD && PL_dowarn & G_WARN_ON)) {
1778             /* Get the bit mask for $warnings::Bits{all}, because
1779              * it could have been extended by warnings::register */
1780             SV **bits_all;
1781             HV * const bits = get_hv("warnings::Bits", 0);
1782             if (bits && (bits_all=hv_fetchs(bits, "all", FALSE))) {
1783                 mask = newSVsv(*bits_all);
1784             }
1785             else {
1786                 mask = newSVpvn(WARN_ALLstring, WARNsize) ;
1787             }
1788         }
1789         else
1790             mask = newSVpvn((char *) (old_warnings + 1), old_warnings[0]);
1791         mPUSHs(mask);
1792     }
1793
1794     PUSHs(cx->blk_oldcop->cop_hints_hash ?
1795           sv_2mortal(newRV_noinc(
1796                                  MUTABLE_SV(Perl_refcounted_he_chain_2hv(aTHX_
1797                                               cx->blk_oldcop->cop_hints_hash))))
1798           : &PL_sv_undef);
1799     RETURN;
1800 }
1801
1802 PP(pp_reset)
1803 {
1804     dVAR;
1805     dSP;
1806     const char * const tmps = (MAXARG < 1) ? (const char *)"" : POPpconstx;
1807     sv_reset(tmps, CopSTASH(PL_curcop));
1808     PUSHs(&PL_sv_yes);
1809     RETURN;
1810 }
1811
1812 /* like pp_nextstate, but used instead when the debugger is active */
1813
1814 PP(pp_dbstate)
1815 {
1816     dVAR;
1817     PL_curcop = (COP*)PL_op;
1818     TAINT_NOT;          /* Each statement is presumed innocent */
1819     PL_stack_sp = PL_stack_base + cxstack[cxstack_ix].blk_oldsp;
1820     FREETMPS;
1821
1822     if (PL_op->op_flags & OPf_SPECIAL /* breakpoint */
1823             || SvIV(PL_DBsingle) || SvIV(PL_DBsignal) || SvIV(PL_DBtrace))
1824     {
1825         dSP;
1826         register PERL_CONTEXT *cx;
1827         const I32 gimme = G_ARRAY;
1828         U8 hasargs;
1829         GV * const gv = PL_DBgv;
1830         register CV * const cv = GvCV(gv);
1831
1832         if (!cv)
1833             DIE(aTHX_ "No DB::DB routine defined");
1834
1835         if (CvDEPTH(cv) >= 1 && !(PL_debug & DEBUG_DB_RECURSE_FLAG))
1836             /* don't do recursive DB::DB call */
1837             return NORMAL;
1838
1839         ENTER;
1840         SAVETMPS;
1841
1842         SAVEI32(PL_debug);
1843         SAVESTACK_POS();
1844         PL_debug = 0;
1845         hasargs = 0;
1846         SPAGAIN;
1847
1848         if (CvISXSUB(cv)) {
1849             CvDEPTH(cv)++;
1850             PUSHMARK(SP);
1851             (void)(*CvXSUB(cv))(aTHX_ cv);
1852             CvDEPTH(cv)--;
1853             FREETMPS;
1854             LEAVE;
1855             return NORMAL;
1856         }
1857         else {
1858             PUSHBLOCK(cx, CXt_SUB, SP);
1859             PUSHSUB_DB(cx);
1860             cx->blk_sub.retop = PL_op->op_next;
1861             CvDEPTH(cv)++;
1862             SAVECOMPPAD();
1863             PAD_SET_CUR_NOSAVE(CvPADLIST(cv), 1);
1864             RETURNOP(CvSTART(cv));
1865         }
1866     }
1867     else
1868         return NORMAL;
1869 }
1870
1871 PP(pp_enteriter)
1872 {
1873     dVAR; dSP; dMARK;
1874     register PERL_CONTEXT *cx;
1875     const I32 gimme = GIMME_V;
1876     SV **svp;
1877     U8 cxtype = CXt_LOOP_FOR;
1878 #ifdef USE_ITHREADS
1879     PAD *iterdata;
1880 #endif
1881
1882     ENTER;
1883     SAVETMPS;
1884
1885     if (PL_op->op_targ) {
1886         if (PL_op->op_private & OPpLVAL_INTRO) { /* for my $x (...) */
1887             SvPADSTALE_off(PAD_SVl(PL_op->op_targ));
1888             SAVESETSVFLAGS(PAD_SVl(PL_op->op_targ),
1889                     SVs_PADSTALE, SVs_PADSTALE);
1890         }
1891         SAVEPADSVANDMORTALIZE(PL_op->op_targ);
1892 #ifndef USE_ITHREADS
1893         svp = &PAD_SVl(PL_op->op_targ);         /* "my" variable */
1894 #else
1895         iterdata = NULL;
1896 #endif
1897     }
1898     else {
1899         GV * const gv = MUTABLE_GV(POPs);
1900         svp = &GvSV(gv);                        /* symbol table variable */
1901         SAVEGENERICSV(*svp);
1902         *svp = newSV(0);
1903 #ifdef USE_ITHREADS
1904         iterdata = (PAD*)gv;
1905 #endif
1906     }
1907
1908     if (PL_op->op_private & OPpITER_DEF)
1909         cxtype |= CXp_FOR_DEF;
1910
1911     ENTER;
1912
1913     PUSHBLOCK(cx, cxtype, SP);
1914 #ifdef USE_ITHREADS
1915     PUSHLOOP_FOR(cx, iterdata, MARK, PL_op->op_targ);
1916 #else
1917     PUSHLOOP_FOR(cx, svp, MARK, 0);
1918 #endif
1919     if (PL_op->op_flags & OPf_STACKED) {
1920         SV *maybe_ary = POPs;
1921         if (SvTYPE(maybe_ary) != SVt_PVAV) {
1922             dPOPss;
1923             SV * const right = maybe_ary;
1924             SvGETMAGIC(sv);
1925             SvGETMAGIC(right);
1926             if (RANGE_IS_NUMERIC(sv,right)) {
1927                 cx->cx_type &= ~CXTYPEMASK;
1928                 cx->cx_type |= CXt_LOOP_LAZYIV;
1929                 /* Make sure that no-one re-orders cop.h and breaks our
1930                    assumptions */
1931                 assert(CxTYPE(cx) == CXt_LOOP_LAZYIV);
1932 #ifdef NV_PRESERVES_UV
1933                 if ((SvOK(sv) && ((SvNV(sv) < (NV)IV_MIN) ||
1934                                   (SvNV(sv) > (NV)IV_MAX)))
1935                         ||
1936                     (SvOK(right) && ((SvNV(right) > (NV)IV_MAX) ||
1937                                      (SvNV(right) < (NV)IV_MIN))))
1938 #else
1939                 if ((SvOK(sv) && ((SvNV(sv) <= (NV)IV_MIN)
1940                                   ||
1941                                   ((SvNV(sv) > 0) &&
1942                                         ((SvUV(sv) > (UV)IV_MAX) ||
1943                                          (SvNV(sv) > (NV)UV_MAX)))))
1944                         ||
1945                     (SvOK(right) && ((SvNV(right) <= (NV)IV_MIN)
1946                                      ||
1947                                      ((SvNV(right) > 0) &&
1948                                         ((SvUV(right) > (UV)IV_MAX) ||
1949                                          (SvNV(right) > (NV)UV_MAX))))))
1950 #endif
1951                     DIE(aTHX_ "Range iterator outside integer range");
1952                 cx->blk_loop.state_u.lazyiv.cur = SvIV(sv);
1953                 cx->blk_loop.state_u.lazyiv.end = SvIV(right);
1954 #ifdef DEBUGGING
1955                 /* for correct -Dstv display */
1956                 cx->blk_oldsp = sp - PL_stack_base;
1957 #endif
1958             }
1959             else {
1960                 cx->cx_type &= ~CXTYPEMASK;
1961                 cx->cx_type |= CXt_LOOP_LAZYSV;
1962                 /* Make sure that no-one re-orders cop.h and breaks our
1963                    assumptions */
1964                 assert(CxTYPE(cx) == CXt_LOOP_LAZYSV);
1965                 cx->blk_loop.state_u.lazysv.cur = newSVsv(sv);
1966                 cx->blk_loop.state_u.lazysv.end = right;
1967                 SvREFCNT_inc(right);
1968                 (void) SvPV_force_nolen(cx->blk_loop.state_u.lazysv.cur);
1969                 /* This will do the upgrade to SVt_PV, and warn if the value
1970                    is uninitialised.  */
1971                 (void) SvPV_nolen_const(right);
1972                 /* Doing this avoids a check every time in pp_iter in pp_hot.c
1973                    to replace !SvOK() with a pointer to "".  */
1974                 if (!SvOK(right)) {
1975                     SvREFCNT_dec(right);
1976                     cx->blk_loop.state_u.lazysv.end = &PL_sv_no;
1977                 }
1978             }
1979         }
1980         else /* SvTYPE(maybe_ary) == SVt_PVAV */ {
1981             cx->blk_loop.state_u.ary.ary = MUTABLE_AV(maybe_ary);
1982             SvREFCNT_inc(maybe_ary);
1983             cx->blk_loop.state_u.ary.ix =
1984                 (PL_op->op_private & OPpITER_REVERSED) ?
1985                 AvFILL(cx->blk_loop.state_u.ary.ary) + 1 :
1986                 -1;
1987         }
1988     }
1989     else { /* iterating over items on the stack */
1990         cx->blk_loop.state_u.ary.ary = NULL; /* means to use the stack */
1991         if (PL_op->op_private & OPpITER_REVERSED) {
1992             cx->blk_loop.state_u.ary.ix = cx->blk_oldsp + 1;
1993         }
1994         else {
1995             cx->blk_loop.state_u.ary.ix = MARK - PL_stack_base;
1996         }
1997     }
1998
1999     RETURN;
2000 }
2001
2002 PP(pp_enterloop)
2003 {
2004     dVAR; dSP;
2005     register PERL_CONTEXT *cx;
2006     const I32 gimme = GIMME_V;
2007
2008     ENTER;
2009     SAVETMPS;
2010     ENTER;
2011
2012     PUSHBLOCK(cx, CXt_LOOP_PLAIN, SP);
2013     PUSHLOOP_PLAIN(cx, SP);
2014
2015     RETURN;
2016 }
2017
2018 PP(pp_leaveloop)
2019 {
2020     dVAR; dSP;
2021     register PERL_CONTEXT *cx;
2022     I32 gimme;
2023     SV **newsp;
2024     PMOP *newpm;
2025     SV **mark;
2026
2027     POPBLOCK(cx,newpm);
2028     assert(CxTYPE_is_LOOP(cx));
2029     mark = newsp;
2030     newsp = PL_stack_base + cx->blk_loop.resetsp;
2031
2032     TAINT_NOT;
2033     if (gimme == G_VOID)
2034         NOOP;
2035     else if (gimme == G_SCALAR) {
2036         if (mark < SP)
2037             *++newsp = sv_mortalcopy(*SP);
2038         else
2039             *++newsp = &PL_sv_undef;
2040     }
2041     else {
2042         while (mark < SP) {
2043             *++newsp = sv_mortalcopy(*++mark);
2044             TAINT_NOT;          /* Each item is independent */
2045         }
2046     }
2047     SP = newsp;
2048     PUTBACK;
2049
2050     POPLOOP(cx);        /* Stack values are safe: release loop vars ... */
2051     PL_curpm = newpm;   /* ... and pop $1 et al */
2052
2053     LEAVE;
2054     LEAVE;
2055
2056     return NORMAL;
2057 }
2058
2059 PP(pp_return)
2060 {
2061     dVAR; dSP; dMARK;
2062     register PERL_CONTEXT *cx;
2063     bool popsub2 = FALSE;
2064     bool clear_errsv = FALSE;
2065     I32 gimme;
2066     SV **newsp;
2067     PMOP *newpm;
2068     I32 optype = 0;
2069     SV *sv;
2070     OP *retop;
2071
2072     const I32 cxix = dopoptosub(cxstack_ix);
2073
2074     if (cxix < 0) {
2075         if (CxMULTICALL(cxstack)) { /* In this case we must be in a
2076                                      * sort block, which is a CXt_NULL
2077                                      * not a CXt_SUB */
2078             dounwind(0);
2079             PL_stack_base[1] = *PL_stack_sp;
2080             PL_stack_sp = PL_stack_base + 1;
2081             return 0;
2082         }
2083         else
2084             DIE(aTHX_ "Can't return outside a subroutine");
2085     }
2086     if (cxix < cxstack_ix)
2087         dounwind(cxix);
2088
2089     if (CxMULTICALL(&cxstack[cxix])) {
2090         gimme = cxstack[cxix].blk_gimme;
2091         if (gimme == G_VOID)
2092             PL_stack_sp = PL_stack_base;
2093         else if (gimme == G_SCALAR) {
2094             PL_stack_base[1] = *PL_stack_sp;
2095             PL_stack_sp = PL_stack_base + 1;
2096         }
2097         return 0;
2098     }
2099
2100     POPBLOCK(cx,newpm);
2101     switch (CxTYPE(cx)) {
2102     case CXt_SUB:
2103         popsub2 = TRUE;
2104         retop = cx->blk_sub.retop;
2105         cxstack_ix++; /* preserve cx entry on stack for use by POPSUB */
2106         break;
2107     case CXt_EVAL:
2108         if (!(PL_in_eval & EVAL_KEEPERR))
2109             clear_errsv = TRUE;
2110         POPEVAL(cx);
2111         retop = cx->blk_eval.retop;
2112         if (CxTRYBLOCK(cx))
2113             break;
2114         lex_end();
2115         if (optype == OP_REQUIRE &&
2116             (MARK == SP || (gimme == G_SCALAR && !SvTRUE(*SP))) )
2117         {
2118             /* Unassume the success we assumed earlier. */
2119             SV * const nsv = cx->blk_eval.old_namesv;
2120             (void)hv_delete(GvHVn(PL_incgv), SvPVX_const(nsv), SvCUR(nsv), G_DISCARD);
2121             DIE(aTHX_ "%"SVf" did not return a true value", SVfARG(nsv));
2122         }
2123         break;
2124     case CXt_FORMAT:
2125         POPFORMAT(cx);
2126         retop = cx->blk_sub.retop;
2127         break;
2128     default:
2129         DIE(aTHX_ "panic: return");
2130     }
2131
2132     TAINT_NOT;
2133     if (gimme == G_SCALAR) {
2134         if (MARK < SP) {
2135             if (popsub2) {
2136                 if (cx->blk_sub.cv && CvDEPTH(cx->blk_sub.cv) > 1) {
2137                     if (SvTEMP(TOPs)) {
2138                         *++newsp = SvREFCNT_inc(*SP);
2139                         FREETMPS;
2140                         sv_2mortal(*newsp);
2141                     }
2142                     else {
2143                         sv = SvREFCNT_inc(*SP); /* FREETMPS could clobber it */
2144                         FREETMPS;
2145                         *++newsp = sv_mortalcopy(sv);
2146                         SvREFCNT_dec(sv);
2147                     }
2148                 }
2149                 else
2150                     *++newsp = (SvTEMP(*SP)) ? *SP : sv_mortalcopy(*SP);
2151             }
2152             else
2153                 *++newsp = sv_mortalcopy(*SP);
2154         }
2155         else
2156             *++newsp = &PL_sv_undef;
2157     }
2158     else if (gimme == G_ARRAY) {
2159         while (++MARK <= SP) {
2160             *++newsp = (popsub2 && SvTEMP(*MARK))
2161                         ? *MARK : sv_mortalcopy(*MARK);
2162             TAINT_NOT;          /* Each item is independent */
2163         }
2164     }
2165     PL_stack_sp = newsp;
2166
2167     LEAVE;
2168     /* Stack values are safe: */
2169     if (popsub2) {
2170         cxstack_ix--;
2171         POPSUB(cx,sv);  /* release CV and @_ ... */
2172     }
2173     else
2174         sv = NULL;
2175     PL_curpm = newpm;   /* ... and pop $1 et al */
2176
2177     LEAVESUB(sv);
2178     if (clear_errsv) {
2179         CLEAR_ERRSV();
2180     }
2181     return retop;
2182 }
2183
2184 PP(pp_last)
2185 {
2186     dVAR; dSP;
2187     I32 cxix;
2188     register PERL_CONTEXT *cx;
2189     I32 pop2 = 0;
2190     I32 gimme;
2191     I32 optype;
2192     OP *nextop;
2193     SV **newsp;
2194     PMOP *newpm;
2195     SV **mark;
2196     SV *sv = NULL;
2197
2198
2199     if (PL_op->op_flags & OPf_SPECIAL) {
2200         cxix = dopoptoloop(cxstack_ix);
2201         if (cxix < 0)
2202             DIE(aTHX_ "Can't \"last\" outside a loop block");
2203     }
2204     else {
2205         cxix = dopoptolabel(cPVOP->op_pv);
2206         if (cxix < 0)
2207             DIE(aTHX_ "Label not found for \"last %s\"", cPVOP->op_pv);
2208     }
2209     if (cxix < cxstack_ix)
2210         dounwind(cxix);
2211
2212     POPBLOCK(cx,newpm);
2213     cxstack_ix++; /* temporarily protect top context */
2214     mark = newsp;
2215     switch (CxTYPE(cx)) {
2216     case CXt_LOOP_LAZYIV:
2217     case CXt_LOOP_LAZYSV:
2218     case CXt_LOOP_FOR:
2219     case CXt_LOOP_PLAIN:
2220         pop2 = CxTYPE(cx);
2221         newsp = PL_stack_base + cx->blk_loop.resetsp;
2222         nextop = cx->blk_loop.my_op->op_lastop->op_next;
2223         break;
2224     case CXt_SUB:
2225         pop2 = CXt_SUB;
2226         nextop = cx->blk_sub.retop;
2227         break;
2228     case CXt_EVAL:
2229         POPEVAL(cx);
2230         nextop = cx->blk_eval.retop;
2231         break;
2232     case CXt_FORMAT:
2233         POPFORMAT(cx);
2234         nextop = cx->blk_sub.retop;
2235         break;
2236     default:
2237         DIE(aTHX_ "panic: last");
2238     }
2239
2240     TAINT_NOT;
2241     if (gimme == G_SCALAR) {
2242         if (MARK < SP)
2243             *++newsp = ((pop2 == CXt_SUB) && SvTEMP(*SP))
2244                         ? *SP : sv_mortalcopy(*SP);
2245         else
2246             *++newsp = &PL_sv_undef;
2247     }
2248     else if (gimme == G_ARRAY) {
2249         while (++MARK <= SP) {
2250             *++newsp = ((pop2 == CXt_SUB) && SvTEMP(*MARK))
2251                         ? *MARK : sv_mortalcopy(*MARK);
2252             TAINT_NOT;          /* Each item is independent */
2253         }
2254     }
2255     SP = newsp;
2256     PUTBACK;
2257
2258     LEAVE;
2259     cxstack_ix--;
2260     /* Stack values are safe: */
2261     switch (pop2) {
2262     case CXt_LOOP_LAZYIV:
2263     case CXt_LOOP_PLAIN:
2264     case CXt_LOOP_LAZYSV:
2265     case CXt_LOOP_FOR:
2266         POPLOOP(cx);    /* release loop vars ... */
2267         LEAVE;
2268         break;
2269     case CXt_SUB:
2270         POPSUB(cx,sv);  /* release CV and @_ ... */
2271         break;
2272     }
2273     PL_curpm = newpm;   /* ... and pop $1 et al */
2274
2275     LEAVESUB(sv);
2276     PERL_UNUSED_VAR(optype);
2277     PERL_UNUSED_VAR(gimme);
2278     return nextop;
2279 }
2280
2281 PP(pp_next)
2282 {
2283     dVAR;
2284     I32 cxix;
2285     register PERL_CONTEXT *cx;
2286     I32 inner;
2287
2288     if (PL_op->op_flags & OPf_SPECIAL) {
2289         cxix = dopoptoloop(cxstack_ix);
2290         if (cxix < 0)
2291             DIE(aTHX_ "Can't \"next\" outside a loop block");
2292     }
2293     else {
2294         cxix = dopoptolabel(cPVOP->op_pv);
2295         if (cxix < 0)
2296             DIE(aTHX_ "Label not found for \"next %s\"", cPVOP->op_pv);
2297     }
2298     if (cxix < cxstack_ix)
2299         dounwind(cxix);
2300
2301     /* clear off anything above the scope we're re-entering, but
2302      * save the rest until after a possible continue block */
2303     inner = PL_scopestack_ix;
2304     TOPBLOCK(cx);
2305     if (PL_scopestack_ix < inner)
2306         leave_scope(PL_scopestack[PL_scopestack_ix]);
2307     PL_curcop = cx->blk_oldcop;
2308     return CX_LOOP_NEXTOP_GET(cx);
2309 }
2310
2311 PP(pp_redo)
2312 {
2313     dVAR;
2314     I32 cxix;
2315     register PERL_CONTEXT *cx;
2316     I32 oldsave;
2317     OP* redo_op;
2318
2319     if (PL_op->op_flags & OPf_SPECIAL) {
2320         cxix = dopoptoloop(cxstack_ix);
2321         if (cxix < 0)
2322             DIE(aTHX_ "Can't \"redo\" outside a loop block");
2323     }
2324     else {
2325         cxix = dopoptolabel(cPVOP->op_pv);
2326         if (cxix < 0)
2327             DIE(aTHX_ "Label not found for \"redo %s\"", cPVOP->op_pv);
2328     }
2329     if (cxix < cxstack_ix)
2330         dounwind(cxix);
2331
2332     redo_op = cxstack[cxix].blk_loop.my_op->op_redoop;
2333     if (redo_op->op_type == OP_ENTER) {
2334         /* pop one less context to avoid $x being freed in while (my $x..) */
2335         cxstack_ix++;
2336         assert(CxTYPE(&cxstack[cxstack_ix]) == CXt_BLOCK);
2337         redo_op = redo_op->op_next;
2338     }
2339
2340     TOPBLOCK(cx);
2341     oldsave = PL_scopestack[PL_scopestack_ix - 1];
2342     LEAVE_SCOPE(oldsave);
2343     FREETMPS;
2344     PL_curcop = cx->blk_oldcop;
2345     return redo_op;
2346 }
2347
2348 STATIC OP *
2349 S_dofindlabel(pTHX_ OP *o, const char *label, OP **opstack, OP **oplimit)
2350 {
2351     dVAR;
2352     OP **ops = opstack;
2353     static const char too_deep[] = "Target of goto is too deeply nested";
2354
2355     PERL_ARGS_ASSERT_DOFINDLABEL;
2356
2357     if (ops >= oplimit)
2358         Perl_croak(aTHX_ too_deep);
2359     if (o->op_type == OP_LEAVE ||
2360         o->op_type == OP_SCOPE ||
2361         o->op_type == OP_LEAVELOOP ||
2362         o->op_type == OP_LEAVESUB ||
2363         o->op_type == OP_LEAVETRY)
2364     {
2365         *ops++ = cUNOPo->op_first;
2366         if (ops >= oplimit)
2367             Perl_croak(aTHX_ too_deep);
2368     }
2369     *ops = 0;
2370     if (o->op_flags & OPf_KIDS) {
2371         OP *kid;
2372         /* First try all the kids at this level, since that's likeliest. */
2373         for (kid = cUNOPo->op_first; kid; kid = kid->op_sibling) {
2374             if ((kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE) &&
2375                     CopLABEL(kCOP) && strEQ(CopLABEL(kCOP), label))
2376                 return kid;
2377         }
2378         for (kid = cUNOPo->op_first; kid; kid = kid->op_sibling) {
2379             if (kid == PL_lastgotoprobe)
2380                 continue;
2381             if (kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE) {
2382                 if (ops == opstack)
2383                     *ops++ = kid;
2384                 else if (ops[-1]->op_type == OP_NEXTSTATE ||
2385                          ops[-1]->op_type == OP_DBSTATE)
2386                     ops[-1] = kid;
2387                 else
2388                     *ops++ = kid;
2389             }
2390             if ((o = dofindlabel(kid, label, ops, oplimit)))
2391                 return o;
2392         }
2393     }
2394     *ops = 0;
2395     return 0;
2396 }
2397
2398 PP(pp_goto)
2399 {
2400     dVAR; dSP;
2401     OP *retop = NULL;
2402     I32 ix;
2403     register PERL_CONTEXT *cx;
2404 #define GOTO_DEPTH 64
2405     OP *enterops[GOTO_DEPTH];
2406     const char *label = NULL;
2407     const bool do_dump = (PL_op->op_type == OP_DUMP);
2408     static const char must_have_label[] = "goto must have label";
2409
2410     if (PL_op->op_flags & OPf_STACKED) {
2411         SV * const sv = POPs;
2412
2413         /* This egregious kludge implements goto &subroutine */
2414         if (SvROK(sv) && SvTYPE(SvRV(sv)) == SVt_PVCV) {
2415             I32 cxix;
2416             register PERL_CONTEXT *cx;
2417             CV *cv = MUTABLE_CV(SvRV(sv));
2418             SV** mark;
2419             I32 items = 0;
2420             I32 oldsave;
2421             bool reified = 0;
2422
2423         retry:
2424             if (!CvROOT(cv) && !CvXSUB(cv)) {
2425                 const GV * const gv = CvGV(cv);
2426                 if (gv) {
2427                     GV *autogv;
2428                     SV *tmpstr;
2429                     /* autoloaded stub? */
2430                     if (cv != GvCV(gv) && (cv = GvCV(gv)))
2431                         goto retry;
2432                     autogv = gv_autoload4(GvSTASH(gv), GvNAME(gv),
2433                                           GvNAMELEN(gv), FALSE);
2434                     if (autogv && (cv = GvCV(autogv)))
2435                         goto retry;
2436                     tmpstr = sv_newmortal();
2437                     gv_efullname3(tmpstr, gv, NULL);
2438                     DIE(aTHX_ "Goto undefined subroutine &%"SVf"", SVfARG(tmpstr));
2439                 }
2440                 DIE(aTHX_ "Goto undefined subroutine");
2441             }
2442
2443             /* First do some returnish stuff. */
2444             SvREFCNT_inc_simple_void(cv); /* avoid premature free during unwind */
2445             FREETMPS;
2446             cxix = dopoptosub(cxstack_ix);
2447             if (cxix < 0)
2448                 DIE(aTHX_ "Can't goto subroutine outside a subroutine");
2449             if (cxix < cxstack_ix)
2450                 dounwind(cxix);
2451             TOPBLOCK(cx);
2452             SPAGAIN;
2453             /* ban goto in eval: see <20050521150056.GC20213@iabyn.com> */
2454             if (CxTYPE(cx) == CXt_EVAL) {
2455                 if (CxREALEVAL(cx))
2456                     DIE(aTHX_ "Can't goto subroutine from an eval-string");
2457                 else
2458                     DIE(aTHX_ "Can't goto subroutine from an eval-block");
2459             }
2460             else if (CxMULTICALL(cx))
2461                 DIE(aTHX_ "Can't goto subroutine from a sort sub (or similar callback)");
2462             if (CxTYPE(cx) == CXt_SUB && CxHASARGS(cx)) {
2463                 /* put @_ back onto stack */
2464                 AV* av = cx->blk_sub.argarray;
2465
2466                 items = AvFILLp(av) + 1;
2467                 EXTEND(SP, items+1); /* @_ could have been extended. */
2468                 Copy(AvARRAY(av), SP + 1, items, SV*);
2469                 SvREFCNT_dec(GvAV(PL_defgv));
2470                 GvAV(PL_defgv) = cx->blk_sub.savearray;
2471                 CLEAR_ARGARRAY(av);
2472                 /* abandon @_ if it got reified */
2473                 if (AvREAL(av)) {
2474                     reified = 1;
2475                     SvREFCNT_dec(av);
2476                     av = newAV();
2477                     av_extend(av, items-1);
2478                     AvREIFY_only(av);
2479                     PAD_SVl(0) = MUTABLE_SV(cx->blk_sub.argarray = av);
2480                 }
2481             }
2482             else if (CvISXSUB(cv)) {    /* put GvAV(defgv) back onto stack */
2483                 AV* const av = GvAV(PL_defgv);
2484                 items = AvFILLp(av) + 1;
2485                 EXTEND(SP, items+1); /* @_ could have been extended. */
2486                 Copy(AvARRAY(av), SP + 1, items, SV*);
2487             }
2488             mark = SP;
2489             SP += items;
2490             if (CxTYPE(cx) == CXt_SUB &&
2491                 !(CvDEPTH(cx->blk_sub.cv) = cx->blk_sub.olddepth))
2492                 SvREFCNT_dec(cx->blk_sub.cv);
2493             oldsave = PL_scopestack[PL_scopestack_ix - 1];
2494             LEAVE_SCOPE(oldsave);
2495
2496             /* Now do some callish stuff. */
2497             SAVETMPS;
2498             SAVEFREESV(cv); /* later, undo the 'avoid premature free' hack */
2499             if (CvISXSUB(cv)) {
2500                 OP* const retop = cx->blk_sub.retop;
2501                 SV **newsp;
2502                 I32 gimme;
2503                 if (reified) {
2504                     I32 index;
2505                     for (index=0; index<items; index++)
2506                         sv_2mortal(SP[-index]);
2507                 }
2508
2509                 /* XS subs don't have a CxSUB, so pop it */
2510                 POPBLOCK(cx, PL_curpm);
2511                 /* Push a mark for the start of arglist */
2512                 PUSHMARK(mark);
2513                 PUTBACK;
2514                 (void)(*CvXSUB(cv))(aTHX_ cv);
2515                 LEAVE;
2516                 return retop;
2517             }
2518             else {
2519                 AV* const padlist = CvPADLIST(cv);
2520                 if (CxTYPE(cx) == CXt_EVAL) {
2521                     PL_in_eval = CxOLD_IN_EVAL(cx);
2522                     PL_eval_root = cx->blk_eval.old_eval_root;
2523                     cx->cx_type = CXt_SUB;
2524                 }
2525                 cx->blk_sub.cv = cv;
2526                 cx->blk_sub.olddepth = CvDEPTH(cv);
2527
2528                 CvDEPTH(cv)++;
2529                 if (CvDEPTH(cv) < 2)
2530                     SvREFCNT_inc_simple_void_NN(cv);
2531                 else {
2532                     if (CvDEPTH(cv) == PERL_SUB_DEPTH_WARN && ckWARN(WARN_RECURSION))
2533                         sub_crush_depth(cv);
2534                     pad_push(padlist, CvDEPTH(cv));
2535                 }
2536                 SAVECOMPPAD();
2537                 PAD_SET_CUR_NOSAVE(padlist, CvDEPTH(cv));
2538                 if (CxHASARGS(cx))
2539                 {
2540                     AV *const av = MUTABLE_AV(PAD_SVl(0));
2541
2542                     cx->blk_sub.savearray = GvAV(PL_defgv);
2543                     GvAV(PL_defgv) = MUTABLE_AV(SvREFCNT_inc_simple(av));
2544                     CX_CURPAD_SAVE(cx->blk_sub);
2545                     cx->blk_sub.argarray = av;
2546
2547                     if (items >= AvMAX(av) + 1) {
2548                         SV **ary = AvALLOC(av);
2549                         if (AvARRAY(av) != ary) {
2550                             AvMAX(av) += AvARRAY(av) - AvALLOC(av);
2551                             AvARRAY(av) = ary;
2552                         }
2553                         if (items >= AvMAX(av) + 1) {
2554                             AvMAX(av) = items - 1;
2555                             Renew(ary,items+1,SV*);
2556                             AvALLOC(av) = ary;
2557                             AvARRAY(av) = ary;
2558                         }
2559                     }
2560                     ++mark;
2561                     Copy(mark,AvARRAY(av),items,SV*);
2562                     AvFILLp(av) = items - 1;
2563                     assert(!AvREAL(av));
2564                     if (reified) {
2565                         /* transfer 'ownership' of refcnts to new @_ */
2566                         AvREAL_on(av);
2567                         AvREIFY_off(av);
2568                     }
2569                     while (items--) {
2570                         if (*mark)
2571                             SvTEMP_off(*mark);
2572                         mark++;
2573                     }
2574                 }
2575                 if (PERLDB_SUB) {       /* Checking curstash breaks DProf. */
2576                     Perl_get_db_sub(aTHX_ NULL, cv);
2577                     if (PERLDB_GOTO) {
2578                         CV * const gotocv = get_cvs("DB::goto", 0);
2579                         if (gotocv) {
2580                             PUSHMARK( PL_stack_sp );
2581                             call_sv(MUTABLE_SV(gotocv), G_SCALAR | G_NODEBUG);
2582                             PL_stack_sp--;
2583                         }
2584                     }
2585                 }
2586                 RETURNOP(CvSTART(cv));
2587             }
2588         }
2589         else {
2590             label = SvPV_nolen_const(sv);
2591             if (!(do_dump || *label))
2592                 DIE(aTHX_ must_have_label);
2593         }
2594     }
2595     else if (PL_op->op_flags & OPf_SPECIAL) {
2596         if (! do_dump)
2597             DIE(aTHX_ must_have_label);
2598     }
2599     else
2600         label = cPVOP->op_pv;
2601
2602     if (label && *label) {
2603         OP *gotoprobe = NULL;
2604         bool leaving_eval = FALSE;
2605         bool in_block = FALSE;
2606         PERL_CONTEXT *last_eval_cx = NULL;
2607
2608         /* find label */
2609
2610         PL_lastgotoprobe = NULL;
2611         *enterops = 0;
2612         for (ix = cxstack_ix; ix >= 0; ix--) {
2613             cx = &cxstack[ix];
2614             switch (CxTYPE(cx)) {
2615             case CXt_EVAL:
2616                 leaving_eval = TRUE;
2617                 if (!CxTRYBLOCK(cx)) {
2618                     gotoprobe = (last_eval_cx ?
2619                                 last_eval_cx->blk_eval.old_eval_root :
2620                                 PL_eval_root);
2621                     last_eval_cx = cx;
2622                     break;
2623                 }
2624                 /* else fall through */
2625             case CXt_LOOP_LAZYIV:
2626             case CXt_LOOP_LAZYSV:
2627             case CXt_LOOP_FOR:
2628             case CXt_LOOP_PLAIN:
2629                 gotoprobe = cx->blk_oldcop->op_sibling;
2630                 break;
2631             case CXt_SUBST:
2632                 continue;
2633             case CXt_BLOCK:
2634                 if (ix) {
2635                     gotoprobe = cx->blk_oldcop->op_sibling;
2636                     in_block = TRUE;
2637                 } else
2638                     gotoprobe = PL_main_root;
2639                 break;
2640             case CXt_SUB:
2641                 if (CvDEPTH(cx->blk_sub.cv) && !CxMULTICALL(cx)) {
2642                     gotoprobe = CvROOT(cx->blk_sub.cv);
2643                     break;
2644                 }
2645                 /* FALL THROUGH */
2646             case CXt_FORMAT:
2647             case CXt_NULL:
2648                 DIE(aTHX_ "Can't \"goto\" out of a pseudo block");
2649             default:
2650                 if (ix)
2651                     DIE(aTHX_ "panic: goto");
2652                 gotoprobe = PL_main_root;
2653                 break;
2654             }
2655             if (gotoprobe) {
2656                 retop = dofindlabel(gotoprobe, label,
2657                                     enterops, enterops + GOTO_DEPTH);
2658                 if (retop)
2659                     break;
2660             }
2661             PL_lastgotoprobe = gotoprobe;
2662         }
2663         if (!retop)
2664             DIE(aTHX_ "Can't find label %s", label);
2665
2666         /* if we're leaving an eval, check before we pop any frames
2667            that we're not going to punt, otherwise the error
2668            won't be caught */
2669
2670         if (leaving_eval && *enterops && enterops[1]) {
2671             I32 i;
2672             for (i = 1; enterops[i]; i++)
2673                 if (enterops[i]->op_type == OP_ENTERITER)
2674                     DIE(aTHX_ "Can't \"goto\" into the middle of a foreach loop");
2675         }
2676
2677         /* pop unwanted frames */
2678
2679         if (ix < cxstack_ix) {
2680             I32 oldsave;
2681
2682             if (ix < 0)
2683                 ix = 0;
2684             dounwind(ix);
2685             TOPBLOCK(cx);
2686             oldsave = PL_scopestack[PL_scopestack_ix];
2687             LEAVE_SCOPE(oldsave);
2688         }
2689
2690         /* push wanted frames */
2691
2692         if (*enterops && enterops[1]) {
2693             OP * const oldop = PL_op;
2694             ix = enterops[1]->op_type == OP_ENTER && in_block ? 2 : 1;
2695             for (; enterops[ix]; ix++) {
2696                 PL_op = enterops[ix];
2697                 /* Eventually we may want to stack the needed arguments
2698                  * for each op.  For now, we punt on the hard ones. */
2699                 if (PL_op->op_type == OP_ENTERITER)
2700                     DIE(aTHX_ "Can't \"goto\" into the middle of a foreach loop");
2701                 CALL_FPTR(PL_op->op_ppaddr)(aTHX);
2702             }
2703             PL_op = oldop;
2704         }
2705     }
2706
2707     if (do_dump) {
2708 #ifdef VMS
2709         if (!retop) retop = PL_main_start;
2710 #endif
2711         PL_restartop = retop;
2712         PL_do_undump = TRUE;
2713
2714         my_unexec();
2715
2716         PL_restartop = 0;               /* hmm, must be GNU unexec().. */
2717         PL_do_undump = FALSE;
2718     }
2719
2720     RETURNOP(retop);
2721 }
2722
2723 PP(pp_exit)
2724 {
2725     dVAR;
2726     dSP;
2727     I32 anum;
2728
2729     if (MAXARG < 1)
2730         anum = 0;
2731     else {
2732         anum = SvIVx(POPs);
2733 #ifdef VMS
2734         if (anum == 1 && (PL_op->op_private & OPpEXIT_VMSISH))
2735             anum = 0;
2736         VMSISH_HUSHED  = VMSISH_HUSHED || (PL_op->op_private & OPpHUSH_VMSISH);
2737 #endif
2738     }
2739     PL_exit_flags |= PERL_EXIT_EXPECTED;
2740 #ifdef PERL_MAD
2741     /* KLUDGE: disable exit 0 in BEGIN blocks when we're just compiling */
2742     if (anum || !(PL_minus_c && PL_madskills))
2743         my_exit(anum);
2744 #else
2745     my_exit(anum);
2746 #endif
2747     PUSHs(&PL_sv_undef);
2748     RETURN;
2749 }
2750
2751 /* Eval. */
2752
2753 STATIC void
2754 S_save_lines(pTHX_ AV *array, SV *sv)
2755 {
2756     const char *s = SvPVX_const(sv);
2757     const char * const send = SvPVX_const(sv) + SvCUR(sv);
2758     I32 line = 1;
2759
2760     PERL_ARGS_ASSERT_SAVE_LINES;
2761
2762     while (s && s < send) {
2763         const char *t;
2764         SV * const tmpstr = newSV_type(SVt_PVMG);
2765
2766         t = (const char *)memchr(s, '\n', send - s);
2767         if (t)
2768             t++;
2769         else
2770             t = send;
2771
2772         sv_setpvn(tmpstr, s, t - s);
2773         av_store(array, line++, tmpstr);
2774         s = t;
2775     }
2776 }
2777
2778 STATIC OP *
2779 S_docatch(pTHX_ OP *o)
2780 {
2781     dVAR;
2782     int ret;
2783     OP * const oldop = PL_op;
2784     dJMPENV;
2785
2786 #ifdef DEBUGGING
2787     assert(CATCH_GET == TRUE);
2788 #endif
2789     PL_op = o;
2790
2791     JMPENV_PUSH(ret);
2792     switch (ret) {
2793     case 0:
2794         assert(cxstack_ix >= 0);
2795         assert(CxTYPE(&cxstack[cxstack_ix]) == CXt_EVAL);
2796         cxstack[cxstack_ix].blk_eval.cur_top_env = PL_top_env;
2797  redo_body:
2798         CALLRUNOPS(aTHX);
2799         break;
2800     case 3:
2801         /* die caught by an inner eval - continue inner loop */
2802
2803         /* NB XXX we rely on the old popped CxEVAL still being at the top
2804          * of the stack; the way die_where() currently works, this
2805          * assumption is valid. In theory The cur_top_env value should be
2806          * returned in another global, the way retop (aka PL_restartop)
2807          * is. */
2808         assert(CxTYPE(&cxstack[cxstack_ix+1]) == CXt_EVAL);
2809
2810         if (PL_restartop
2811             && cxstack[cxstack_ix+1].blk_eval.cur_top_env == PL_top_env)
2812         {
2813             PL_op = PL_restartop;
2814             PL_restartop = 0;
2815             goto redo_body;
2816         }
2817         /* FALL THROUGH */
2818     default:
2819         JMPENV_POP;
2820         PL_op = oldop;
2821         JMPENV_JUMP(ret);
2822         /* NOTREACHED */
2823     }
2824     JMPENV_POP;
2825     PL_op = oldop;
2826     return NULL;
2827 }
2828
2829 OP *
2830 Perl_sv_compile_2op(pTHX_ SV *sv, OP** startop, const char *code, PAD** padp)
2831 /* sv Text to convert to OP tree. */
2832 /* startop op_free() this to undo. */
2833 /* code Short string id of the caller. */
2834 {
2835     /* FIXME - how much of this code is common with pp_entereval?  */
2836     dVAR; dSP;                          /* Make POPBLOCK work. */
2837     PERL_CONTEXT *cx;
2838     SV **newsp;
2839     I32 gimme = G_VOID;
2840     I32 optype;
2841     OP dummy;
2842     char tbuf[TYPE_DIGITS(long) + 12 + 10];
2843     char *tmpbuf = tbuf;
2844     char *safestr;
2845     int runtime;
2846     CV* runcv = NULL;   /* initialise to avoid compiler warnings */
2847     STRLEN len;
2848
2849     PERL_ARGS_ASSERT_SV_COMPILE_2OP;
2850
2851     ENTER;
2852     lex_start(sv, NULL, FALSE);
2853     SAVETMPS;
2854     /* switch to eval mode */
2855
2856     if (IN_PERL_COMPILETIME) {
2857         SAVECOPSTASH_FREE(&PL_compiling);
2858         CopSTASH_set(&PL_compiling, PL_curstash);
2859     }
2860     if (PERLDB_NAMEEVAL && CopLINE(PL_curcop)) {
2861         SV * const sv = sv_newmortal();
2862         Perl_sv_setpvf(aTHX_ sv, "_<(%.10seval %lu)[%s:%"IVdf"]",
2863                        code, (unsigned long)++PL_evalseq,
2864                        CopFILE(PL_curcop), (IV)CopLINE(PL_curcop));
2865         tmpbuf = SvPVX(sv);
2866         len = SvCUR(sv);
2867     }
2868     else
2869         len = my_snprintf(tmpbuf, sizeof(tbuf), "_<(%.10s_eval %lu)", code,
2870                           (unsigned long)++PL_evalseq);
2871     SAVECOPFILE_FREE(&PL_compiling);
2872     CopFILE_set(&PL_compiling, tmpbuf+2);
2873     SAVECOPLINE(&PL_compiling);
2874     CopLINE_set(&PL_compiling, 1);
2875     /* XXX For C<eval "...">s within BEGIN {} blocks, this ends up
2876        deleting the eval's FILEGV from the stash before gv_check() runs
2877        (i.e. before run-time proper). To work around the coredump that
2878        ensues, we always turn GvMULTI_on for any globals that were
2879        introduced within evals. See force_ident(). GSAR 96-10-12 */
2880     safestr = savepvn(tmpbuf, len);
2881     SAVEDELETE(PL_defstash, safestr, len);
2882     SAVEHINTS();
2883 #ifdef OP_IN_REGISTER
2884     PL_opsave = op;
2885 #else
2886     SAVEVPTR(PL_op);
2887 #endif
2888
2889     /* we get here either during compilation, or via pp_regcomp at runtime */
2890     runtime = IN_PERL_RUNTIME;
2891     if (runtime)
2892         runcv = find_runcv(NULL);
2893
2894     PL_op = &dummy;
2895     PL_op->op_type = OP_ENTEREVAL;
2896     PL_op->op_flags = 0;                        /* Avoid uninit warning. */
2897     PUSHBLOCK(cx, CXt_EVAL|(IN_PERL_COMPILETIME ? 0 : CXp_REAL), SP);
2898     PUSHEVAL(cx, 0);
2899
2900     if (runtime)
2901         (void) doeval(G_SCALAR, startop, runcv, PL_curcop->cop_seq);
2902     else
2903         (void) doeval(G_SCALAR, startop, PL_compcv, PL_cop_seqmax);
2904     POPBLOCK(cx,PL_curpm);
2905     POPEVAL(cx);
2906
2907     (*startop)->op_type = OP_NULL;
2908     (*startop)->op_ppaddr = PL_ppaddr[OP_NULL];
2909     lex_end();
2910     /* XXX DAPM do this properly one year */
2911     *padp = MUTABLE_AV(SvREFCNT_inc_simple(PL_comppad));
2912     LEAVE;
2913     if (IN_PERL_COMPILETIME)
2914         CopHINTS_set(&PL_compiling, PL_hints);
2915 #ifdef OP_IN_REGISTER
2916     op = PL_opsave;
2917 #endif
2918     PERL_UNUSED_VAR(newsp);
2919     PERL_UNUSED_VAR(optype);
2920
2921     return PL_eval_start;
2922 }
2923
2924
2925 /*
2926 =for apidoc find_runcv
2927
2928 Locate the CV corresponding to the currently executing sub or eval.
2929 If db_seqp is non_null, skip CVs that are in the DB package and populate
2930 *db_seqp with the cop sequence number at the point that the DB:: code was
2931 entered. (allows debuggers to eval in the scope of the breakpoint rather
2932 than in the scope of the debugger itself).
2933
2934 =cut
2935 */
2936
2937 CV*
2938 Perl_find_runcv(pTHX_ U32 *db_seqp)
2939 {
2940     dVAR;
2941     PERL_SI      *si;
2942
2943     if (db_seqp)
2944         *db_seqp = PL_curcop->cop_seq;
2945     for (si = PL_curstackinfo; si; si = si->si_prev) {
2946         I32 ix;
2947         for (ix = si->si_cxix; ix >= 0; ix--) {
2948             const PERL_CONTEXT *cx = &(si->si_cxstack[ix]);
2949             if (CxTYPE(cx) == CXt_SUB || CxTYPE(cx) == CXt_FORMAT) {
2950                 CV * const cv = cx->blk_sub.cv;
2951                 /* skip DB:: code */
2952                 if (db_seqp && PL_debstash && CvSTASH(cv) == PL_debstash) {
2953                     *db_seqp = cx->blk_oldcop->cop_seq;
2954                     continue;
2955                 }
2956                 return cv;
2957             }
2958             else if (CxTYPE(cx) == CXt_EVAL && !CxTRYBLOCK(cx))
2959                 return PL_compcv;
2960         }
2961     }
2962     return PL_main_cv;
2963 }
2964
2965
2966 /* Compile a require/do, an eval '', or a /(?{...})/.
2967  * In the last case, startop is non-null, and contains the address of
2968  * a pointer that should be set to the just-compiled code.
2969  * outside is the lexically enclosing CV (if any) that invoked us.
2970  * Returns a bool indicating whether the compile was successful; if so,
2971  * PL_eval_start contains the first op of the compiled ocde; otherwise,
2972  * pushes undef (also croaks if startop != NULL).
2973  */
2974
2975 STATIC bool
2976 S_doeval(pTHX_ int gimme, OP** startop, CV* outside, U32 seq)
2977 {
2978     dVAR; dSP;
2979     OP * const saveop = PL_op;
2980
2981     PL_in_eval = ((saveop && saveop->op_type == OP_REQUIRE)
2982                   ? (EVAL_INREQUIRE | (PL_in_eval & EVAL_INEVAL))
2983                   : EVAL_INEVAL);
2984
2985     PUSHMARK(SP);
2986
2987     SAVESPTR(PL_compcv);
2988     PL_compcv = MUTABLE_CV(newSV_type(SVt_PVCV));
2989     CvEVAL_on(PL_compcv);
2990     assert(CxTYPE(&cxstack[cxstack_ix]) == CXt_EVAL);
2991     cxstack[cxstack_ix].blk_eval.cv = PL_compcv;
2992
2993     CvOUTSIDE_SEQ(PL_compcv) = seq;
2994     CvOUTSIDE(PL_compcv) = MUTABLE_CV(SvREFCNT_inc_simple(outside));
2995
2996     /* set up a scratch pad */
2997
2998     CvPADLIST(PL_compcv) = pad_new(padnew_SAVE);
2999     PL_op = NULL; /* avoid PL_op and PL_curpad referring to different CVs */
3000
3001
3002     if (!PL_madskills)
3003         SAVEMORTALIZESV(PL_compcv);     /* must remain until end of current statement */
3004
3005     /* make sure we compile in the right package */
3006
3007     if (CopSTASH_ne(PL_curcop, PL_curstash)) {
3008         SAVESPTR(PL_curstash);
3009         PL_curstash = CopSTASH(PL_curcop);
3010     }
3011     /* XXX:ajgo do we really need to alloc an AV for begin/checkunit */
3012     SAVESPTR(PL_beginav);
3013     PL_beginav = newAV();
3014     SAVEFREESV(PL_beginav);
3015     SAVESPTR(PL_unitcheckav);
3016     PL_unitcheckav = newAV();
3017     SAVEFREESV(PL_unitcheckav);
3018
3019 #ifdef PERL_MAD
3020     SAVEBOOL(PL_madskills);
3021     PL_madskills = 0;
3022 #endif
3023
3024     /* try to compile it */
3025
3026     PL_eval_root = NULL;
3027     PL_curcop = &PL_compiling;
3028     CopARYBASE_set(PL_curcop, 0);
3029     if (saveop && (saveop->op_type != OP_REQUIRE) && (saveop->op_flags & OPf_SPECIAL))
3030         PL_in_eval |= EVAL_KEEPERR;
3031     else
3032         CLEAR_ERRSV();
3033     if (yyparse() || PL_parser->error_count || !PL_eval_root) {
3034         SV **newsp;                     /* Used by POPBLOCK. */
3035         PERL_CONTEXT *cx = &cxstack[cxstack_ix];
3036         I32 optype = 0;                 /* Might be reset by POPEVAL. */
3037         const char *msg;
3038
3039         PL_op = saveop;
3040         if (PL_eval_root) {
3041             op_free(PL_eval_root);
3042             PL_eval_root = NULL;
3043         }
3044         SP = PL_stack_base + POPMARK;           /* pop original mark */
3045         if (!startop) {
3046             POPBLOCK(cx,PL_curpm);
3047             POPEVAL(cx);
3048         }
3049         lex_end();
3050         LEAVE; /* pp_entereval knows about this LEAVE.  */
3051
3052         msg = SvPVx_nolen_const(ERRSV);
3053         if (optype == OP_REQUIRE) {
3054             const SV * const nsv = cx->blk_eval.old_namesv;
3055             (void)hv_store(GvHVn(PL_incgv), SvPVX_const(nsv), SvCUR(nsv),
3056                           &PL_sv_undef, 0);
3057             Perl_croak(aTHX_ "%sCompilation failed in require",
3058                        *msg ? msg : "Unknown error\n");
3059         }
3060         else if (startop) {
3061             POPBLOCK(cx,PL_curpm);
3062             POPEVAL(cx);
3063             Perl_croak(aTHX_ "%sCompilation failed in regexp",
3064                        (*msg ? msg : "Unknown error\n"));
3065         }
3066         else {
3067             if (!*msg) {
3068                 sv_setpvs(ERRSV, "Compilation error");
3069             }
3070         }
3071         PERL_UNUSED_VAR(newsp);
3072         PUSHs(&PL_sv_undef);
3073         PUTBACK;
3074         return FALSE;
3075     }
3076     CopLINE_set(&PL_compiling, 0);
3077     if (startop) {
3078         *startop = PL_eval_root;
3079     } else
3080         SAVEFREEOP(PL_eval_root);
3081
3082     /* Set the context for this new optree.
3083      * If the last op is an OP_REQUIRE, force scalar context.
3084      * Otherwise, propagate the context from the eval(). */
3085     if (PL_eval_root->op_type == OP_LEAVEEVAL
3086             && cUNOPx(PL_eval_root)->op_first->op_type == OP_LINESEQ
3087             && cLISTOPx(cUNOPx(PL_eval_root)->op_first)->op_last->op_type
3088             == OP_REQUIRE)
3089         scalar(PL_eval_root);
3090     else if ((gimme & G_WANT) == G_VOID)
3091         scalarvoid(PL_eval_root);
3092     else if ((gimme & G_WANT) == G_ARRAY)
3093         list(PL_eval_root);
3094     else
3095         scalar(PL_eval_root);
3096
3097     DEBUG_x(dump_eval());
3098
3099     /* Register with debugger: */
3100     if (PERLDB_INTER && saveop && saveop->op_type == OP_REQUIRE) {
3101         CV * const cv = get_cvs("DB::postponed", 0);
3102         if (cv) {
3103             dSP;
3104             PUSHMARK(SP);
3105             XPUSHs(MUTABLE_SV(CopFILEGV(&PL_compiling)));
3106             PUTBACK;
3107             call_sv(MUTABLE_SV(cv), G_DISCARD);
3108         }
3109     }
3110
3111     if (PL_unitcheckav)
3112         call_list(PL_scopestack_ix, PL_unitcheckav);
3113
3114     /* compiled okay, so do it */
3115
3116     CvDEPTH(PL_compcv) = 1;
3117     SP = PL_stack_base + POPMARK;               /* pop original mark */
3118     PL_op = saveop;                     /* The caller may need it. */
3119     PL_parser->lex_state = LEX_NOTPARSING;      /* $^S needs this. */
3120
3121     PUTBACK;
3122     return TRUE;
3123 }
3124
3125 STATIC PerlIO *
3126 S_check_type_and_open(pTHX_ const char *name)
3127 {
3128     Stat_t st;
3129     const int st_rc = PerlLIO_stat(name, &st);
3130
3131     PERL_ARGS_ASSERT_CHECK_TYPE_AND_OPEN;
3132
3133     if (st_rc < 0 || S_ISDIR(st.st_mode) || S_ISBLK(st.st_mode)) {
3134         return NULL;
3135     }
3136
3137     return PerlIO_open(name, PERL_SCRIPT_MODE);
3138 }
3139
3140 #ifndef PERL_DISABLE_PMC
3141 STATIC PerlIO *
3142 S_doopen_pm(pTHX_ const char *name, const STRLEN namelen)
3143 {
3144     PerlIO *fp;
3145
3146     PERL_ARGS_ASSERT_DOOPEN_PM;
3147
3148     if (namelen > 3 && memEQs(name + namelen - 3, 3, ".pm")) {
3149         SV *const pmcsv = newSV(namelen + 2);
3150         char *const pmc = SvPVX(pmcsv);
3151         Stat_t pmcstat;
3152
3153         memcpy(pmc, name, namelen);
3154         pmc[namelen] = 'c';
3155         pmc[namelen + 1] = '\0';
3156
3157         if (PerlLIO_stat(pmc, &pmcstat) < 0) {
3158             fp = check_type_and_open(name);
3159         }
3160         else {
3161             fp = check_type_and_open(pmc);
3162         }
3163         SvREFCNT_dec(pmcsv);
3164     }
3165     else {
3166         fp = check_type_and_open(name);
3167     }
3168     return fp;
3169 }
3170 #else
3171 #  define doopen_pm(name, namelen) check_type_and_open(name)
3172 #endif /* !PERL_DISABLE_PMC */
3173
3174 PP(pp_require)
3175 {
3176     dVAR; dSP;
3177     register PERL_CONTEXT *cx;
3178     SV *sv;
3179     const char *name;
3180     STRLEN len;
3181     char * unixname;
3182     STRLEN unixlen;
3183 #ifdef VMS
3184     int vms_unixname = 0;
3185 #endif
3186     const char *tryname = NULL;
3187     SV *namesv = NULL;
3188     const I32 gimme = GIMME_V;
3189     int filter_has_file = 0;
3190     PerlIO *tryrsfp = NULL;
3191     SV *filter_cache = NULL;
3192     SV *filter_state = NULL;
3193     SV *filter_sub = NULL;
3194     SV *hook_sv = NULL;
3195     SV *encoding;
3196     OP *op;
3197
3198     sv = POPs;
3199     if ( (SvNIOKp(sv) || SvVOK(sv)) && PL_op->op_type != OP_DOFILE) {
3200         sv = new_version(sv);
3201         if (!sv_derived_from(PL_patchlevel, "version"))
3202             upg_version(PL_patchlevel, TRUE);
3203         if (cUNOP->op_first->op_type == OP_CONST && cUNOP->op_first->op_private & OPpCONST_NOVER) {
3204             if ( vcmp(sv,PL_patchlevel) <= 0 )
3205                 DIE(aTHX_ "Perls since %"SVf" too modern--this is %"SVf", stopped",
3206                     SVfARG(vnormal(sv)), SVfARG(vnormal(PL_patchlevel)));
3207         }
3208         else {
3209             if ( vcmp(sv,PL_patchlevel) > 0 ) {
3210                 I32 first = 0;
3211                 AV *lav;
3212                 SV * const req = SvRV(sv);
3213                 SV * const pv = *hv_fetchs(MUTABLE_HV(req), "original", FALSE);
3214
3215                 /* get the left hand term */
3216                 lav = MUTABLE_AV(SvRV(*hv_fetchs(MUTABLE_HV(req), "version", FALSE)));
3217
3218                 first  = SvIV(*av_fetch(lav,0,0));
3219                 if (   first > (int)PERL_REVISION    /* probably 'use 6.0' */
3220                     || hv_exists(MUTABLE_HV(req), "qv", 2 ) /* qv style */
3221                     || av_len(lav) > 1               /* FP with > 3 digits */
3222                     || strstr(SvPVX(pv),".0")        /* FP with leading 0 */
3223                    ) {
3224                     DIE(aTHX_ "Perl %"SVf" required--this is only "
3225                         "%"SVf", stopped", SVfARG(vnormal(req)),
3226                         SVfARG(vnormal(PL_patchlevel)));
3227                 }
3228                 else { /* probably 'use 5.10' or 'use 5.8' */
3229                     SV * hintsv = newSV(0);
3230                     I32 second = 0;
3231
3232                     if (av_len(lav)>=1)
3233                         second = SvIV(*av_fetch(lav,1,0));
3234
3235                     second /= second >= 600  ? 100 : 10;
3236                     hintsv = Perl_newSVpvf(aTHX_ "v%d.%d.%d",
3237                         (int)first, (int)second,0);
3238                     upg_version(hintsv, TRUE);
3239
3240                     DIE(aTHX_ "Perl %"SVf" required (did you mean %"SVf"?)"
3241                         "--this is only %"SVf", stopped",
3242                         SVfARG(vnormal(req)),
3243                         SVfARG(vnormal(hintsv)),
3244                         SVfARG(vnormal(PL_patchlevel)));
3245                 }
3246             }
3247         }
3248
3249         /* We do this only with use, not require. */
3250         if (PL_compcv &&
3251           /* If we request a version >= 5.9.5, load feature.pm with the
3252            * feature bundle that corresponds to the required version. */
3253                 vcmp(sv, sv_2mortal(upg_version(newSVnv(5.009005), FALSE))) >= 0) {
3254             SV *const importsv = vnormal(sv);
3255             *SvPVX_mutable(importsv) = ':';
3256             ENTER;
3257             Perl_load_module(aTHX_ 0, newSVpvs("feature"), NULL, importsv, NULL);
3258             LEAVE;
3259         }
3260
3261         RETPUSHYES;
3262     }
3263     name = SvPV_const(sv, len);
3264     if (!(name && len > 0 && *name))
3265         DIE(aTHX_ "Null filename used");
3266     TAINT_PROPER("require");
3267
3268
3269 #ifdef VMS
3270     /* The key in the %ENV hash is in the syntax of file passed as the argument
3271      * usually this is in UNIX format, but sometimes in VMS format, which
3272      * can result in a module being pulled in more than once.
3273      * To prevent this, the key must be stored in UNIX format if the VMS
3274      * name can be translated to UNIX.
3275      */
3276     if ((unixname = tounixspec(name, NULL)) != NULL) {
3277         unixlen = strlen(unixname);
3278         vms_unixname = 1;
3279     }
3280     else
3281 #endif
3282     {
3283         /* if not VMS or VMS name can not be translated to UNIX, pass it
3284          * through.
3285          */
3286         unixname = (char *) name;
3287         unixlen = len;
3288     }
3289     if (PL_op->op_type == OP_REQUIRE) {
3290         SV * const * const svp = hv_fetch(GvHVn(PL_incgv),
3291                                           unixname, unixlen, 0);
3292         if ( svp ) {
3293             if (*svp != &PL_sv_undef)
3294                 RETPUSHYES;
3295             else
3296                 DIE(aTHX_ "Attempt to reload %s aborted.\n"
3297                             "Compilation failed in require", unixname);
3298         }
3299     }
3300
3301     /* prepare to compile file */
3302
3303     if (path_is_absolute(name)) {
3304         tryname = name;
3305         tryrsfp = doopen_pm(name, len);
3306     }
3307 #ifdef MACOS_TRADITIONAL
3308     if (!tryrsfp) {
3309         char newname[256];
3310
3311         MacPerl_CanonDir(name, newname, 1);
3312         if (path_is_absolute(newname)) {
3313             tryname = newname;
3314             tryrsfp = doopen_pm(newname, strlen(newname));
3315         }
3316     }
3317 #endif
3318     if (!tryrsfp) {
3319         AV * const ar = GvAVn(PL_incgv);
3320         I32 i;
3321 #ifdef VMS
3322         if (vms_unixname)
3323 #endif
3324         {
3325             namesv = newSV_type(SVt_PV);
3326             for (i = 0; i <= AvFILL(ar); i++) {
3327                 SV * const dirsv = *av_fetch(ar, i, TRUE);
3328
3329                 if (SvTIED_mg((const SV *)ar, PERL_MAGIC_tied))
3330                     mg_get(dirsv);
3331                 if (SvROK(dirsv)) {
3332                     int count;
3333                     SV **svp;
3334                     SV *loader = dirsv;
3335
3336                     if (SvTYPE(SvRV(loader)) == SVt_PVAV
3337                         && !sv_isobject(loader))
3338                     {
3339                         loader = *av_fetch(MUTABLE_AV(SvRV(loader)), 0, TRUE);
3340                     }
3341
3342                     Perl_sv_setpvf(aTHX_ namesv, "/loader/0x%"UVxf"/%s",
3343                                    PTR2UV(SvRV(dirsv)), name);
3344                     tryname = SvPVX_const(namesv);
3345                     tryrsfp = NULL;
3346
3347                     ENTER;
3348                     SAVETMPS;
3349                     EXTEND(SP, 2);
3350
3351                     PUSHMARK(SP);
3352                     PUSHs(dirsv);
3353                     PUSHs(sv);
3354                     PUTBACK;
3355                     if (sv_isobject(loader))
3356                         count = call_method("INC", G_ARRAY);
3357                     else
3358                         count = call_sv(loader, G_ARRAY);
3359                     SPAGAIN;
3360
3361                     /* Adjust file name if the hook has set an %INC entry */
3362                     svp = hv_fetch(GvHVn(PL_incgv), name, len, 0);
3363                     if (svp)
3364                         tryname = SvPVX_const(*svp);
3365
3366                     if (count > 0) {
3367                         int i = 0;
3368                         SV *arg;
3369
3370                         SP -= count - 1;
3371                         arg = SP[i++];
3372
3373                         if (SvROK(arg) && (SvTYPE(SvRV(arg)) <= SVt_PVLV)
3374                             && !isGV_with_GP(SvRV(arg))) {
3375                             filter_cache = SvRV(arg);
3376                             SvREFCNT_inc_simple_void_NN(filter_cache);
3377
3378                             if (i < count) {
3379                                 arg = SP[i++];
3380                             }
3381                         }
3382
3383                         if (SvROK(arg) && isGV_with_GP(SvRV(arg))) {
3384                             arg = SvRV(arg);
3385                         }
3386
3387                         if (isGV_with_GP(arg)) {
3388                             IO * const io = GvIO((const GV *)arg);
3389
3390                             ++filter_has_file;
3391
3392                             if (io) {
3393                                 tryrsfp = IoIFP(io);
3394                                 if (IoOFP(io) && IoOFP(io) != IoIFP(io)) {
3395                                     PerlIO_close(IoOFP(io));
3396                                 }
3397                                 IoIFP(io) = NULL;
3398                                 IoOFP(io) = NULL;
3399                             }
3400
3401                             if (i < count) {
3402                                 arg = SP[i++];
3403                             }
3404                         }
3405
3406                         if (SvROK(arg) && SvTYPE(SvRV(arg)) == SVt_PVCV) {
3407                             filter_sub = arg;
3408                             SvREFCNT_inc_simple_void_NN(filter_sub);
3409
3410                             if (i < count) {
3411                                 filter_state = SP[i];
3412                                 SvREFCNT_inc_simple_void(filter_state);
3413                             }
3414                         }
3415
3416                         if (!tryrsfp && (filter_cache || filter_sub)) {
3417                             tryrsfp = PerlIO_open(BIT_BUCKET,
3418                                                   PERL_SCRIPT_MODE);
3419                         }
3420                         SP--;
3421                     }
3422
3423                     PUTBACK;
3424                     FREETMPS;
3425                     LEAVE;
3426
3427                     if (tryrsfp) {
3428                         hook_sv = dirsv;
3429                         break;
3430                     }
3431
3432                     filter_has_file = 0;
3433                     if (filter_cache) {
3434                         SvREFCNT_dec(filter_cache);
3435                         filter_cache = NULL;
3436                     }
3437                     if (filter_state) {
3438                         SvREFCNT_dec(filter_state);
3439                         filter_state = NULL;
3440                     }
3441                     if (filter_sub) {
3442                         SvREFCNT_dec(filter_sub);
3443                         filter_sub = NULL;
3444                     }
3445                 }
3446                 else {
3447                   if (!path_is_absolute(name)
3448 #ifdef MACOS_TRADITIONAL
3449                         /* We consider paths of the form :a:b ambiguous and interpret them first
3450                            as global then as local
3451                         */
3452                         || (*name == ':' && name[1] != ':' && strchr(name+2, ':'))
3453 #endif
3454                   ) {
3455                     const char *dir;
3456                     STRLEN dirlen;
3457
3458                     if (SvOK(dirsv)) {
3459                         dir = SvPV_const(dirsv, dirlen);
3460                     } else {
3461                         dir = "";
3462                         dirlen = 0;
3463                     }
3464
3465 #ifdef MACOS_TRADITIONAL
3466                     char buf1[256];
3467                     char buf2[256];
3468
3469                     MacPerl_CanonDir(name, buf2, 1);
3470                     Perl_sv_setpvf(aTHX_ namesv, "%s%s", MacPerl_CanonDir(dir, buf1, 0), buf2+(buf2[0] == ':'));
3471 #else
3472 #  ifdef VMS
3473                     char *unixdir;
3474                     if ((unixdir = tounixpath(dir, NULL)) == NULL)
3475                         continue;
3476                     sv_setpv(namesv, unixdir);
3477                     sv_catpv(namesv, unixname);
3478 #  else
3479 #    ifdef __SYMBIAN32__
3480                     if (PL_origfilename[0] &&
3481                         PL_origfilename[1] == ':' &&
3482                         !(dir[0] && dir[1] == ':'))
3483                         Perl_sv_setpvf(aTHX_ namesv,
3484                                        "%c:%s\\%s",
3485                                        PL_origfilename[0],
3486                                        dir, name);
3487                     else
3488                         Perl_sv_setpvf(aTHX_ namesv,
3489                                        "%s\\%s",
3490                                        dir, name);
3491 #    else
3492                     /* The equivalent of
3493                        Perl_sv_setpvf(aTHX_ namesv, "%s/%s", dir, name);
3494                        but without the need to parse the format string, or
3495                        call strlen on either pointer, and with the correct
3496                        allocation up front.  */
3497                     {
3498                         char *tmp = SvGROW(namesv, dirlen + len + 2);
3499
3500                         memcpy(tmp, dir, dirlen);
3501                         tmp +=dirlen;
3502                         *tmp++ = '/';
3503                         /* name came from an SV, so it will have a '\0' at the
3504                            end that we can copy as part of this memcpy().  */
3505                         memcpy(tmp, name, len + 1);
3506
3507                         SvCUR_set(namesv, dirlen + len + 1);
3508
3509                         /* Don't even actually have to turn SvPOK_on() as we
3510                            access it directly with SvPVX() below.  */
3511                     }
3512 #    endif
3513 #  endif
3514 #endif
3515                     TAINT_PROPER("require");
3516                     tryname = SvPVX_const(namesv);
3517                     tryrsfp = doopen_pm(tryname, SvCUR(namesv));
3518                     if (tryrsfp) {
3519                         if (tryname[0] == '.' && tryname[1] == '/')
3520                             tryname += 2;
3521                         break;
3522                     }
3523                     else if (errno == EMFILE)
3524                         /* no point in trying other paths if out of handles */
3525                         break;
3526                   }
3527                 }
3528             }
3529         }
3530     }
3531     SAVECOPFILE_FREE(&PL_compiling);
3532     CopFILE_set(&PL_compiling, tryrsfp ? tryname : name);
3533     SvREFCNT_dec(namesv);
3534     if (!tryrsfp) {
3535         if (PL_op->op_type == OP_REQUIRE) {
3536             const char *msgstr = name;
3537             if(errno == EMFILE) {
3538                 SV * const msg
3539                     = sv_2mortal(Perl_newSVpvf(aTHX_ "%s:   %s", msgstr,
3540                                                Strerror(errno)));
3541                 msgstr = SvPV_nolen_const(msg);
3542             } else {
3543                 if (namesv) {                   /* did we lookup @INC? */
3544                     AV * const ar = GvAVn(PL_incgv);
3545                     I32 i;
3546                     SV * const msg = sv_2mortal(Perl_newSVpvf(aTHX_
3547                         "%s in @INC%s%s (@INC contains:",
3548                         msgstr,
3549                         (instr(msgstr, ".h ")
3550                          ? " (change .h to .ph maybe?)" : ""),
3551                         (instr(msgstr, ".ph ")
3552                          ? " (did you run h2ph?)" : "")
3553                                                               ));
3554
3555                     for (i = 0; i <= AvFILL(ar); i++) {
3556                         sv_catpvs(msg, " ");
3557                         sv_catsv(msg, *av_fetch(ar, i, TRUE));
3558                     }
3559                     sv_catpvs(msg, ")");
3560                     msgstr = SvPV_nolen_const(msg);
3561                 }
3562             }
3563             DIE(aTHX_ "Can't locate %s", msgstr);
3564         }
3565
3566         RETPUSHUNDEF;
3567     }
3568     else
3569         SETERRNO(0, SS_NORMAL);
3570
3571     /* Assume success here to prevent recursive requirement. */
3572     /* name is never assigned to again, so len is still strlen(name)  */
3573     /* Check whether a hook in @INC has already filled %INC */
3574     if (!hook_sv) {
3575         (void)hv_store(GvHVn(PL_incgv),
3576                        unixname, unixlen, newSVpv(CopFILE(&PL_compiling),0),0);
3577     } else {
3578         SV** const svp = hv_fetch(GvHVn(PL_incgv), unixname, unixlen, 0);
3579         if (!svp)
3580             (void)hv_store(GvHVn(PL_incgv),
3581                            unixname, unixlen, SvREFCNT_inc_simple(hook_sv), 0 );
3582     }
3583
3584     ENTER;
3585     SAVETMPS;
3586     lex_start(NULL, tryrsfp, TRUE);
3587
3588     SAVEHINTS();
3589     PL_hints = 0;
3590     if (PL_compiling.cop_hints_hash) {
3591         Perl_refcounted_he_free(aTHX_ PL_compiling.cop_hints_hash);
3592         PL_compiling.cop_hints_hash = NULL;
3593     }
3594
3595     SAVECOMPILEWARNINGS();
3596     if (PL_dowarn & G_WARN_ALL_ON)
3597         PL_compiling.cop_warnings = pWARN_ALL ;
3598     else if (PL_dowarn & G_WARN_ALL_OFF)
3599         PL_compiling.cop_warnings = pWARN_NONE ;
3600     else
3601         PL_compiling.cop_warnings = pWARN_STD ;
3602
3603     if (filter_sub || filter_cache) {
3604         SV * const datasv = filter_add(S_run_user_filter, NULL);
3605         IoLINES(datasv) = filter_has_file;
3606         IoTOP_GV(datasv) = MUTABLE_GV(filter_state);
3607         IoBOTTOM_GV(datasv) = MUTABLE_GV(filter_sub);
3608         IoFMT_GV(datasv) = MUTABLE_GV(filter_cache);
3609     }
3610
3611     /* switch to eval mode */
3612     PUSHBLOCK(cx, CXt_EVAL, SP);
3613     PUSHEVAL(cx, name);
3614     cx->blk_eval.retop = PL_op->op_next;
3615
3616     SAVECOPLINE(&PL_compiling);
3617     CopLINE_set(&PL_compiling, 0);
3618
3619     PUTBACK;
3620
3621     /* Store and reset encoding. */
3622     encoding = PL_encoding;
3623     PL_encoding = NULL;
3624
3625     if (doeval(gimme, NULL, NULL, PL_curcop->cop_seq))
3626         op = DOCATCH(PL_eval_start);
3627     else
3628         op = PL_op->op_next;
3629
3630     /* Restore encoding. */
3631     PL_encoding = encoding;
3632
3633     return op;
3634 }
3635
3636 /* This is a op added to hold the hints hash for
3637    pp_entereval. The hash can be modified by the code
3638    being eval'ed, so we return a copy instead. */
3639
3640 PP(pp_hintseval)
3641 {
3642     dVAR;
3643     dSP;
3644     mXPUSHs(MUTABLE_SV(Perl_hv_copy_hints_hv(aTHX_ MUTABLE_HV(cSVOP_sv))));
3645     RETURN;
3646 }
3647
3648
3649 PP(pp_entereval)
3650 {
3651     dVAR; dSP;
3652     register PERL_CONTEXT *cx;
3653     SV *sv;
3654     const I32 gimme = GIMME_V;
3655     const U32 was = PL_breakable_sub_gen;
3656     char tbuf[TYPE_DIGITS(long) + 12];
3657     char *tmpbuf = tbuf;
3658     STRLEN len;
3659     CV* runcv;
3660     U32 seq;
3661     HV *saved_hh = NULL;
3662
3663     if (PL_op->op_private & OPpEVAL_HAS_HH) {
3664         saved_hh = MUTABLE_HV(SvREFCNT_inc(POPs));
3665     }
3666     sv = POPs;
3667
3668     TAINT_IF(SvTAINTED(sv));
3669     TAINT_PROPER("eval");
3670
3671     ENTER;
3672     lex_start(sv, NULL, FALSE);
3673     SAVETMPS;
3674
3675     /* switch to eval mode */
3676
3677     if (PERLDB_NAMEEVAL && CopLINE(PL_curcop)) {
3678         SV * const temp_sv = sv_newmortal();
3679         Perl_sv_setpvf(aTHX_ temp_sv, "_<(eval %lu)[%s:%"IVdf"]",
3680                        (unsigned long)++PL_evalseq,
3681                        CopFILE(PL_curcop), (IV)CopLINE(PL_curcop));
3682         tmpbuf = SvPVX(temp_sv);
3683         len = SvCUR(temp_sv);
3684     }
3685     else
3686         len = my_snprintf(tmpbuf, sizeof(tbuf), "_<(eval %lu)", (unsigned long)++PL_evalseq);
3687     SAVECOPFILE_FREE(&PL_compiling);
3688     CopFILE_set(&PL_compiling, tmpbuf+2);
3689     SAVECOPLINE(&PL_compiling);
3690     CopLINE_set(&PL_compiling, 1);
3691     /* XXX For C<eval "...">s within BEGIN {} blocks, this ends up
3692        deleting the eval's FILEGV from the stash before gv_check() runs
3693        (i.e. before run-time proper). To work around the coredump that
3694        ensues, we always turn GvMULTI_on for any globals that were
3695        introduced within evals. See force_ident(). GSAR 96-10-12 */
3696     SAVEHINTS();
3697     PL_hints = PL_op->op_targ;
3698     if (saved_hh)
3699         GvHV(PL_hintgv) = saved_hh;
3700     SAVECOMPILEWARNINGS();
3701     PL_compiling.cop_warnings = DUP_WARNINGS(PL_curcop->cop_warnings);
3702     if (PL_compiling.cop_hints_hash) {
3703         Perl_refcounted_he_free(aTHX_ PL_compiling.cop_hints_hash);
3704     }
3705     PL_compiling.cop_hints_hash = PL_curcop->cop_hints_hash;
3706     if (PL_compiling.cop_hints_hash) {
3707         HINTS_REFCNT_LOCK;
3708         PL_compiling.cop_hints_hash->refcounted_he_refcnt++;
3709         HINTS_REFCNT_UNLOCK;
3710     }
3711     /* special case: an eval '' executed within the DB package gets lexically
3712      * placed in the first non-DB CV rather than the current CV - this
3713      * allows the debugger to execute code, find lexicals etc, in the
3714      * scope of the code being debugged. Passing &seq gets find_runcv
3715      * to do the dirty work for us */
3716     runcv = find_runcv(&seq);
3717
3718     PUSHBLOCK(cx, (CXt_EVAL|CXp_REAL), SP);
3719     PUSHEVAL(cx, 0);
3720     cx->blk_eval.retop = PL_op->op_next;
3721
3722     /* prepare to compile string */
3723
3724     if ((PERLDB_LINE || PERLDB_SAVESRC) && PL_curstash != PL_debstash)
3725         save_lines(CopFILEAV(&PL_compiling), PL_parser->linestr);
3726     PUTBACK;
3727
3728     if (doeval(gimme, NULL, runcv, seq)) {
3729         if (was != PL_breakable_sub_gen /* Some subs defined here. */
3730             ? (PERLDB_LINE || PERLDB_SAVESRC)
3731             :  PERLDB_SAVESRC_NOSUBS) {
3732             /* Retain the filegv we created.  */
3733         } else {
3734             char *const safestr = savepvn(tmpbuf, len);
3735             SAVEDELETE(PL_defstash, safestr, len);
3736         }
3737         return DOCATCH(PL_eval_start);
3738     } else {
3739         /* We have already left the scope set up earler thanks to the LEAVE
3740            in doeval().  */
3741         if (was != PL_breakable_sub_gen /* Some subs defined here. */
3742             ? (PERLDB_LINE || PERLDB_SAVESRC)
3743             :  PERLDB_SAVESRC_INVALID) {
3744             /* Retain the filegv we created.  */
3745         } else {
3746             (void)hv_delete(PL_defstash, tmpbuf, len, G_DISCARD);
3747         }
3748         return PL_op->op_next;
3749     }
3750 }
3751
3752 PP(pp_leaveeval)
3753 {
3754     dVAR; dSP;
3755     register SV **mark;
3756     SV **newsp;
3757     PMOP *newpm;
3758     I32 gimme;
3759     register PERL_CONTEXT *cx;
3760     OP *retop;
3761     const U8 save_flags = PL_op -> op_flags;
3762     I32 optype;
3763
3764     POPBLOCK(cx,newpm);
3765     POPEVAL(cx);
3766     retop = cx->blk_eval.retop;
3767
3768     TAINT_NOT;
3769     if (gimme == G_VOID)
3770         MARK = newsp;
3771     else if (gimme == G_SCALAR) {
3772         MARK = newsp + 1;
3773         if (MARK <= SP) {
3774             if (SvFLAGS(TOPs) & SVs_TEMP)
3775                 *MARK = TOPs;
3776             else
3777                 *MARK = sv_mortalcopy(TOPs);
3778         }
3779         else {
3780             MEXTEND(mark,0);
3781             *MARK = &PL_sv_undef;
3782         }
3783         SP = MARK;
3784     }
3785     else {
3786         /* in case LEAVE wipes old return values */
3787         for (mark = newsp + 1; mark <= SP; mark++) {
3788             if (!(SvFLAGS(*mark) & SVs_TEMP)) {
3789                 *mark = sv_mortalcopy(*mark);
3790                 TAINT_NOT;      /* Each item is independent */
3791             }
3792         }
3793     }
3794     PL_curpm = newpm;   /* Don't pop $1 et al till now */
3795
3796 #ifdef DEBUGGING
3797     assert(CvDEPTH(PL_compcv) == 1);
3798 #endif
3799     CvDEPTH(PL_compcv) = 0;
3800     lex_end();
3801
3802     if (optype == OP_REQUIRE &&
3803         !(gimme == G_SCALAR ? SvTRUE(*SP) : SP > newsp))
3804     {
3805         /* Unassume the success we assumed earlier. */
3806         SV * const nsv = cx->blk_eval.old_namesv;
3807         (void)hv_delete(GvHVn(PL_incgv), SvPVX_const(nsv), SvCUR(nsv), G_DISCARD);
3808         retop = Perl_die(aTHX_ "%"SVf" did not return a true value", SVfARG(nsv));
3809         /* die_where() did LEAVE, or we won't be here */
3810     }
3811     else {
3812         LEAVE;
3813         if (!(save_flags & OPf_SPECIAL)) {
3814             CLEAR_ERRSV();
3815         }
3816     }
3817
3818     RETURNOP(retop);
3819 }
3820
3821 /* Common code for Perl_call_sv and Perl_fold_constants, put here to keep it
3822    close to the related Perl_create_eval_scope.  */
3823 void
3824 Perl_delete_eval_scope(pTHX)
3825 {
3826     SV **newsp;
3827     PMOP *newpm;
3828     I32 gimme;
3829     register PERL_CONTEXT *cx;
3830     I32 optype;
3831
3832     POPBLOCK(cx,newpm);
3833     POPEVAL(cx);
3834     PL_curpm = newpm;
3835     LEAVE;
3836     PERL_UNUSED_VAR(newsp);
3837     PERL_UNUSED_VAR(gimme);
3838     PERL_UNUSED_VAR(optype);
3839 }
3840
3841 /* Common-ish code salvaged from Perl_call_sv and pp_entertry, because it was
3842    also needed by Perl_fold_constants.  */
3843 PERL_CONTEXT *
3844 Perl_create_eval_scope(pTHX_ U32 flags)
3845 {
3846     PERL_CONTEXT *cx;
3847     const I32 gimme = GIMME_V;
3848
3849     ENTER;
3850     SAVETMPS;
3851
3852     PUSHBLOCK(cx, (CXt_EVAL|CXp_TRYBLOCK), PL_stack_sp);
3853     PUSHEVAL(cx, 0);
3854
3855     PL_in_eval = EVAL_INEVAL;
3856     if (flags & G_KEEPERR)
3857         PL_in_eval |= EVAL_KEEPERR;
3858     else
3859         CLEAR_ERRSV();
3860     if (flags & G_FAKINGEVAL) {
3861         PL_eval_root = PL_op; /* Only needed so that goto works right. */
3862     }
3863     return cx;
3864 }
3865
3866 PP(pp_entertry)
3867 {
3868     dVAR;
3869     PERL_CONTEXT * const cx = create_eval_scope(0);
3870     cx->blk_eval.retop = cLOGOP->op_other->op_next;
3871     return DOCATCH(PL_op->op_next);
3872 }
3873
3874 PP(pp_leavetry)
3875 {
3876     dVAR; dSP;
3877     SV **newsp;
3878     PMOP *newpm;
3879     I32 gimme;
3880     register PERL_CONTEXT *cx;
3881     I32 optype;
3882
3883     POPBLOCK(cx,newpm);
3884     POPEVAL(cx);
3885     PERL_UNUSED_VAR(optype);
3886
3887     TAINT_NOT;
3888     if (gimme == G_VOID)
3889         SP = newsp;
3890     else if (gimme == G_SCALAR) {
3891         register SV **mark;
3892         MARK = newsp + 1;
3893         if (MARK <= SP) {
3894             if (SvFLAGS(TOPs) & (SVs_PADTMP|SVs_TEMP))
3895                 *MARK = TOPs;
3896             else
3897                 *MARK = sv_mortalcopy(TOPs);
3898         }
3899         else {
3900             MEXTEND(mark,0);
3901             *MARK = &PL_sv_undef;
3902         }
3903         SP = MARK;
3904     }
3905     else {
3906         /* in case LEAVE wipes old return values */
3907         register SV **mark;
3908         for (mark = newsp + 1; mark <= SP; mark++) {
3909             if (!(SvFLAGS(*mark) & (SVs_PADTMP|SVs_TEMP))) {
3910                 *mark = sv_mortalcopy(*mark);
3911                 TAINT_NOT;      /* Each item is independent */
3912             }
3913         }
3914     }
3915     PL_curpm = newpm;   /* Don't pop $1 et al till now */
3916
3917     LEAVE;
3918     CLEAR_ERRSV();
3919     RETURN;
3920 }
3921
3922 PP(pp_entergiven)
3923 {
3924     dVAR; dSP;
3925     register PERL_CONTEXT *cx;
3926     const I32 gimme = GIMME_V;
3927
3928     ENTER;
3929     SAVETMPS;
3930
3931     if (PL_op->op_targ == 0) {
3932         SV ** const defsv_p = &GvSV(PL_defgv);
3933         *defsv_p = newSVsv(POPs);
3934         SAVECLEARSV(*defsv_p);
3935     }
3936     else
3937         sv_setsv(PAD_SV(PL_op->op_targ), POPs);
3938
3939     PUSHBLOCK(cx, CXt_GIVEN, SP);
3940     PUSHGIVEN(cx);
3941
3942     RETURN;
3943 }
3944
3945 PP(pp_leavegiven)
3946 {
3947     dVAR; dSP;
3948     register PERL_CONTEXT *cx;
3949     I32 gimme;
3950     SV **newsp;
3951     PMOP *newpm;
3952     PERL_UNUSED_CONTEXT;
3953
3954     POPBLOCK(cx,newpm);
3955     assert(CxTYPE(cx) == CXt_GIVEN);
3956
3957     SP = newsp;
3958     PUTBACK;
3959
3960     PL_curpm = newpm;   /* pop $1 et al */
3961
3962     LEAVE;
3963
3964     return NORMAL;
3965 }
3966
3967 /* Helper routines used by pp_smartmatch */
3968 STATIC PMOP *
3969 S_make_matcher(pTHX_ REGEXP *re)
3970 {
3971     dVAR;
3972     PMOP *matcher = (PMOP *) newPMOP(OP_MATCH, OPf_WANT_SCALAR | OPf_STACKED);
3973
3974     PERL_ARGS_ASSERT_MAKE_MATCHER;
3975
3976     PM_SETRE(matcher, ReREFCNT_inc(re));
3977
3978     SAVEFREEOP((OP *) matcher);
3979     ENTER; SAVETMPS;
3980     SAVEOP();
3981     return matcher;
3982 }
3983
3984 STATIC bool
3985 S_matcher_matches_sv(pTHX_ PMOP *matcher, SV *sv)
3986 {
3987     dVAR;
3988     dSP;
3989
3990     PERL_ARGS_ASSERT_MATCHER_MATCHES_SV;
3991
3992     PL_op = (OP *) matcher;
3993     XPUSHs(sv);
3994     PUTBACK;
3995     (void) pp_match();
3996     SPAGAIN;
3997     return (SvTRUEx(POPs));
3998 }
3999
4000 STATIC void
4001 S_destroy_matcher(pTHX_ PMOP *matcher)
4002 {
4003     dVAR;
4004
4005     PERL_ARGS_ASSERT_DESTROY_MATCHER;
4006     PERL_UNUSED_ARG(matcher);
4007
4008     FREETMPS;
4009     LEAVE;
4010 }
4011
4012 /* Do a smart match */
4013 PP(pp_smartmatch)
4014 {
4015     return do_smartmatch(NULL, NULL);
4016 }
4017
4018 /* This version of do_smartmatch() implements the
4019  * table of smart matches that is found in perlsyn.
4020  */
4021 STATIC OP *
4022 S_do_smartmatch(pTHX_ HV *seen_this, HV *seen_other)
4023 {
4024     dVAR;
4025     dSP;
4026
4027     SV *e = TOPs;       /* e is for 'expression' */
4028     SV *d = TOPm1s;     /* d is for 'default', as in PL_defgv */
4029     SV *This, *Other;   /* 'This' (and Other to match) to play with C++ */
4030     REGEXP *this_regex, *other_regex;
4031
4032 #   define NOT_EMPTY_PROTO(cv) (!SvPOK(cv) || SvCUR(cv) == 0)
4033
4034 #   define SM_REF(type) ( \
4035            (SvROK(d) && (SvTYPE(This = SvRV(d)) == SVt_##type) && (Other = e)) \
4036         || (SvROK(e) && (SvTYPE(This = SvRV(e)) == SVt_##type) && (Other = d)))
4037
4038 #   define SM_CV_NEP   /* Find a code ref without an empty prototype */ \
4039         ((SvROK(d) && (SvTYPE(This = SvRV(d)) == SVt_PVCV)              \
4040             && NOT_EMPTY_PROTO(This) && (Other = e))                    \
4041         || (SvROK(e) && (SvTYPE(This = SvRV(e)) == SVt_PVCV)            \
4042             && NOT_EMPTY_PROTO(This) && (Other = d)))
4043
4044 #   define SM_REGEX ( \
4045            (SvROK(d) && (SvTYPE(This = SvRV(d)) == SVt_REGEXP)          \
4046         && (this_regex = (REGEXP*) This)                                \
4047         && (Other = e))                                                 \
4048     ||                                                                  \
4049            (SvROK(e) && (SvTYPE(This = SvRV(e)) == SVt_REGEXP)          \
4050         && (this_regex = (REGEXP*) This)                                \
4051         && (Other = d)) )
4052
4053
4054 #   define SM_OBJECT ( \
4055            (sv_isobject(d) && (SvTYPE(SvRV(d)) != SVt_REGEXP))          \
4056     ||                                                                  \
4057            (sv_isobject(e) && (SvTYPE(SvRV(e)) != SVt_REGEXP)) )        \
4058
4059 #   define SM_OTHER_REF(type) \
4060         (SvROK(Other) && SvTYPE(SvRV(Other)) == SVt_##type)
4061
4062 #   define SM_OTHER_REGEX (SvROK(Other)                                 \
4063         && (SvTYPE(SvRV(Other)) == SVt_REGEXP)                          \
4064         && (other_regex = (REGEXP*) SvRV(Other)))
4065
4066
4067 #   define SM_SEEN_THIS(sv) hv_exists_ent(seen_this, \
4068         sv_2mortal(newSViv(PTR2IV(sv))), 0)
4069
4070 #   define SM_SEEN_OTHER(sv) hv_exists_ent(seen_other, \
4071         sv_2mortal(newSViv(PTR2IV(sv))), 0)
4072
4073     tryAMAGICbinSET(smart, 0);
4074
4075     SP -= 2;    /* Pop the values */
4076
4077     /* Take care only to invoke mg_get() once for each argument.
4078      * Currently we do this by copying the SV if it's magical. */
4079     if (d) {
4080         if (SvGMAGICAL(d))
4081             d = sv_mortalcopy(d);
4082     }
4083     else
4084         d = &PL_sv_undef;
4085
4086     assert(e);
4087     if (SvGMAGICAL(e))
4088         e = sv_mortalcopy(e);
4089
4090     if (SM_OBJECT)
4091         Perl_croak(aTHX_ "Smart matching a non-overloaded object breaks encapsulation");
4092
4093     if (SM_CV_NEP) {
4094         I32 c;
4095
4096         if ( SM_OTHER_REF(PVCV) && NOT_EMPTY_PROTO(SvRV(Other)) )
4097         {
4098             if (This == SvRV(Other))
4099                 RETPUSHYES;
4100             else
4101                 RETPUSHNO;
4102         }
4103
4104         ENTER;
4105         SAVETMPS;
4106         PUSHMARK(SP);
4107         PUSHs(Other);
4108         PUTBACK;
4109         c = call_sv(This, G_SCALAR);
4110         SPAGAIN;
4111         if (c == 0)
4112             PUSHs(&PL_sv_no);
4113         else if (SvTEMP(TOPs))
4114             SvREFCNT_inc_void(TOPs);
4115         FREETMPS;
4116         LEAVE;
4117         RETURN;
4118     }
4119     else if (SM_REF(PVHV)) {
4120         if (SM_OTHER_REF(PVHV)) {
4121             /* Check that the key-sets are identical */
4122             HE *he;
4123             HV *other_hv = MUTABLE_HV(SvRV(Other));
4124             bool tied = FALSE;
4125             bool other_tied = FALSE;
4126             U32 this_key_count  = 0,
4127                 other_key_count = 0;
4128
4129             /* Tied hashes don't know how many keys they have. */
4130             if (SvTIED_mg(This, PERL_MAGIC_tied)) {
4131                 tied = TRUE;
4132             }
4133             else if (SvTIED_mg((const SV *)other_hv, PERL_MAGIC_tied)) {
4134                 HV * const temp = other_hv;
4135                 other_hv = MUTABLE_HV(This);
4136                 This  = MUTABLE_SV(temp);
4137                 tied = TRUE;
4138             }
4139             if (SvTIED_mg((const SV *)other_hv, PERL_MAGIC_tied))
4140                 other_tied = TRUE;
4141
4142             if (!tied && HvUSEDKEYS((const HV *) This) != HvUSEDKEYS(other_hv))
4143                 RETPUSHNO;
4144
4145             /* The hashes have the same number of keys, so it suffices
4146                to check that one is a subset of the other. */
4147             (void) hv_iterinit(MUTABLE_HV(This));
4148             while ( (he = hv_iternext(MUTABLE_HV(This))) ) {
4149                 I32 key_len;
4150                 char * const key = hv_iterkey(he, &key_len);
4151
4152                 ++ this_key_count;
4153
4154                 if(!hv_exists(other_hv, key, key_len)) {
4155                     (void) hv_iterinit(MUTABLE_HV(This));       /* reset iterator */
4156                     RETPUSHNO;
4157                 }
4158             }
4159
4160             if (other_tied) {
4161                 (void) hv_iterinit(other_hv);
4162                 while ( hv_iternext(other_hv) )
4163                     ++other_key_count;
4164             }
4165             else
4166                 other_key_count = HvUSEDKEYS(other_hv);
4167
4168             if (this_key_count != other_key_count)
4169                 RETPUSHNO;
4170             else
4171                 RETPUSHYES;
4172         }
4173         else if (SM_OTHER_REF(PVAV)) {
4174             AV * const other_av = MUTABLE_AV(SvRV(Other));
4175             const I32 other_len = av_len(other_av) + 1;
4176             I32 i;
4177
4178             for (i = 0; i < other_len; ++i) {
4179                 SV ** const svp = av_fetch(other_av, i, FALSE);
4180                 char *key;
4181                 STRLEN key_len;
4182
4183                 if (svp) {      /* ??? When can this not happen? */
4184                     key = SvPV(*svp, key_len);
4185                     if (hv_exists(MUTABLE_HV(This), key, key_len))
4186                         RETPUSHYES;
4187                 }
4188             }
4189             RETPUSHNO;
4190         }
4191         else if (SM_OTHER_REGEX) {
4192             PMOP * const matcher = make_matcher(other_regex);
4193             HE *he;
4194
4195             (void) hv_iterinit(MUTABLE_HV(This));
4196             while ( (he = hv_iternext(MUTABLE_HV(This))) ) {
4197                 if (matcher_matches_sv(matcher, hv_iterkeysv(he))) {
4198                     (void) hv_iterinit(MUTABLE_HV(This));
4199                     destroy_matcher(matcher);
4200                     RETPUSHYES;
4201                 }
4202             }
4203             destroy_matcher(matcher);
4204             RETPUSHNO;
4205         }
4206         else {
4207             if (hv_exists_ent(MUTABLE_HV(This), Other, 0))
4208                 RETPUSHYES;
4209             else
4210                 RETPUSHNO;
4211         }
4212     }
4213     else if (SM_REF(PVAV)) {
4214         if (SM_OTHER_REF(PVAV)) {
4215             AV *other_av = MUTABLE_AV(SvRV(Other));
4216             if (av_len(MUTABLE_AV(This)) != av_len(other_av))
4217                 RETPUSHNO;
4218             else {
4219                 I32 i;
4220                 const I32 other_len = av_len(other_av);
4221
4222                 if (NULL == seen_this) {
4223                     seen_this = newHV();
4224                     (void) sv_2mortal(MUTABLE_SV(seen_this));
4225                 }
4226                 if (NULL == seen_other) {
4227                     seen_this = newHV();
4228                     (void) sv_2mortal(MUTABLE_SV(seen_other));
4229                 }
4230                 for(i = 0; i <= other_len; ++i) {
4231                     SV * const * const this_elem = av_fetch(MUTABLE_AV(This), i, FALSE);
4232                     SV * const * const other_elem = av_fetch(other_av, i, FALSE);
4233
4234                     if (!this_elem || !other_elem) {
4235                         if (this_elem || other_elem)
4236                             RETPUSHNO;
4237                     }
4238                     else if (SM_SEEN_THIS(*this_elem)
4239                          || SM_SEEN_OTHER(*other_elem))
4240                     {
4241                         if (*this_elem != *other_elem)
4242                             RETPUSHNO;
4243                     }
4244                     else {
4245                         (void)hv_store_ent(seen_this,
4246                                 sv_2mortal(newSViv(PTR2IV(*this_elem))),
4247                                 &PL_sv_undef, 0);
4248                         (void)hv_store_ent(seen_other,
4249                                 sv_2mortal(newSViv(PTR2IV(*other_elem))),
4250                                 &PL_sv_undef, 0);
4251                         PUSHs(*this_elem);
4252                         PUSHs(*other_elem);
4253
4254                         PUTBACK;
4255                         (void) do_smartmatch(seen_this, seen_other);
4256                         SPAGAIN;
4257
4258                         if (!SvTRUEx(POPs))
4259                             RETPUSHNO;
4260                     }
4261                 }
4262                 RETPUSHYES;
4263             }
4264         }
4265         else if (SM_OTHER_REGEX) {
4266             PMOP * const matcher = make_matcher(other_regex);
4267             const I32 this_len = av_len(MUTABLE_AV(This));
4268             I32 i;
4269
4270             for(i = 0; i <= this_len; ++i) {
4271                 SV * const * const svp = av_fetch(MUTABLE_AV(This), i, FALSE);
4272                 if (svp && matcher_matches_sv(matcher, *svp)) {
4273                     destroy_matcher(matcher);
4274                     RETPUSHYES;
4275                 }
4276             }
4277             destroy_matcher(matcher);
4278             RETPUSHNO;
4279         }
4280         else if (SvIOK(Other) || SvNOK(Other)) {
4281             I32 i;
4282
4283             for(i = 0; i <= AvFILL(MUTABLE_AV(This)); ++i) {
4284                 SV * const * const svp = av_fetch(MUTABLE_AV(This), i, FALSE);
4285                 if (!svp)
4286                     continue;
4287
4288                 PUSHs(Other);
4289                 PUSHs(*svp);
4290                 PUTBACK;
4291                 if (CopHINTS_get(PL_curcop) & HINT_INTEGER)
4292                     (void) pp_i_eq();
4293                 else
4294                     (void) pp_eq();
4295                 SPAGAIN;
4296                 if (SvTRUEx(POPs))
4297                     RETPUSHYES;
4298             }
4299             RETPUSHNO;
4300         }
4301         else if (SvPOK(Other)) {
4302             const I32 this_len = av_len(MUTABLE_AV(This));
4303             I32 i;
4304
4305             for(i = 0; i <= this_len; ++i) {
4306                 SV * const * const svp = av_fetch(MUTABLE_AV(This), i, FALSE);
4307                 if (!svp)
4308                     continue;
4309
4310                 PUSHs(Other);
4311                 PUSHs(*svp);
4312                 PUTBACK;
4313                 (void) pp_seq();
4314                 SPAGAIN;
4315                 if (SvTRUEx(POPs))
4316                     RETPUSHYES;
4317             }
4318             RETPUSHNO;
4319         }
4320     }
4321     else if (!SvOK(d) || !SvOK(e)) {
4322         if (!SvOK(d) && !SvOK(e))
4323             RETPUSHYES;
4324         else
4325             RETPUSHNO;
4326     }
4327     else if (SM_REGEX) {
4328         PMOP * const matcher = make_matcher(this_regex);
4329
4330         PUTBACK;
4331         PUSHs(matcher_matches_sv(matcher, Other)
4332             ? &PL_sv_yes
4333             : &PL_sv_no);
4334         destroy_matcher(matcher);
4335         RETURN;
4336     }
4337     else if (SM_REF(PVCV)) {
4338         I32 c;
4339         /* This must be a null-prototyped sub, because we
4340            already checked for the other kind. */
4341
4342         ENTER;
4343         SAVETMPS;
4344         PUSHMARK(SP);
4345         PUTBACK;
4346         c = call_sv(This, G_SCALAR);
4347         SPAGAIN;
4348         if (c == 0)
4349             PUSHs(&PL_sv_undef);
4350         else if (SvTEMP(TOPs))
4351             SvREFCNT_inc_void(TOPs);
4352
4353         if (SM_OTHER_REF(PVCV)) {
4354             /* This one has to be null-proto'd too.
4355                Call both of 'em, and compare the results */
4356             PUSHMARK(SP);
4357             c = call_sv(SvRV(Other), G_SCALAR);
4358             SPAGAIN;
4359             if (c == 0)
4360                 PUSHs(&PL_sv_undef);
4361             else if (SvTEMP(TOPs))
4362                 SvREFCNT_inc_void(TOPs);
4363             FREETMPS;
4364             LEAVE;
4365             PUTBACK;
4366             return pp_eq();
4367         }
4368
4369         FREETMPS;
4370         LEAVE;
4371         RETURN;
4372     }
4373     else if ( ((SvIOK(d) || SvNOK(d)) && (This = d) && (Other = e))
4374          ||   ((SvIOK(e) || SvNOK(e)) && (This = e) && (Other = d)) )
4375     {
4376         if (SvPOK(Other) && !looks_like_number(Other)) {
4377             /* String comparison */
4378             PUSHs(d); PUSHs(e);
4379             PUTBACK;
4380             return pp_seq();
4381         }
4382         /* Otherwise, numeric comparison */
4383         PUSHs(d); PUSHs(e);
4384         PUTBACK;
4385         if (CopHINTS_get(PL_curcop) & HINT_INTEGER)
4386             (void) pp_i_eq();
4387         else
4388             (void) pp_eq();
4389         SPAGAIN;
4390         if (SvTRUEx(POPs))
4391             RETPUSHYES;
4392         else
4393             RETPUSHNO;
4394     }
4395
4396     /* As a last resort, use string comparison */
4397     PUSHs(d); PUSHs(e);
4398     PUTBACK;
4399     return pp_seq();
4400 }
4401
4402 PP(pp_enterwhen)
4403 {
4404     dVAR; dSP;
4405     register PERL_CONTEXT *cx;
4406     const I32 gimme = GIMME_V;
4407
4408     /* This is essentially an optimization: if the match
4409        fails, we don't want to push a context and then
4410        pop it again right away, so we skip straight
4411        to the op that follows the leavewhen.
4412     */
4413     if ((0 == (PL_op->op_flags & OPf_SPECIAL)) && !SvTRUEx(POPs))
4414         return cLOGOP->op_other->op_next;
4415
4416     ENTER;
4417     SAVETMPS;
4418
4419     PUSHBLOCK(cx, CXt_WHEN, SP);
4420     PUSHWHEN(cx);
4421
4422     RETURN;
4423 }
4424
4425 PP(pp_leavewhen)
4426 {
4427     dVAR; dSP;
4428     register PERL_CONTEXT *cx;
4429     I32 gimme;
4430     SV **newsp;
4431     PMOP *newpm;
4432
4433     POPBLOCK(cx,newpm);
4434     assert(CxTYPE(cx) == CXt_WHEN);
4435
4436     SP = newsp;
4437     PUTBACK;
4438
4439     PL_curpm = newpm;   /* pop $1 et al */
4440
4441     LEAVE;
4442     return NORMAL;
4443 }
4444
4445 PP(pp_continue)
4446 {
4447     dVAR;
4448     I32 cxix;
4449     register PERL_CONTEXT *cx;
4450     I32 inner;
4451
4452     cxix = dopoptowhen(cxstack_ix);
4453     if (cxix < 0)
4454         DIE(aTHX_ "Can't \"continue\" outside a when block");
4455     if (cxix < cxstack_ix)
4456         dounwind(cxix);
4457
4458     /* clear off anything above the scope we're re-entering */
4459     inner = PL_scopestack_ix;
4460     TOPBLOCK(cx);
4461     if (PL_scopestack_ix < inner)
4462         leave_scope(PL_scopestack[PL_scopestack_ix]);
4463     PL_curcop = cx->blk_oldcop;
4464     return cx->blk_givwhen.leave_op;
4465 }
4466
4467 PP(pp_break)
4468 {
4469     dVAR;
4470     I32 cxix;
4471     register PERL_CONTEXT *cx;
4472     I32 inner;
4473
4474     cxix = dopoptogiven(cxstack_ix);
4475     if (cxix < 0) {
4476         if (PL_op->op_flags & OPf_SPECIAL)
4477             DIE(aTHX_ "Can't use when() outside a topicalizer");
4478         else
4479             DIE(aTHX_ "Can't \"break\" outside a given block");
4480     }
4481     if (CxFOREACH(&cxstack[cxix]) && (0 == (PL_op->op_flags & OPf_SPECIAL)))
4482         DIE(aTHX_ "Can't \"break\" in a loop topicalizer");
4483
4484     if (cxix < cxstack_ix)
4485         dounwind(cxix);
4486
4487     /* clear off anything above the scope we're re-entering */
4488     inner = PL_scopestack_ix;
4489     TOPBLOCK(cx);
4490     if (PL_scopestack_ix < inner)
4491         leave_scope(PL_scopestack[PL_scopestack_ix]);
4492     PL_curcop = cx->blk_oldcop;
4493
4494     if (CxFOREACH(cx))
4495         return CX_LOOP_NEXTOP_GET(cx);
4496     else
4497         return cx->blk_givwhen.leave_op;
4498 }
4499
4500 STATIC OP *
4501 S_doparseform(pTHX_ SV *sv)
4502 {
4503     STRLEN len;
4504     register char *s = SvPV_force(sv, len);
4505     register char * const send = s + len;
4506     register char *base = NULL;
4507     register I32 skipspaces = 0;
4508     bool noblank   = FALSE;
4509     bool repeat    = FALSE;
4510     bool postspace = FALSE;
4511     U32 *fops;
4512     register U32 *fpc;
4513     U32 *linepc = NULL;
4514     register I32 arg;
4515     bool ischop;
4516     bool unchopnum = FALSE;
4517     int maxops = 12; /* FF_LINEMARK + FF_END + 10 (\0 without preceding \n) */
4518
4519     PERL_ARGS_ASSERT_DOPARSEFORM;
4520
4521     if (len == 0)
4522         Perl_croak(aTHX_ "Null picture in formline");
4523
4524     /* estimate the buffer size needed */
4525     for (base = s; s <= send; s++) {
4526         if (*s == '\n' || *s == '@' || *s == '^')
4527             maxops += 10;
4528     }
4529     s = base;
4530     base = NULL;
4531
4532     Newx(fops, maxops, U32);
4533     fpc = fops;
4534
4535     if (s < send) {
4536         linepc = fpc;
4537         *fpc++ = FF_LINEMARK;
4538         noblank = repeat = FALSE;
4539         base = s;
4540     }
4541
4542     while (s <= send) {
4543         switch (*s++) {
4544         default:
4545             skipspaces = 0;
4546             continue;
4547
4548         case '~':
4549             if (*s == '~') {
4550                 repeat = TRUE;
4551                 *s = ' ';
4552             }
4553             noblank = TRUE;
4554             s[-1] = ' ';
4555             /* FALL THROUGH */
4556         case ' ': case '\t':
4557             skipspaces++;
4558             continue;
4559         case 0:
4560             if (s < send) {
4561                 skipspaces = 0;
4562                 continue;
4563             } /* else FALL THROUGH */
4564         case '\n':
4565             arg = s - base;
4566             skipspaces++;
4567             arg -= skipspaces;
4568             if (arg) {
4569                 if (postspace)
4570                     *fpc++ = FF_SPACE;
4571                 *fpc++ = FF_LITERAL;
4572                 *fpc++ = (U16)arg;
4573             }
4574             postspace = FALSE;
4575             if (s <= send)
4576                 skipspaces--;
4577             if (skipspaces) {
4578                 *fpc++ = FF_SKIP;
4579                 *fpc++ = (U16)skipspaces;
4580             }
4581             skipspaces = 0;
4582             if (s <= send)
4583                 *fpc++ = FF_NEWLINE;
4584             if (noblank) {
4585                 *fpc++ = FF_BLANK;
4586                 if (repeat)
4587                     arg = fpc - linepc + 1;
4588                 else
4589                     arg = 0;
4590                 *fpc++ = (U16)arg;
4591             }
4592             if (s < send) {
4593                 linepc = fpc;
4594                 *fpc++ = FF_LINEMARK;
4595                 noblank = repeat = FALSE;
4596                 base = s;
4597             }
4598             else
4599                 s++;
4600             continue;
4601
4602         case '@':
4603         case '^':
4604             ischop = s[-1] == '^';
4605
4606             if (postspace) {
4607                 *fpc++ = FF_SPACE;
4608                 postspace = FALSE;
4609             }
4610             arg = (s - base) - 1;
4611             if (arg) {
4612                 *fpc++ = FF_LITERAL;
4613                 *fpc++ = (U16)arg;
4614             }
4615
4616             base = s - 1;
4617             *fpc++ = FF_FETCH;
4618             if (*s == '*') {
4619                 s++;
4620                 *fpc++ = 2;  /* skip the @* or ^* */
4621                 if (ischop) {
4622                     *fpc++ = FF_LINESNGL;
4623                     *fpc++ = FF_CHOP;
4624                 } else
4625                     *fpc++ = FF_LINEGLOB;
4626             }
4627             else if (*s == '#' || (*s == '.' && s[1] == '#')) {
4628                 arg = ischop ? 512 : 0;
4629                 base = s - 1;
4630                 while (*s == '#')
4631                     s++;
4632                 if (*s == '.') {
4633                     const char * const f = ++s;
4634                     while (*s == '#')
4635                         s++;
4636                     arg |= 256 + (s - f);
4637                 }
4638                 *fpc++ = s - base;              /* fieldsize for FETCH */
4639                 *fpc++ = FF_DECIMAL;
4640                 *fpc++ = (U16)arg;
4641                 unchopnum |= ! ischop;
4642             }
4643             else if (*s == '0' && s[1] == '#') {  /* Zero padded decimals */
4644                 arg = ischop ? 512 : 0;
4645                 base = s - 1;
4646                 s++;                                /* skip the '0' first */
4647                 while (*s == '#')
4648                     s++;
4649                 if (*s == '.') {
4650                     const char * const f = ++s;
4651                     while (*s == '#')
4652                         s++;
4653                     arg |= 256 + (s - f);
4654                 }
4655                 *fpc++ = s - base;                /* fieldsize for FETCH */
4656                 *fpc++ = FF_0DECIMAL;
4657                 *fpc++ = (U16)arg;
4658                 unchopnum |= ! ischop;
4659             }
4660             else {
4661                 I32 prespace = 0;
4662                 bool ismore = FALSE;
4663
4664                 if (*s == '>') {
4665                     while (*++s == '>') ;
4666                     prespace = FF_SPACE;
4667                 }
4668                 else if (*s == '|') {
4669                     while (*++s == '|') ;
4670                     prespace = FF_HALFSPACE;
4671                     postspace = TRUE;
4672                 }
4673                 else {
4674                     if (*s == '<')
4675                         while (*++s == '<') ;
4676                     postspace = TRUE;
4677                 }
4678                 if (*s == '.' && s[1] == '.' && s[2] == '.') {
4679                     s += 3;
4680                     ismore = TRUE;
4681                 }
4682                 *fpc++ = s - base;              /* fieldsize for FETCH */
4683
4684                 *fpc++ = ischop ? FF_CHECKCHOP : FF_CHECKNL;
4685
4686                 if (prespace)
4687                     *fpc++ = (U16)prespace;
4688                 *fpc++ = FF_ITEM;
4689                 if (ismore)
4690                     *fpc++ = FF_MORE;
4691                 if (ischop)
4692                     *fpc++ = FF_CHOP;
4693             }
4694             base = s;
4695             skipspaces = 0;
4696             continue;
4697         }
4698     }
4699     *fpc++ = FF_END;
4700
4701     assert (fpc <= fops + maxops); /* ensure our buffer estimate was valid */
4702     arg = fpc - fops;
4703     { /* need to jump to the next word */
4704         int z;
4705         z = WORD_ALIGN - SvCUR(sv) % WORD_ALIGN;
4706         SvGROW(sv, SvCUR(sv) + z + arg * sizeof(U32) + 4);
4707         s = SvPVX(sv) + SvCUR(sv) + z;
4708     }
4709     Copy(fops, s, arg, U32);
4710     Safefree(fops);
4711     sv_magic(sv, NULL, PERL_MAGIC_fm, NULL, 0);
4712     SvCOMPILED_on(sv);
4713
4714     if (unchopnum && repeat)
4715         DIE(aTHX_ "Repeated format line will never terminate (~~ and @#)");
4716     return 0;
4717 }
4718
4719
4720 STATIC bool
4721 S_num_overflow(NV value, I32 fldsize, I32 frcsize)
4722 {
4723     /* Can value be printed in fldsize chars, using %*.*f ? */
4724     NV pwr = 1;
4725     NV eps = 0.5;
4726     bool res = FALSE;
4727     int intsize = fldsize - (value < 0 ? 1 : 0);
4728
4729     if (frcsize & 256)
4730         intsize--;
4731     frcsize &= 255;
4732     intsize -= frcsize;
4733
4734     while (intsize--) pwr *= 10.0;
4735     while (frcsize--) eps /= 10.0;
4736
4737     if( value >= 0 ){
4738         if (value + eps >= pwr)
4739             res = TRUE;
4740     } else {
4741         if (value - eps <= -pwr)
4742             res = TRUE;
4743     }
4744     return res;
4745 }
4746
4747 static I32
4748 S_run_user_filter(pTHX_ int idx, SV *buf_sv, int maxlen)
4749 {
4750     dVAR;
4751     SV * const datasv = FILTER_DATA(idx);
4752     const int filter_has_file = IoLINES(datasv);
4753     SV * const filter_state = MUTABLE_SV(IoTOP_GV(datasv));
4754     SV * const filter_sub = MUTABLE_SV(IoBOTTOM_GV(datasv));
4755     int status = 0;
4756     SV *upstream;
4757     STRLEN got_len;
4758     const char *got_p = NULL;
4759     const char *prune_from = NULL;
4760     bool read_from_cache = FALSE;
4761     STRLEN umaxlen;
4762
4763     PERL_ARGS_ASSERT_RUN_USER_FILTER;
4764
4765     assert(maxlen >= 0);
4766     umaxlen = maxlen;
4767
4768     /* I was having segfault trouble under Linux 2.2.5 after a
4769        parse error occured.  (Had to hack around it with a test
4770        for PL_parser->error_count == 0.)  Solaris doesn't segfault --
4771        not sure where the trouble is yet.  XXX */
4772
4773     if (IoFMT_GV(datasv)) {
4774         SV *const cache = MUTABLE_SV(IoFMT_GV(datasv));
4775         if (SvOK(cache)) {
4776             STRLEN cache_len;
4777             const char *cache_p = SvPV(cache, cache_len);
4778             STRLEN take = 0;
4779
4780             if (umaxlen) {
4781                 /* Running in block mode and we have some cached data already.
4782                  */
4783                 if (cache_len >= umaxlen) {
4784                     /* In fact, so much data we don't even need to call
4785                        filter_read.  */
4786                     take = umaxlen;
4787                 }
4788             } else {
4789                 const char *const first_nl =
4790                     (const char *)memchr(cache_p, '\n', cache_len);
4791                 if (first_nl) {
4792                     take = first_nl + 1 - cache_p;
4793                 }
4794             }
4795             if (take) {
4796                 sv_catpvn(buf_sv, cache_p, take);
4797                 sv_chop(cache, cache_p + take);
4798                 /* Definately not EOF  */
4799                 return 1;
4800             }
4801
4802             sv_catsv(buf_sv, cache);
4803             if (umaxlen) {
4804                 umaxlen -= cache_len;
4805             }
4806             SvOK_off(cache);
4807             read_from_cache = TRUE;
4808         }
4809     }
4810
4811     /* Filter API says that the filter appends to the contents of the buffer.
4812        Usually the buffer is "", so the details don't matter. But if it's not,
4813        then clearly what it contains is already filtered by this filter, so we
4814        don't want to pass it in a second time.
4815        I'm going to use a mortal in case the upstream filter croaks.  */
4816     upstream = ((SvOK(buf_sv) && sv_len(buf_sv)) || SvGMAGICAL(buf_sv))
4817         ? sv_newmortal() : buf_sv;
4818     SvUPGRADE(upstream, SVt_PV);
4819
4820     if (filter_has_file) {
4821         status = FILTER_READ(idx+1, upstream, 0);
4822     }
4823
4824     if (filter_sub && status >= 0) {
4825         dSP;
4826         int count;
4827
4828         ENTER;
4829         SAVE_DEFSV;
4830         SAVETMPS;
4831         EXTEND(SP, 2);
4832
4833         DEFSV_set(upstream);
4834         PUSHMARK(SP);
4835         mPUSHi(0);
4836         if (filter_state) {
4837             PUSHs(filter_state);
4838         }
4839         PUTBACK;
4840         count = call_sv(filter_sub, G_SCALAR);
4841         SPAGAIN;
4842
4843         if (count > 0) {
4844             SV *out = POPs;
4845             if (SvOK(out)) {
4846                 status = SvIV(out);
4847             }
4848         }
4849
4850         PUTBACK;
4851         FREETMPS;
4852         LEAVE;
4853     }
4854
4855     if(SvOK(upstream)) {
4856         got_p = SvPV(upstream, got_len);
4857         if (umaxlen) {
4858             if (got_len > umaxlen) {
4859                 prune_from = got_p + umaxlen;
4860             }
4861         } else {
4862             const char *const first_nl =
4863                 (const char *)memchr(got_p, '\n', got_len);
4864             if (first_nl && first_nl + 1 < got_p + got_len) {
4865                 /* There's a second line here... */
4866                 prune_from = first_nl + 1;
4867             }
4868         }
4869     }
4870     if (prune_from) {
4871         /* Oh. Too long. Stuff some in our cache.  */
4872         STRLEN cached_len = got_p + got_len - prune_from;
4873         SV *cache = MUTABLE_SV(IoFMT_GV(datasv));
4874
4875         if (!cache) {
4876             IoFMT_GV(datasv) = MUTABLE_GV((cache = newSV(got_len - umaxlen)));
4877         } else if (SvOK(cache)) {
4878             /* Cache should be empty.  */
4879             assert(!SvCUR(cache));
4880         }
4881
4882         sv_setpvn(cache, prune_from, cached_len);
4883         /* If you ask for block mode, you may well split UTF-8 characters.
4884            "If it breaks, you get to keep both parts"
4885            (Your code is broken if you  don't put them back together again
4886            before something notices.) */
4887         if (SvUTF8(upstream)) {
4888             SvUTF8_on(cache);
4889         }
4890         SvCUR_set(upstream, got_len - cached_len);
4891         /* Can't yet be EOF  */
4892         if (status == 0)
4893             status = 1;
4894     }
4895
4896     /* If they are at EOF but buf_sv has something in it, then they may never
4897        have touched the SV upstream, so it may be undefined.  If we naively
4898        concatenate it then we get a warning about use of uninitialised value.
4899     */
4900     if (upstream != buf_sv && (SvOK(upstream) || SvGMAGICAL(upstream))) {
4901         sv_catsv(buf_sv, upstream);
4902     }
4903
4904     if (status <= 0) {
4905         IoLINES(datasv) = 0;
4906         SvREFCNT_dec(IoFMT_GV(datasv));
4907         if (filter_state) {
4908             SvREFCNT_dec(filter_state);
4909             IoTOP_GV(datasv) = NULL;
4910         }
4911         if (filter_sub) {
4912             SvREFCNT_dec(filter_sub);
4913             IoBOTTOM_GV(datasv) = NULL;
4914         }
4915         filter_del(S_run_user_filter);
4916     }
4917     if (status == 0 && read_from_cache) {
4918         /* If we read some data from the cache (and by getting here it implies
4919            that we emptied the cache) then we aren't yet at EOF, and mustn't
4920            report that to our caller.  */
4921         return 1;
4922     }
4923     return status;
4924 }
4925
4926 /* perhaps someone can come up with a better name for
4927    this?  it is not really "absolute", per se ... */
4928 static bool
4929 S_path_is_absolute(const char *name)
4930 {
4931     PERL_ARGS_ASSERT_PATH_IS_ABSOLUTE;
4932
4933     if (PERL_FILE_IS_ABSOLUTE(name)
4934 #ifdef MACOS_TRADITIONAL
4935         || (*name == ':')
4936 #else
4937         || (*name == '.' && (name[1] == '/' ||
4938                              (name[1] == '.' && name[2] == '/')))
4939 #endif
4940          )
4941     {
4942         return TRUE;
4943     }
4944     else
4945         return FALSE;
4946 }
4947
4948 /*
4949  * Local variables:
4950  * c-indentation-style: bsd
4951  * c-basic-offset: 4
4952  * indent-tabs-mode: t
4953  * End:
4954  *
4955  * ex: set ts=8 sts=4 sw=4 noet:
4956  */