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