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