pp_ctl.c

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