pp_ctl.c

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