pp_ctl.c

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