pp_ctl.c

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