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_STACK:
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_STACK:
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_STACK:
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_STACK:
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 = 0;
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 #ifndef USE_ITHREADS
1853         svp = &PAD_SVl(PL_op->op_targ);         /* "my" variable */
1854         SAVESPTR(*svp);
1855 #else
1856         SAVEPADSV(PL_op->op_targ);
1857         iterdata = INT2PTR(void*, PL_op->op_targ);
1858         cxtype |= CXp_PADVAR;
1859 #endif
1860     }
1861     else {
1862         GV * const gv = (GV*)POPs;
1863         svp = &GvSV(gv);                        /* symbol table variable */
1864         SAVEGENERICSV(*svp);
1865         *svp = newSV(0);
1866 #ifdef USE_ITHREADS
1867         iterdata = (void*)gv;
1868 #endif
1869     }
1870
1871     if (PL_op->op_private & OPpITER_DEF)
1872         cxtype |= CXp_FOR_DEF;
1873
1874     ENTER;
1875
1876     cxtype |= (PL_op->op_flags & OPf_STACKED) ? CXt_LOOP_FOR : CXt_LOOP_STACK;
1877     PUSHBLOCK(cx, cxtype, SP);
1878 #ifdef USE_ITHREADS
1879     PUSHLOOP_FOR(cx, iterdata, MARK);
1880 #else
1881     PUSHLOOP_FOR(cx, svp, MARK);
1882 #endif
1883     if (PL_op->op_flags & OPf_STACKED) {
1884         cx->blk_loop.ary_min_u.iterary = (AV*)SvREFCNT_inc(POPs);
1885         if (SvTYPE(cx->blk_loop.ary_min_u.iterary) != SVt_PVAV) {
1886             dPOPss;
1887             SV * const right = (SV*)cx->blk_loop.ary_min_u.iterary;
1888             SvGETMAGIC(sv);
1889             SvGETMAGIC(right);
1890             if (RANGE_IS_NUMERIC(sv,right)) {
1891                 cx->cx_type |= CXt_LOOP_LAZYIV;
1892                 /* Make sure that no-one re-orders cop.h and breaks our
1893                    assumptions */
1894                 assert(CxTYPE(cx) == CXt_LOOP_LAZYIV);
1895 #ifdef NV_PRESERVES_UV
1896                 if ((SvOK(sv) && ((SvNV(sv) < (NV)IV_MIN) ||
1897                                   (SvNV(sv) > (NV)IV_MAX)))
1898                         ||
1899                     (SvOK(right) && ((SvNV(right) > (NV)IV_MAX) ||
1900                                      (SvNV(right) < (NV)IV_MIN))))
1901 #else
1902                 if ((SvOK(sv) && ((SvNV(sv) <= (NV)IV_MIN)
1903                                   ||
1904                                   ((SvNV(sv) > 0) &&
1905                                         ((SvUV(sv) > (UV)IV_MAX) ||
1906                                          (SvNV(sv) > (NV)UV_MAX)))))
1907                         ||
1908                     (SvOK(right) && ((SvNV(right) <= (NV)IV_MIN)
1909                                      ||
1910                                      ((SvNV(right) > 0) &&
1911                                         ((SvUV(right) > (UV)IV_MAX) ||
1912                                          (SvNV(right) > (NV)UV_MAX))))))
1913 #endif
1914                     DIE(aTHX_ "Range iterator outside integer range");
1915                 cx->blk_loop.iterix = SvIV(sv);
1916                 cx->blk_loop.lval_max_u.itermax = SvIV(right);
1917 #ifdef DEBUGGING
1918                 /* for correct -Dstv display */
1919                 cx->blk_oldsp = sp - PL_stack_base;
1920 #endif
1921             }
1922             else {
1923                 cx->blk_loop.lval_max_u.iterlval = newSVsv(sv);
1924                 (void) SvPV_force_nolen(cx->blk_loop.lval_max_u.iterlval);
1925                 /* This will do the upgrade to SVt_PV, and warn if the value
1926                    is uninitialised.  */
1927                 (void) SvPV_nolen_const(right);
1928                 /* Doing this avoids a check every time in pp_iter in pp_hot.c
1929                    to replace !SvOK() with a pointer to "".  */
1930                 if (!SvOK(right)) {
1931                     SvREFCNT_dec(right);
1932                     cx->blk_loop.ary_min_u.iterary = (AV*) &PL_sv_no;
1933                 }
1934             }
1935         }
1936         else if (PL_op->op_private & OPpITER_REVERSED) {
1937             cx->blk_loop.iterix = AvFILL(cx->blk_loop.ary_min_u.iterary) + 1;
1938
1939         }
1940     }
1941     else {
1942         if (PL_op->op_private & OPpITER_REVERSED) {
1943             cx->blk_loop.ary_min_u.itermin = MARK - PL_stack_base + 1;
1944             cx->blk_loop.iterix = cx->blk_oldsp + 1;
1945         }
1946         else {
1947             cx->blk_loop.iterix = MARK - PL_stack_base;
1948         }
1949     }
1950
1951     RETURN;
1952 }
1953
1954 PP(pp_enterloop)
1955 {
1956     dVAR; dSP;
1957     register PERL_CONTEXT *cx;
1958     const I32 gimme = GIMME_V;
1959
1960     ENTER;
1961     SAVETMPS;
1962     ENTER;
1963
1964     PUSHBLOCK(cx, CXt_LOOP_PLAIN, SP);
1965     PUSHLOOP_PLAIN(cx, SP);
1966
1967     RETURN;
1968 }
1969
1970 PP(pp_leaveloop)
1971 {
1972     dVAR; dSP;
1973     register PERL_CONTEXT *cx;
1974     I32 gimme;
1975     SV **newsp;
1976     PMOP *newpm;
1977     SV **mark;
1978
1979     POPBLOCK(cx,newpm);
1980     assert(CxTYPE_is_LOOP(cx));
1981     mark = newsp;
1982     newsp = PL_stack_base + cx->blk_loop.resetsp;
1983
1984     TAINT_NOT;
1985     if (gimme == G_VOID)
1986         NOOP;
1987     else if (gimme == G_SCALAR) {
1988         if (mark < SP)
1989             *++newsp = sv_mortalcopy(*SP);
1990         else
1991             *++newsp = &PL_sv_undef;
1992     }
1993     else {
1994         while (mark < SP) {
1995             *++newsp = sv_mortalcopy(*++mark);
1996             TAINT_NOT;          /* Each item is independent */
1997         }
1998     }
1999     SP = newsp;
2000     PUTBACK;
2001
2002     POPLOOP(cx);        /* Stack values are safe: release loop vars ... */
2003     PL_curpm = newpm;   /* ... and pop $1 et al */
2004
2005     LEAVE;
2006     LEAVE;
2007
2008     return NORMAL;
2009 }
2010
2011 PP(pp_return)
2012 {
2013     dVAR; dSP; dMARK;
2014     register PERL_CONTEXT *cx;
2015     bool popsub2 = FALSE;
2016     bool clear_errsv = FALSE;
2017     I32 gimme;
2018     SV **newsp;
2019     PMOP *newpm;
2020     I32 optype = 0;
2021     SV *sv;
2022     OP *retop;
2023
2024     const I32 cxix = dopoptosub(cxstack_ix);
2025
2026     if (cxix < 0) {
2027         if (CxMULTICALL(cxstack)) { /* In this case we must be in a
2028                                      * sort block, which is a CXt_NULL
2029                                      * not a CXt_SUB */
2030             dounwind(0);
2031             PL_stack_base[1] = *PL_stack_sp;
2032             PL_stack_sp = PL_stack_base + 1;
2033             return 0;
2034         }
2035         else
2036             DIE(aTHX_ "Can't return outside a subroutine");
2037     }
2038     if (cxix < cxstack_ix)
2039         dounwind(cxix);
2040
2041     if (CxMULTICALL(&cxstack[cxix])) {
2042         gimme = cxstack[cxix].blk_gimme;
2043         if (gimme == G_VOID)
2044             PL_stack_sp = PL_stack_base;
2045         else if (gimme == G_SCALAR) {
2046             PL_stack_base[1] = *PL_stack_sp;
2047             PL_stack_sp = PL_stack_base + 1;
2048         }
2049         return 0;
2050     }
2051
2052     POPBLOCK(cx,newpm);
2053     switch (CxTYPE(cx)) {
2054     case CXt_SUB:
2055         popsub2 = TRUE;
2056         retop = cx->blk_sub.retop;
2057         cxstack_ix++; /* preserve cx entry on stack for use by POPSUB */
2058         break;
2059     case CXt_EVAL:
2060         if (!(PL_in_eval & EVAL_KEEPERR))
2061             clear_errsv = TRUE;
2062         POPEVAL(cx);
2063         retop = cx->blk_eval.retop;
2064         if (CxTRYBLOCK(cx))
2065             break;
2066         lex_end();
2067         if (optype == OP_REQUIRE &&
2068             (MARK == SP || (gimme == G_SCALAR && !SvTRUE(*SP))) )
2069         {
2070             /* Unassume the success we assumed earlier. */
2071             SV * const nsv = cx->blk_eval.old_namesv;
2072             (void)hv_delete(GvHVn(PL_incgv), SvPVX_const(nsv), SvCUR(nsv), G_DISCARD);
2073             DIE(aTHX_ "%"SVf" did not return a true value", SVfARG(nsv));
2074         }
2075         break;
2076     case CXt_FORMAT:
2077         POPFORMAT(cx);
2078         retop = cx->blk_sub.retop;
2079         break;
2080     default:
2081         DIE(aTHX_ "panic: return");
2082     }
2083
2084     TAINT_NOT;
2085     if (gimme == G_SCALAR) {
2086         if (MARK < SP) {
2087             if (popsub2) {
2088                 if (cx->blk_sub.cv && CvDEPTH(cx->blk_sub.cv) > 1) {
2089                     if (SvTEMP(TOPs)) {
2090                         *++newsp = SvREFCNT_inc(*SP);
2091                         FREETMPS;
2092                         sv_2mortal(*newsp);
2093                     }
2094                     else {
2095                         sv = SvREFCNT_inc(*SP); /* FREETMPS could clobber it */
2096                         FREETMPS;
2097                         *++newsp = sv_mortalcopy(sv);
2098                         SvREFCNT_dec(sv);
2099                     }
2100                 }
2101                 else
2102                     *++newsp = (SvTEMP(*SP)) ? *SP : sv_mortalcopy(*SP);
2103             }
2104             else
2105                 *++newsp = sv_mortalcopy(*SP);
2106         }
2107         else
2108             *++newsp = &PL_sv_undef;
2109     }
2110     else if (gimme == G_ARRAY) {
2111         while (++MARK <= SP) {
2112             *++newsp = (popsub2 && SvTEMP(*MARK))
2113                         ? *MARK : sv_mortalcopy(*MARK);
2114             TAINT_NOT;          /* Each item is independent */
2115         }
2116     }
2117     PL_stack_sp = newsp;
2118
2119     LEAVE;
2120     /* Stack values are safe: */
2121     if (popsub2) {
2122         cxstack_ix--;
2123         POPSUB(cx,sv);  /* release CV and @_ ... */
2124     }
2125     else
2126         sv = NULL;
2127     PL_curpm = newpm;   /* ... and pop $1 et al */
2128
2129     LEAVESUB(sv);
2130     if (clear_errsv)
2131         sv_setpvn(ERRSV,"",0);
2132     return retop;
2133 }
2134
2135 PP(pp_last)
2136 {
2137     dVAR; dSP;
2138     I32 cxix;
2139     register PERL_CONTEXT *cx;
2140     I32 pop2 = 0;
2141     I32 gimme;
2142     I32 optype;
2143     OP *nextop;
2144     SV **newsp;
2145     PMOP *newpm;
2146     SV **mark;
2147     SV *sv = NULL;
2148
2149
2150     if (PL_op->op_flags & OPf_SPECIAL) {
2151         cxix = dopoptoloop(cxstack_ix);
2152         if (cxix < 0)
2153             DIE(aTHX_ "Can't \"last\" outside a loop block");
2154     }
2155     else {
2156         cxix = dopoptolabel(cPVOP->op_pv);
2157         if (cxix < 0)
2158             DIE(aTHX_ "Label not found for \"last %s\"", cPVOP->op_pv);
2159     }
2160     if (cxix < cxstack_ix)
2161         dounwind(cxix);
2162
2163     POPBLOCK(cx,newpm);
2164     cxstack_ix++; /* temporarily protect top context */
2165     mark = newsp;
2166     switch (CxTYPE(cx)) {
2167     case CXt_LOOP_LAZYIV:
2168     case CXt_LOOP_STACK:
2169     case CXt_LOOP_FOR:
2170     case CXt_LOOP_PLAIN:
2171         pop2 = CxTYPE(cx);
2172         newsp = PL_stack_base + cx->blk_loop.resetsp;
2173         nextop = cx->blk_loop.my_op->op_lastop->op_next;
2174         break;
2175     case CXt_SUB:
2176         pop2 = CXt_SUB;
2177         nextop = cx->blk_sub.retop;
2178         break;
2179     case CXt_EVAL:
2180         POPEVAL(cx);
2181         nextop = cx->blk_eval.retop;
2182         break;
2183     case CXt_FORMAT:
2184         POPFORMAT(cx);
2185         nextop = cx->blk_sub.retop;
2186         break;
2187     default:
2188         DIE(aTHX_ "panic: last");
2189     }
2190
2191     TAINT_NOT;
2192     if (gimme == G_SCALAR) {
2193         if (MARK < SP)
2194             *++newsp = ((pop2 == CXt_SUB) && SvTEMP(*SP))
2195                         ? *SP : sv_mortalcopy(*SP);
2196         else
2197             *++newsp = &PL_sv_undef;
2198     }
2199     else if (gimme == G_ARRAY) {
2200         while (++MARK <= SP) {
2201             *++newsp = ((pop2 == CXt_SUB) && SvTEMP(*MARK))
2202                         ? *MARK : sv_mortalcopy(*MARK);
2203             TAINT_NOT;          /* Each item is independent */
2204         }
2205     }
2206     SP = newsp;
2207     PUTBACK;
2208
2209     LEAVE;
2210     cxstack_ix--;
2211     /* Stack values are safe: */
2212     switch (pop2) {
2213     case CXt_LOOP_LAZYIV:
2214     case CXt_LOOP_PLAIN:
2215     case CXt_LOOP_STACK:
2216     case CXt_LOOP_FOR:
2217         POPLOOP(cx);    /* release loop vars ... */
2218         LEAVE;
2219         break;
2220     case CXt_SUB:
2221         POPSUB(cx,sv);  /* release CV and @_ ... */
2222         break;
2223     }
2224     PL_curpm = newpm;   /* ... and pop $1 et al */
2225
2226     LEAVESUB(sv);
2227     PERL_UNUSED_VAR(optype);
2228     PERL_UNUSED_VAR(gimme);
2229     return nextop;
2230 }
2231
2232 PP(pp_next)
2233 {
2234     dVAR;
2235     I32 cxix;
2236     register PERL_CONTEXT *cx;
2237     I32 inner;
2238
2239     if (PL_op->op_flags & OPf_SPECIAL) {
2240         cxix = dopoptoloop(cxstack_ix);
2241         if (cxix < 0)
2242             DIE(aTHX_ "Can't \"next\" outside a loop block");
2243     }
2244     else {
2245         cxix = dopoptolabel(cPVOP->op_pv);
2246         if (cxix < 0)
2247             DIE(aTHX_ "Label not found for \"next %s\"", cPVOP->op_pv);
2248     }
2249     if (cxix < cxstack_ix)
2250         dounwind(cxix);
2251
2252     /* clear off anything above the scope we're re-entering, but
2253      * save the rest until after a possible continue block */
2254     inner = PL_scopestack_ix;
2255     TOPBLOCK(cx);
2256     if (PL_scopestack_ix < inner)
2257         leave_scope(PL_scopestack[PL_scopestack_ix]);
2258     PL_curcop = cx->blk_oldcop;
2259     return CX_LOOP_NEXTOP_GET(cx);
2260 }
2261
2262 PP(pp_redo)
2263 {
2264     dVAR;
2265     I32 cxix;
2266     register PERL_CONTEXT *cx;
2267     I32 oldsave;
2268     OP* redo_op;
2269
2270     if (PL_op->op_flags & OPf_SPECIAL) {
2271         cxix = dopoptoloop(cxstack_ix);
2272         if (cxix < 0)
2273             DIE(aTHX_ "Can't \"redo\" outside a loop block");
2274     }
2275     else {
2276         cxix = dopoptolabel(cPVOP->op_pv);
2277         if (cxix < 0)
2278             DIE(aTHX_ "Label not found for \"redo %s\"", cPVOP->op_pv);
2279     }
2280     if (cxix < cxstack_ix)
2281         dounwind(cxix);
2282
2283     redo_op = cxstack[cxix].blk_loop.my_op->op_redoop;
2284     if (redo_op->op_type == OP_ENTER) {
2285         /* pop one less context to avoid $x being freed in while (my $x..) */
2286         cxstack_ix++;
2287         assert(CxTYPE(&cxstack[cxstack_ix]) == CXt_BLOCK);
2288         redo_op = redo_op->op_next;
2289     }
2290
2291     TOPBLOCK(cx);
2292     oldsave = PL_scopestack[PL_scopestack_ix - 1];
2293     LEAVE_SCOPE(oldsave);
2294     FREETMPS;
2295     PL_curcop = cx->blk_oldcop;
2296     return redo_op;
2297 }
2298
2299 STATIC OP *
2300 S_dofindlabel(pTHX_ OP *o, const char *label, OP **opstack, OP **oplimit)
2301 {
2302     dVAR;
2303     OP **ops = opstack;
2304     static const char too_deep[] = "Target of goto is too deeply nested";
2305
2306     if (ops >= oplimit)
2307         Perl_croak(aTHX_ too_deep);
2308     if (o->op_type == OP_LEAVE ||
2309         o->op_type == OP_SCOPE ||
2310         o->op_type == OP_LEAVELOOP ||
2311         o->op_type == OP_LEAVESUB ||
2312         o->op_type == OP_LEAVETRY)
2313     {
2314         *ops++ = cUNOPo->op_first;
2315         if (ops >= oplimit)
2316             Perl_croak(aTHX_ too_deep);
2317     }
2318     *ops = 0;
2319     if (o->op_flags & OPf_KIDS) {
2320         OP *kid;
2321         /* First try all the kids at this level, since that's likeliest. */
2322         for (kid = cUNOPo->op_first; kid; kid = kid->op_sibling) {
2323             if ((kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE) &&
2324                     kCOP->cop_label && strEQ(kCOP->cop_label, label))
2325                 return kid;
2326         }
2327         for (kid = cUNOPo->op_first; kid; kid = kid->op_sibling) {
2328             if (kid == PL_lastgotoprobe)
2329                 continue;
2330             if (kid->op_type == OP_NEXTSTATE || kid->op_type == OP_DBSTATE) {
2331                 if (ops == opstack)
2332                     *ops++ = kid;
2333                 else if (ops[-1]->op_type == OP_NEXTSTATE ||
2334                          ops[-1]->op_type == OP_DBSTATE)
2335                     ops[-1] = kid;
2336                 else
2337                     *ops++ = kid;
2338             }
2339             if ((o = dofindlabel(kid, label, ops, oplimit)))
2340                 return o;
2341         }
2342     }
2343     *ops = 0;
2344     return 0;
2345 }
2346
2347 PP(pp_goto)
2348 {
2349     dVAR; dSP;
2350     OP *retop = NULL;
2351     I32 ix;
2352     register PERL_CONTEXT *cx;
2353 #define GOTO_DEPTH 64
2354     OP *enterops[GOTO_DEPTH];
2355     const char *label = NULL;
2356     const bool do_dump = (PL_op->op_type == OP_DUMP);
2357     static const char must_have_label[] = "goto must have label";
2358
2359     if (PL_op->op_flags & OPf_STACKED) {
2360         SV * const sv = POPs;
2361
2362         /* This egregious kludge implements goto &subroutine */
2363         if (SvROK(sv) && SvTYPE(SvRV(sv)) == SVt_PVCV) {
2364             I32 cxix;
2365             register PERL_CONTEXT *cx;
2366             CV* cv = (CV*)SvRV(sv);
2367             SV** mark;
2368             I32 items = 0;
2369             I32 oldsave;
2370             bool reified = 0;
2371
2372         retry:
2373             if (!CvROOT(cv) && !CvXSUB(cv)) {
2374                 const GV * const gv = CvGV(cv);
2375                 if (gv) {
2376                     GV *autogv;
2377                     SV *tmpstr;
2378                     /* autoloaded stub? */
2379                     if (cv != GvCV(gv) && (cv = GvCV(gv)))
2380                         goto retry;
2381                     autogv = gv_autoload4(GvSTASH(gv), GvNAME(gv),
2382                                           GvNAMELEN(gv), FALSE);
2383                     if (autogv && (cv = GvCV(autogv)))
2384                         goto retry;
2385                     tmpstr = sv_newmortal();
2386                     gv_efullname3(tmpstr, gv, NULL);
2387                     DIE(aTHX_ "Goto undefined subroutine &%"SVf"", SVfARG(tmpstr));
2388                 }
2389                 DIE(aTHX_ "Goto undefined subroutine");
2390             }
2391
2392             /* First do some returnish stuff. */
2393             SvREFCNT_inc_simple_void(cv); /* avoid premature free during unwind */
2394             FREETMPS;
2395             cxix = dopoptosub(cxstack_ix);
2396             if (cxix < 0)
2397                 DIE(aTHX_ "Can't goto subroutine outside a subroutine");
2398             if (cxix < cxstack_ix)
2399                 dounwind(cxix);
2400             TOPBLOCK(cx);
2401             SPAGAIN;
2402             /* ban goto in eval: see <20050521150056.GC20213@iabyn.com> */
2403             if (CxTYPE(cx) == CXt_EVAL) {
2404                 if (CxREALEVAL(cx))
2405                     DIE(aTHX_ "Can't goto subroutine from an eval-string");
2406                 else
2407                     DIE(aTHX_ "Can't goto subroutine from an eval-block");
2408             }
2409             else if (CxMULTICALL(cx))
2410                 DIE(aTHX_ "Can't goto subroutine from a sort sub (or similar callback)");
2411             if (CxTYPE(cx) == CXt_SUB && CxHASARGS(cx)) {
2412                 /* put @_ back onto stack */
2413                 AV* av = cx->blk_sub.argarray;
2414
2415                 items = AvFILLp(av) + 1;
2416                 EXTEND(SP, items+1); /* @_ could have been extended. */
2417                 Copy(AvARRAY(av), SP + 1, items, SV*);
2418                 SvREFCNT_dec(GvAV(PL_defgv));
2419                 GvAV(PL_defgv) = cx->blk_sub.savearray;
2420                 CLEAR_ARGARRAY(av);
2421                 /* abandon @_ if it got reified */
2422                 if (AvREAL(av)) {
2423                     reified = 1;
2424                     SvREFCNT_dec(av);
2425                     av = newAV();
2426                     av_extend(av, items-1);
2427                     AvREIFY_only(av);
2428                     PAD_SVl(0) = (SV*)(cx->blk_sub.argarray = av);
2429                 }
2430             }
2431             else if (CvISXSUB(cv)) {    /* put GvAV(defgv) back onto stack */
2432                 AV* const av = GvAV(PL_defgv);
2433                 items = AvFILLp(av) + 1;
2434                 EXTEND(SP, items+1); /* @_ could have been extended. */
2435                 Copy(AvARRAY(av), SP + 1, items, SV*);
2436             }
2437             mark = SP;
2438             SP += items;
2439             if (CxTYPE(cx) == CXt_SUB &&
2440                 !(CvDEPTH(cx->blk_sub.cv) = cx->blk_sub.olddepth))
2441                 SvREFCNT_dec(cx->blk_sub.cv);
2442             oldsave = PL_scopestack[PL_scopestack_ix - 1];
2443             LEAVE_SCOPE(oldsave);
2444
2445             /* Now do some callish stuff. */
2446             SAVETMPS;
2447             SAVEFREESV(cv); /* later, undo the 'avoid premature free' hack */
2448             if (CvISXSUB(cv)) {
2449                 OP* const retop = cx->blk_sub.retop;
2450                 SV **newsp;
2451                 I32 gimme;
2452                 if (reified) {
2453                     I32 index;
2454                     for (index=0; index<items; index++)
2455                         sv_2mortal(SP[-index]);
2456                 }
2457
2458                 /* XS subs don't have a CxSUB, so pop it */
2459                 POPBLOCK(cx, PL_curpm);
2460                 /* Push a mark for the start of arglist */
2461                 PUSHMARK(mark);
2462                 PUTBACK;
2463                 (void)(*CvXSUB(cv))(aTHX_ cv);
2464                 LEAVE;
2465                 return retop;
2466             }
2467             else {
2468                 AV* const padlist = CvPADLIST(cv);
2469                 if (CxTYPE(cx) == CXt_EVAL) {
2470                     PL_in_eval = CxOLD_IN_EVAL(cx);
2471                     PL_eval_root = cx->blk_eval.old_eval_root;
2472                     cx->cx_type = CXt_SUB;
2473                 }
2474                 cx->blk_sub.cv = cv;
2475                 cx->blk_sub.olddepth = CvDEPTH(cv);
2476
2477                 CvDEPTH(cv)++;
2478                 if (CvDEPTH(cv) < 2)
2479                     SvREFCNT_inc_simple_void_NN(cv);
2480                 else {
2481                     if (CvDEPTH(cv) == PERL_SUB_DEPTH_WARN && ckWARN(WARN_RECURSION))
2482                         sub_crush_depth(cv);
2483                     pad_push(padlist, CvDEPTH(cv));
2484                 }
2485                 SAVECOMPPAD();
2486                 PAD_SET_CUR_NOSAVE(padlist, CvDEPTH(cv));
2487                 if (CxHASARGS(cx))
2488                 {
2489                     AV* const av = (AV*)PAD_SVl(0);
2490
2491                     cx->blk_sub.savearray = GvAV(PL_defgv);
2492                     GvAV(PL_defgv) = (AV*)SvREFCNT_inc_simple(av);
2493                     CX_CURPAD_SAVE(cx->blk_sub);
2494                     cx->blk_sub.argarray = av;
2495
2496                     if (items >= AvMAX(av) + 1) {
2497                         SV **ary = AvALLOC(av);
2498                         if (AvARRAY(av) != ary) {
2499                             AvMAX(av) += AvARRAY(av) - AvALLOC(av);
2500                             AvARRAY(av) = ary;
2501                         }
2502                         if (items >= AvMAX(av) + 1) {
2503                             AvMAX(av) = items - 1;
2504                             Renew(ary,items+1,SV*);
2505                             AvALLOC(av) = ary;
2506                             AvARRAY(av) = ary;
2507                         }
2508                     }
2509                     ++mark;
2510                     Copy(mark,AvARRAY(av),items,SV*);
2511                     AvFILLp(av) = items - 1;
2512                     assert(!AvREAL(av));
2513                     if (reified) {
2514                         /* transfer 'ownership' of refcnts to new @_ */
2515                         AvREAL_on(av);
2516                         AvREIFY_off(av);
2517                     }
2518                     while (items--) {
2519                         if (*mark)
2520                             SvTEMP_off(*mark);
2521                         mark++;
2522                     }
2523                 }
2524                 if (PERLDB_SUB) {       /* Checking curstash breaks DProf. */
2525                     Perl_get_db_sub(aTHX_ NULL, cv);
2526                     if (PERLDB_GOTO) {
2527                         CV * const gotocv = get_cv("DB::goto", FALSE);
2528                         if (gotocv) {
2529                             PUSHMARK( PL_stack_sp );
2530                             call_sv((SV*)gotocv, G_SCALAR | G_NODEBUG);
2531                             PL_stack_sp--;
2532                         }
2533                     }
2534                 }
2535                 RETURNOP(CvSTART(cv));
2536             }
2537         }
2538         else {
2539             label = SvPV_nolen_const(sv);
2540             if (!(do_dump || *label))
2541                 DIE(aTHX_ must_have_label);
2542         }
2543     }
2544     else if (PL_op->op_flags & OPf_SPECIAL) {
2545         if (! do_dump)
2546             DIE(aTHX_ must_have_label);
2547     }
2548     else
2549         label = cPVOP->op_pv;
2550
2551     if (label && *label) {
2552         OP *gotoprobe = NULL;
2553         bool leaving_eval = FALSE;
2554         bool in_block = FALSE;
2555         PERL_CONTEXT *last_eval_cx = NULL;
2556
2557         /* find label */
2558
2559         PL_lastgotoprobe = NULL;
2560         *enterops = 0;
2561         for (ix = cxstack_ix; ix >= 0; ix--) {
2562             cx = &cxstack[ix];
2563             switch (CxTYPE(cx)) {
2564             case CXt_EVAL:
2565                 leaving_eval = TRUE;
2566                 if (!CxTRYBLOCK(cx)) {
2567                     gotoprobe = (last_eval_cx ?
2568                                 last_eval_cx->blk_eval.old_eval_root :
2569                                 PL_eval_root);
2570                     last_eval_cx = cx;
2571                     break;
2572                 }
2573                 /* else fall through */
2574             case CXt_LOOP_LAZYIV:
2575             case CXt_LOOP_STACK:
2576             case CXt_LOOP_FOR:
2577             case CXt_LOOP_PLAIN:
2578                 gotoprobe = cx->blk_oldcop->op_sibling;
2579                 break;
2580             case CXt_SUBST:
2581                 continue;
2582             case CXt_BLOCK:
2583                 if (ix) {
2584                     gotoprobe = cx->blk_oldcop->op_sibling;
2585                     in_block = TRUE;
2586                 } else
2587                     gotoprobe = PL_main_root;
2588                 break;
2589             case CXt_SUB:
2590                 if (CvDEPTH(cx->blk_sub.cv) && !CxMULTICALL(cx)) {
2591                     gotoprobe = CvROOT(cx->blk_sub.cv);
2592                     break;
2593                 }
2594                 /* FALL THROUGH */
2595             case CXt_FORMAT:
2596             case CXt_NULL:
2597                 DIE(aTHX_ "Can't \"goto\" out of a pseudo block");
2598             default:
2599                 if (ix)
2600                     DIE(aTHX_ "panic: goto");
2601                 gotoprobe = PL_main_root;
2602                 break;
2603             }
2604             if (gotoprobe) {
2605                 retop = dofindlabel(gotoprobe, label,
2606                                     enterops, enterops + GOTO_DEPTH);
2607                 if (retop)
2608                     break;
2609             }
2610             PL_lastgotoprobe = gotoprobe;
2611         }
2612         if (!retop)
2613             DIE(aTHX_ "Can't find label %s", label);
2614
2615         /* if we're leaving an eval, check before we pop any frames
2616            that we're not going to punt, otherwise the error
2617            won't be caught */
2618
2619         if (leaving_eval && *enterops && enterops[1]) {
2620             I32 i;
2621             for (i = 1; enterops[i]; i++)
2622                 if (enterops[i]->op_type == OP_ENTERITER)
2623                     DIE(aTHX_ "Can't \"goto\" into the middle of a foreach loop");
2624         }
2625
2626         /* pop unwanted frames */
2627
2628         if (ix < cxstack_ix) {
2629             I32 oldsave;
2630
2631             if (ix < 0)
2632                 ix = 0;
2633             dounwind(ix);
2634             TOPBLOCK(cx);
2635             oldsave = PL_scopestack[PL_scopestack_ix];
2636             LEAVE_SCOPE(oldsave);
2637         }
2638
2639         /* push wanted frames */
2640
2641         if (*enterops && enterops[1]) {
2642             OP * const oldop = PL_op;
2643             ix = enterops[1]->op_type == OP_ENTER && in_block ? 2 : 1;
2644             for (; enterops[ix]; ix++) {
2645                 PL_op = enterops[ix];
2646                 /* Eventually we may want to stack the needed arguments
2647                  * for each op.  For now, we punt on the hard ones. */
2648                 if (PL_op->op_type == OP_ENTERITER)
2649                     DIE(aTHX_ "Can't \"goto\" into the middle of a foreach loop");
2650                 CALL_FPTR(PL_op->op_ppaddr)(aTHX);
2651             }
2652             PL_op = oldop;
2653         }
2654     }
2655
2656     if (do_dump) {
2657 #ifdef VMS
2658         if (!retop) retop = PL_main_start;
2659 #endif
2660         PL_restartop = retop;
2661         PL_do_undump = TRUE;
2662
2663         my_unexec();
2664
2665         PL_restartop = 0;               /* hmm, must be GNU unexec().. */
2666         PL_do_undump = FALSE;
2667     }
2668
2669     RETURNOP(retop);
2670 }
2671
2672 PP(pp_exit)
2673 {
2674     dVAR;
2675     dSP;
2676     I32 anum;
2677
2678     if (MAXARG < 1)
2679         anum = 0;
2680     else {
2681         anum = SvIVx(POPs);
2682 #ifdef VMS
2683         if (anum == 1 && (PL_op->op_private & OPpEXIT_VMSISH))
2684             anum = 0;
2685         VMSISH_HUSHED  = VMSISH_HUSHED || (PL_op->op_private & OPpHUSH_VMSISH);
2686 #endif
2687     }
2688     PL_exit_flags |= PERL_EXIT_EXPECTED;
2689 #ifdef PERL_MAD
2690     /* KLUDGE: disable exit 0 in BEGIN blocks when we're just compiling */
2691     if (anum || !(PL_minus_c && PL_madskills))
2692         my_exit(anum);
2693 #else
2694     my_exit(anum);
2695 #endif
2696     PUSHs(&PL_sv_undef);
2697     RETURN;
2698 }
2699
2700 /* Eval. */
2701
2702 STATIC void
2703 S_save_lines(pTHX_ AV *array, SV *sv)
2704 {
2705     const char *s = SvPVX_const(sv);
2706     const char * const send = SvPVX_const(sv) + SvCUR(sv);
2707     I32 line = 1;
2708
2709     while (s && s < send) {
2710         const char *t;
2711         SV * const tmpstr = newSV_type(SVt_PVMG);
2712
2713         t = strchr(s, '\n');
2714         if (t)
2715             t++;
2716         else
2717             t = send;
2718
2719         sv_setpvn(tmpstr, s, t - s);
2720         av_store(array, line++, tmpstr);
2721         s = t;
2722     }
2723 }
2724
2725 STATIC OP *
2726 S_docatch(pTHX_ OP *o)
2727 {
2728     dVAR;
2729     int ret;
2730     OP * const oldop = PL_op;
2731     dJMPENV;
2732
2733 #ifdef DEBUGGING
2734     assert(CATCH_GET == TRUE);
2735 #endif
2736     PL_op = o;
2737
2738     JMPENV_PUSH(ret);
2739     switch (ret) {
2740     case 0:
2741         assert(cxstack_ix >= 0);
2742         assert(CxTYPE(&cxstack[cxstack_ix]) == CXt_EVAL);
2743         cxstack[cxstack_ix].blk_eval.cur_top_env = PL_top_env;
2744  redo_body:
2745         CALLRUNOPS(aTHX);
2746         break;
2747     case 3:
2748         /* die caught by an inner eval - continue inner loop */
2749
2750         /* NB XXX we rely on the old popped CxEVAL still being at the top
2751          * of the stack; the way die_where() currently works, this
2752          * assumption is valid. In theory The cur_top_env value should be
2753          * returned in another global, the way retop (aka PL_restartop)
2754          * is. */
2755         assert(CxTYPE(&cxstack[cxstack_ix+1]) == CXt_EVAL);
2756
2757         if (PL_restartop
2758             && cxstack[cxstack_ix+1].blk_eval.cur_top_env == PL_top_env)
2759         {
2760             PL_op = PL_restartop;
2761             PL_restartop = 0;
2762             goto redo_body;
2763         }
2764         /* FALL THROUGH */
2765     default:
2766         JMPENV_POP;
2767         PL_op = oldop;
2768         JMPENV_JUMP(ret);
2769         /* NOTREACHED */
2770     }
2771     JMPENV_POP;
2772     PL_op = oldop;
2773     return NULL;
2774 }
2775
2776 OP *
2777 Perl_sv_compile_2op(pTHX_ SV *sv, OP** startop, const char *code, PAD** padp)
2778 /* sv Text to convert to OP tree. */
2779 /* startop op_free() this to undo. */
2780 /* code Short string id of the caller. */
2781 {
2782     /* FIXME - how much of this code is common with pp_entereval?  */
2783     dVAR; dSP;                          /* Make POPBLOCK work. */
2784     PERL_CONTEXT *cx;
2785     SV **newsp;
2786     I32 gimme = G_VOID;
2787     I32 optype;
2788     OP dummy;
2789     char tbuf[TYPE_DIGITS(long) + 12 + 10];
2790     char *tmpbuf = tbuf;
2791     char *safestr;
2792     int runtime;
2793     CV* runcv = NULL;   /* initialise to avoid compiler warnings */
2794     STRLEN len;
2795
2796     ENTER;
2797     lex_start(sv, NULL, FALSE);
2798     SAVETMPS;
2799     /* switch to eval mode */
2800
2801     if (IN_PERL_COMPILETIME) {
2802         SAVECOPSTASH_FREE(&PL_compiling);
2803         CopSTASH_set(&PL_compiling, PL_curstash);
2804     }
2805     if (PERLDB_NAMEEVAL && CopLINE(PL_curcop)) {
2806         SV * const sv = sv_newmortal();
2807         Perl_sv_setpvf(aTHX_ sv, "_<(%.10seval %lu)[%s:%"IVdf"]",
2808                        code, (unsigned long)++PL_evalseq,
2809                        CopFILE(PL_curcop), (IV)CopLINE(PL_curcop));
2810         tmpbuf = SvPVX(sv);
2811         len = SvCUR(sv);
2812     }
2813     else
2814         len = my_snprintf(tmpbuf, sizeof(tbuf), "_<(%.10s_eval %lu)", code,
2815                           (unsigned long)++PL_evalseq);
2816     SAVECOPFILE_FREE(&PL_compiling);
2817     CopFILE_set(&PL_compiling, tmpbuf+2);
2818     SAVECOPLINE(&PL_compiling);
2819     CopLINE_set(&PL_compiling, 1);
2820     /* XXX For C<eval "...">s within BEGIN {} blocks, this ends up
2821        deleting the eval's FILEGV from the stash before gv_check() runs
2822        (i.e. before run-time proper). To work around the coredump that
2823        ensues, we always turn GvMULTI_on for any globals that were
2824        introduced within evals. See force_ident(). GSAR 96-10-12 */
2825     safestr = savepvn(tmpbuf, len);
2826     SAVEDELETE(PL_defstash, safestr, len);
2827     SAVEHINTS();
2828 #ifdef OP_IN_REGISTER
2829     PL_opsave = op;
2830 #else
2831     SAVEVPTR(PL_op);
2832 #endif
2833
2834     /* we get here either during compilation, or via pp_regcomp at runtime */
2835     runtime = IN_PERL_RUNTIME;
2836     if (runtime)
2837         runcv = find_runcv(NULL);
2838
2839     PL_op = &dummy;
2840     PL_op->op_type = OP_ENTEREVAL;
2841     PL_op->op_flags = 0;                        /* Avoid uninit warning. */
2842     PUSHBLOCK(cx, CXt_EVAL|(IN_PERL_COMPILETIME ? 0 : CXp_REAL), SP);
2843     PUSHEVAL(cx, 0, NULL);
2844
2845     if (runtime)
2846         (void) doeval(G_SCALAR, startop, runcv, PL_curcop->cop_seq);
2847     else
2848         (void) doeval(G_SCALAR, startop, PL_compcv, PL_cop_seqmax);
2849     POPBLOCK(cx,PL_curpm);
2850     POPEVAL(cx);
2851
2852     (*startop)->op_type = OP_NULL;
2853     (*startop)->op_ppaddr = PL_ppaddr[OP_NULL];
2854     lex_end();
2855     /* XXX DAPM do this properly one year */
2856     *padp = (AV*)SvREFCNT_inc_simple(PL_comppad);
2857     LEAVE;
2858     if (IN_PERL_COMPILETIME)
2859         CopHINTS_set(&PL_compiling, PL_hints);
2860 #ifdef OP_IN_REGISTER
2861     op = PL_opsave;
2862 #endif
2863     PERL_UNUSED_VAR(newsp);
2864     PERL_UNUSED_VAR(optype);
2865
2866     return PL_eval_start;
2867 }
2868
2869
2870 /*
2871 =for apidoc find_runcv
2872
2873 Locate the CV corresponding to the currently executing sub or eval.
2874 If db_seqp is non_null, skip CVs that are in the DB package and populate
2875 *db_seqp with the cop sequence number at the point that the DB:: code was
2876 entered. (allows debuggers to eval in the scope of the breakpoint rather
2877 than in the scope of the debugger itself).
2878
2879 =cut
2880 */
2881
2882 CV*
2883 Perl_find_runcv(pTHX_ U32 *db_seqp)
2884 {
2885     dVAR;
2886     PERL_SI      *si;
2887
2888     if (db_seqp)
2889         *db_seqp = PL_curcop->cop_seq;
2890     for (si = PL_curstackinfo; si; si = si->si_prev) {
2891         I32 ix;
2892         for (ix = si->si_cxix; ix >= 0; ix--) {
2893             const PERL_CONTEXT *cx = &(si->si_cxstack[ix]);
2894             if (CxTYPE(cx) == CXt_SUB || CxTYPE(cx) == CXt_FORMAT) {
2895                 CV * const cv = cx->blk_sub.cv;
2896                 /* skip DB:: code */
2897                 if (db_seqp && PL_debstash && CvSTASH(cv) == PL_debstash) {
2898                     *db_seqp = cx->blk_oldcop->cop_seq;
2899                     continue;
2900                 }
2901                 return cv;
2902             }
2903             else if (CxTYPE(cx) == CXt_EVAL && !CxTRYBLOCK(cx))
2904                 return PL_compcv;
2905         }
2906     }
2907     return PL_main_cv;
2908 }
2909
2910
2911 /* Compile a require/do, an eval '', or a /(?{...})/.
2912  * In the last case, startop is non-null, and contains the address of
2913  * a pointer that should be set to the just-compiled code.
2914  * outside is the lexically enclosing CV (if any) that invoked us.
2915  * Returns a bool indicating whether the compile was successful; if so,
2916  * PL_eval_start contains the first op of the compiled ocde; otherwise,
2917  * pushes undef (also croaks if startop != NULL).
2918  */
2919
2920 STATIC bool
2921 S_doeval(pTHX_ int gimme, OP** startop, CV* outside, U32 seq)
2922 {
2923     dVAR; dSP;
2924     OP * const saveop = PL_op;
2925
2926     PL_in_eval = ((saveop && saveop->op_type == OP_REQUIRE)
2927                   ? (EVAL_INREQUIRE | (PL_in_eval & EVAL_INEVAL))
2928                   : EVAL_INEVAL);
2929
2930     PUSHMARK(SP);
2931
2932     SAVESPTR(PL_compcv);
2933     PL_compcv = (CV*)newSV_type(SVt_PVCV);
2934     CvEVAL_on(PL_compcv);
2935     assert(CxTYPE(&cxstack[cxstack_ix]) == CXt_EVAL);
2936     cxstack[cxstack_ix].blk_eval.cv = PL_compcv;
2937
2938     CvOUTSIDE_SEQ(PL_compcv) = seq;
2939     CvOUTSIDE(PL_compcv) = (CV*)SvREFCNT_inc_simple(outside);
2940
2941     /* set up a scratch pad */
2942
2943     CvPADLIST(PL_compcv) = pad_new(padnew_SAVE);
2944     PL_op = NULL; /* avoid PL_op and PL_curpad referring to different CVs */
2945
2946
2947     if (!PL_madskills)
2948         SAVEMORTALIZESV(PL_compcv);     /* must remain until end of current statement */
2949
2950     /* make sure we compile in the right package */
2951
2952     if (CopSTASH_ne(PL_curcop, PL_curstash)) {
2953         SAVESPTR(PL_curstash);
2954         PL_curstash = CopSTASH(PL_curcop);
2955     }
2956     /* XXX:ajgo do we really need to alloc an AV for begin/checkunit */
2957     SAVESPTR(PL_beginav);
2958     PL_beginav = newAV();
2959     SAVEFREESV(PL_beginav);
2960     SAVESPTR(PL_unitcheckav);
2961     PL_unitcheckav = newAV();
2962     SAVEFREESV(PL_unitcheckav);
2963
2964 #ifdef PERL_MAD
2965     SAVEBOOL(PL_madskills);
2966     PL_madskills = 0;
2967 #endif
2968
2969     /* try to compile it */
2970
2971     PL_eval_root = NULL;
2972     PL_curcop = &PL_compiling;
2973     CopARYBASE_set(PL_curcop, 0);
2974     if (saveop && (saveop->op_type != OP_REQUIRE) && (saveop->op_flags & OPf_SPECIAL))
2975         PL_in_eval |= EVAL_KEEPERR;
2976     else
2977         sv_setpvn(ERRSV,"",0);
2978     if (yyparse() || PL_parser->error_count || !PL_eval_root) {
2979         SV **newsp;                     /* Used by POPBLOCK. */
2980         PERL_CONTEXT *cx = &cxstack[cxstack_ix];
2981         I32 optype = 0;                 /* Might be reset by POPEVAL. */
2982         const char *msg;
2983
2984         PL_op = saveop;
2985         if (PL_eval_root) {
2986             op_free(PL_eval_root);
2987             PL_eval_root = NULL;
2988         }
2989         SP = PL_stack_base + POPMARK;           /* pop original mark */
2990         if (!startop) {
2991             POPBLOCK(cx,PL_curpm);
2992             POPEVAL(cx);
2993         }
2994         lex_end();
2995         LEAVE;
2996
2997         msg = SvPVx_nolen_const(ERRSV);
2998         if (optype == OP_REQUIRE) {
2999             const SV * const nsv = cx->blk_eval.old_namesv;
3000             (void)hv_store(GvHVn(PL_incgv), SvPVX_const(nsv), SvCUR(nsv),
3001                           &PL_sv_undef, 0);
3002             Perl_croak(aTHX_ "%sCompilation failed in require",
3003                        *msg ? msg : "Unknown error\n");
3004         }
3005         else if (startop) {
3006             POPBLOCK(cx,PL_curpm);
3007             POPEVAL(cx);
3008             Perl_croak(aTHX_ "%sCompilation failed in regexp",
3009                        (*msg ? msg : "Unknown error\n"));
3010         }
3011         else {
3012             if (!*msg) {
3013                 sv_setpvs(ERRSV, "Compilation error");
3014             }
3015         }
3016         PERL_UNUSED_VAR(newsp);
3017         PUSHs(&PL_sv_undef);
3018         PUTBACK;
3019         return FALSE;
3020     }
3021     CopLINE_set(&PL_compiling, 0);
3022     if (startop) {
3023         *startop = PL_eval_root;
3024     } else
3025         SAVEFREEOP(PL_eval_root);
3026
3027     /* Set the context for this new optree.
3028      * If the last op is an OP_REQUIRE, force scalar context.
3029      * Otherwise, propagate the context from the eval(). */
3030     if (PL_eval_root->op_type == OP_LEAVEEVAL
3031             && cUNOPx(PL_eval_root)->op_first->op_type == OP_LINESEQ
3032             && cLISTOPx(cUNOPx(PL_eval_root)->op_first)->op_last->op_type
3033             == OP_REQUIRE)
3034         scalar(PL_eval_root);
3035     else if ((gimme & G_WANT) == G_VOID)
3036         scalarvoid(PL_eval_root);
3037     else if ((gimme & G_WANT) == G_ARRAY)
3038         list(PL_eval_root);
3039     else
3040         scalar(PL_eval_root);
3041
3042     DEBUG_x(dump_eval());
3043
3044     /* Register with debugger: */
3045     if (PERLDB_INTER && saveop && saveop->op_type == OP_REQUIRE) {
3046         CV * const cv = get_cv("DB::postponed", FALSE);
3047         if (cv) {
3048             dSP;
3049             PUSHMARK(SP);
3050             XPUSHs((SV*)CopFILEGV(&PL_compiling));
3051             PUTBACK;
3052             call_sv((SV*)cv, G_DISCARD);
3053         }
3054     }
3055
3056     if (PL_unitcheckav)
3057         call_list(PL_scopestack_ix, PL_unitcheckav);
3058
3059     /* compiled okay, so do it */
3060
3061     CvDEPTH(PL_compcv) = 1;
3062     SP = PL_stack_base + POPMARK;               /* pop original mark */
3063     PL_op = saveop;                     /* The caller may need it. */
3064     PL_parser->lex_state = LEX_NOTPARSING;      /* $^S needs this. */
3065
3066     PUTBACK;
3067     return TRUE;
3068 }
3069
3070 STATIC PerlIO *
3071 S_check_type_and_open(pTHX_ const char *name)
3072 {
3073     Stat_t st;
3074     const int st_rc = PerlLIO_stat(name, &st);
3075
3076     if (st_rc < 0 || S_ISDIR(st.st_mode) || S_ISBLK(st.st_mode)) {
3077         return NULL;
3078     }
3079
3080     return PerlIO_open(name, PERL_SCRIPT_MODE);
3081 }
3082
3083 #ifndef PERL_DISABLE_PMC
3084 STATIC PerlIO *
3085 S_doopen_pm(pTHX_ const char *name, const STRLEN namelen)
3086 {
3087     PerlIO *fp;
3088
3089     if (namelen > 3 && memEQs(name + namelen - 3, 3, ".pm")) {
3090         SV *const pmcsv = newSV(namelen + 2);
3091         char *const pmc = SvPVX(pmcsv);
3092         Stat_t pmcstat;
3093
3094         memcpy(pmc, name, namelen);
3095         pmc[namelen] = 'c';
3096         pmc[namelen + 1] = '\0';
3097
3098         if (PerlLIO_stat(pmc, &pmcstat) < 0) {
3099             fp = check_type_and_open(name);
3100         }
3101         else {
3102             fp = check_type_and_open(pmc);
3103         }
3104         SvREFCNT_dec(pmcsv);
3105     }
3106     else {
3107         fp = check_type_and_open(name);
3108     }
3109     return fp;
3110 }
3111 #else
3112 #  define doopen_pm(name, namelen) check_type_and_open(name)
3113 #endif /* !PERL_DISABLE_PMC */
3114
3115 PP(pp_require)
3116 {
3117     dVAR; dSP;
3118     register PERL_CONTEXT *cx;
3119     SV *sv;
3120     const char *name;
3121     STRLEN len;
3122     char * unixname;
3123     STRLEN unixlen;
3124 #ifdef VMS
3125     int vms_unixname = 0;
3126 #endif
3127     const char *tryname = NULL;
3128     SV *namesv = NULL;
3129     const I32 gimme = GIMME_V;
3130     int filter_has_file = 0;
3131     PerlIO *tryrsfp = NULL;
3132     SV *filter_cache = NULL;
3133     SV *filter_state = NULL;
3134     SV *filter_sub = NULL;
3135     SV *hook_sv = NULL;
3136     SV *encoding;
3137     OP *op;
3138
3139     sv = POPs;
3140     if ( (SvNIOKp(sv) || SvVOK(sv)) && PL_op->op_type != OP_DOFILE) {
3141         sv = new_version(sv);
3142         if (!sv_derived_from(PL_patchlevel, "version"))
3143             upg_version(PL_patchlevel, TRUE);
3144         if (cUNOP->op_first->op_type == OP_CONST && cUNOP->op_first->op_private & OPpCONST_NOVER) {
3145             if ( vcmp(sv,PL_patchlevel) <= 0 )
3146                 DIE(aTHX_ "Perls since %"SVf" too modern--this is %"SVf", stopped",
3147                     SVfARG(vnormal(sv)), SVfARG(vnormal(PL_patchlevel)));
3148         }
3149         else {
3150             if ( vcmp(sv,PL_patchlevel) > 0 ) {
3151                 I32 first = 0;
3152                 AV *lav;
3153                 SV * const req = SvRV(sv);
3154                 SV * const pv = *hv_fetchs((HV*)req, "original", FALSE);
3155
3156                 /* get the left hand term */
3157                 lav = (AV *)SvRV(*hv_fetchs((HV*)req, "version", FALSE));
3158
3159                 first  = SvIV(*av_fetch(lav,0,0));
3160                 if (   first > (int)PERL_REVISION    /* probably 'use 6.0' */
3161                     || hv_exists((HV*)req, "qv", 2 ) /* qv style */
3162                     || av_len(lav) > 1               /* FP with > 3 digits */
3163                     || strstr(SvPVX(pv),".0")        /* FP with leading 0 */
3164                    ) {
3165                     DIE(aTHX_ "Perl %"SVf" required--this is only "
3166                         "%"SVf", stopped", SVfARG(vnormal(req)),
3167                         SVfARG(vnormal(PL_patchlevel)));
3168                 }
3169                 else { /* probably 'use 5.10' or 'use 5.8' */
3170                     SV * hintsv = newSV(0);
3171                     I32 second = 0;
3172
3173                     if (av_len(lav)>=1)
3174                         second = SvIV(*av_fetch(lav,1,0));
3175
3176                     second /= second >= 600  ? 100 : 10;
3177                     hintsv = Perl_newSVpvf(aTHX_ "v%d.%d.%d",
3178                         (int)first, (int)second,0);
3179                     upg_version(hintsv, TRUE);
3180
3181                     DIE(aTHX_ "Perl %"SVf" required (did you mean %"SVf"?)"
3182                         "--this is only %"SVf", stopped",
3183                         SVfARG(vnormal(req)),
3184                         SVfARG(vnormal(hintsv)),
3185                         SVfARG(vnormal(PL_patchlevel)));
3186                 }
3187             }
3188         }
3189
3190         /* We do this only with use, not require. */
3191         if (PL_compcv &&
3192           /* If we request a version >= 5.9.5, load feature.pm with the
3193            * feature bundle that corresponds to the required version. */
3194                 vcmp(sv, sv_2mortal(upg_version(newSVnv(5.009005), FALSE))) >= 0) {
3195             SV *const importsv = vnormal(sv);
3196             *SvPVX_mutable(importsv) = ':';
3197             ENTER;
3198             Perl_load_module(aTHX_ 0, newSVpvs("feature"), NULL, importsv, NULL);
3199             LEAVE;
3200         }
3201
3202         RETPUSHYES;
3203     }
3204     name = SvPV_const(sv, len);
3205     if (!(name && len > 0 && *name))
3206         DIE(aTHX_ "Null filename used");
3207     TAINT_PROPER("require");
3208
3209
3210 #ifdef VMS
3211     /* The key in the %ENV hash is in the syntax of file passed as the argument
3212      * usually this is in UNIX format, but sometimes in VMS format, which
3213      * can result in a module being pulled in more than once.
3214      * To prevent this, the key must be stored in UNIX format if the VMS
3215      * name can be translated to UNIX.
3216      */
3217     if ((unixname = tounixspec(name, NULL)) != NULL) {
3218         unixlen = strlen(unixname);
3219         vms_unixname = 1;
3220     }
3221     else
3222 #endif
3223     {
3224         /* if not VMS or VMS name can not be translated to UNIX, pass it
3225          * through.
3226          */
3227         unixname = (char *) name;
3228         unixlen = len;
3229     }
3230     if (PL_op->op_type == OP_REQUIRE) {
3231         SV * const * const svp = hv_fetch(GvHVn(PL_incgv),
3232                                           unixname, unixlen, 0);
3233         if ( svp ) {
3234             if (*svp != &PL_sv_undef)
3235                 RETPUSHYES;
3236             else
3237                 DIE(aTHX_ "Attempt to reload %s aborted.\n"
3238                             "Compilation failed in require", unixname);
3239         }
3240     }
3241
3242     /* prepare to compile file */
3243
3244     if (path_is_absolute(name)) {
3245         tryname = name;
3246         tryrsfp = doopen_pm(name, len);
3247     }
3248 #ifdef MACOS_TRADITIONAL
3249     if (!tryrsfp) {
3250         char newname[256];
3251
3252         MacPerl_CanonDir(name, newname, 1);
3253         if (path_is_absolute(newname)) {
3254             tryname = newname;
3255             tryrsfp = doopen_pm(newname, strlen(newname));
3256         }
3257     }
3258 #endif
3259     if (!tryrsfp) {
3260         AV * const ar = GvAVn(PL_incgv);
3261         I32 i;
3262 #ifdef VMS
3263         if (vms_unixname)
3264 #endif
3265         {
3266             namesv = newSV_type(SVt_PV);
3267             for (i = 0; i <= AvFILL(ar); i++) {
3268                 SV * const dirsv = *av_fetch(ar, i, TRUE);
3269
3270                 if (SvTIED_mg((SV*)ar, PERL_MAGIC_tied))
3271                     mg_get(dirsv);
3272                 if (SvROK(dirsv)) {
3273                     int count;
3274                     SV **svp;
3275                     SV *loader = dirsv;
3276
3277                     if (SvTYPE(SvRV(loader)) == SVt_PVAV
3278                         && !sv_isobject(loader))
3279                     {
3280                         loader = *av_fetch((AV *)SvRV(loader), 0, TRUE);
3281                     }
3282
3283                     Perl_sv_setpvf(aTHX_ namesv, "/loader/0x%"UVxf"/%s",
3284                                    PTR2UV(SvRV(dirsv)), name);
3285                     tryname = SvPVX_const(namesv);
3286                     tryrsfp = NULL;
3287
3288                     ENTER;
3289                     SAVETMPS;
3290                     EXTEND(SP, 2);
3291
3292                     PUSHMARK(SP);
3293                     PUSHs(dirsv);
3294                     PUSHs(sv);
3295                     PUTBACK;
3296                     if (sv_isobject(loader))
3297                         count = call_method("INC", G_ARRAY);
3298                     else
3299                         count = call_sv(loader, G_ARRAY);
3300                     SPAGAIN;
3301
3302                     /* Adjust file name if the hook has set an %INC entry */
3303                     svp = hv_fetch(GvHVn(PL_incgv), name, len, 0);
3304                     if (svp)
3305                         tryname = SvPVX_const(*svp);
3306
3307                     if (count > 0) {
3308                         int i = 0;
3309                         SV *arg;
3310
3311                         SP -= count - 1;
3312                         arg = SP[i++];
3313
3314                         if (SvROK(arg) && (SvTYPE(SvRV(arg)) <= SVt_PVLV)
3315                             && !isGV_with_GP(SvRV(arg))) {
3316                             filter_cache = SvRV(arg);
3317                             SvREFCNT_inc_simple_void_NN(filter_cache);
3318
3319                             if (i < count) {
3320                                 arg = SP[i++];
3321                             }
3322                         }
3323
3324                         if (SvROK(arg) && SvTYPE(SvRV(arg)) == SVt_PVGV) {
3325                             arg = SvRV(arg);
3326                         }
3327
3328                         if (SvTYPE(arg) == SVt_PVGV) {
3329                             IO * const io = GvIO((GV *)arg);
3330
3331                             ++filter_has_file;
3332
3333                             if (io) {
3334                                 tryrsfp = IoIFP(io);
3335                                 if (IoOFP(io) && IoOFP(io) != IoIFP(io)) {
3336                                     PerlIO_close(IoOFP(io));
3337                                 }
3338                                 IoIFP(io) = NULL;
3339                                 IoOFP(io) = NULL;
3340                             }
3341
3342                             if (i < count) {
3343                                 arg = SP[i++];
3344                             }
3345                         }
3346
3347                         if (SvROK(arg) && SvTYPE(SvRV(arg)) == SVt_PVCV) {
3348                             filter_sub = arg;
3349                             SvREFCNT_inc_simple_void_NN(filter_sub);
3350
3351                             if (i < count) {
3352                                 filter_state = SP[i];
3353                                 SvREFCNT_inc_simple_void(filter_state);
3354                             }
3355                         }
3356
3357                         if (!tryrsfp && (filter_cache || filter_sub)) {
3358                             tryrsfp = PerlIO_open(BIT_BUCKET,
3359                                                   PERL_SCRIPT_MODE);
3360                         }
3361                         SP--;
3362                     }
3363
3364                     PUTBACK;
3365                     FREETMPS;
3366                     LEAVE;
3367
3368                     if (tryrsfp) {
3369                         hook_sv = dirsv;
3370                         break;
3371                     }
3372
3373                     filter_has_file = 0;
3374                     if (filter_cache) {
3375                         SvREFCNT_dec(filter_cache);
3376                         filter_cache = NULL;
3377                     }
3378                     if (filter_state) {
3379                         SvREFCNT_dec(filter_state);
3380                         filter_state = NULL;
3381                     }
3382                     if (filter_sub) {
3383                         SvREFCNT_dec(filter_sub);
3384                         filter_sub = NULL;
3385                     }
3386                 }
3387                 else {
3388                   if (!path_is_absolute(name)
3389 #ifdef MACOS_TRADITIONAL
3390                         /* We consider paths of the form :a:b ambiguous and interpret them first
3391                            as global then as local
3392                         */
3393                         || (*name == ':' && name[1] != ':' && strchr(name+2, ':'))
3394 #endif
3395                   ) {
3396                     const char *dir;
3397                     STRLEN dirlen;
3398
3399                     if (SvOK(dirsv)) {
3400                         dir = SvPV_const(dirsv, dirlen);
3401                     } else {
3402                         dir = "";
3403                         dirlen = 0;
3404                     }
3405
3406 #ifdef MACOS_TRADITIONAL
3407                     char buf1[256];
3408                     char buf2[256];
3409
3410                     MacPerl_CanonDir(name, buf2, 1);
3411                     Perl_sv_setpvf(aTHX_ namesv, "%s%s", MacPerl_CanonDir(dir, buf1, 0), buf2+(buf2[0] == ':'));
3412 #else
3413 #  ifdef VMS
3414                     char *unixdir;
3415                     if ((unixdir = tounixpath(dir, NULL)) == NULL)
3416                         continue;
3417                     sv_setpv(namesv, unixdir);
3418                     sv_catpv(namesv, unixname);
3419 #  else
3420 #    ifdef __SYMBIAN32__
3421                     if (PL_origfilename[0] &&
3422                         PL_origfilename[1] == ':' &&
3423                         !(dir[0] && dir[1] == ':'))
3424                         Perl_sv_setpvf(aTHX_ namesv,
3425                                        "%c:%s\\%s",
3426                                        PL_origfilename[0],
3427                                        dir, name);
3428                     else
3429                         Perl_sv_setpvf(aTHX_ namesv,
3430                                        "%s\\%s",
3431                                        dir, name);
3432 #    else
3433                     /* The equivalent of
3434                        Perl_sv_setpvf(aTHX_ namesv, "%s/%s", dir, name);
3435                        but without the need to parse the format string, or
3436                        call strlen on either pointer, and with the correct
3437                        allocation up front.  */
3438                     {
3439                         char *tmp = SvGROW(namesv, dirlen + len + 2);
3440
3441                         memcpy(tmp, dir, dirlen);
3442                         tmp +=dirlen;
3443                         *tmp++ = '/';
3444                         /* name came from an SV, so it will have a '\0' at the
3445                            end that we can copy as part of this memcpy().  */
3446                         memcpy(tmp, name, len + 1);
3447
3448                         SvCUR_set(namesv, dirlen + len + 1);
3449
3450                         /* Don't even actually have to turn SvPOK_on() as we
3451                            access it directly with SvPVX() below.  */
3452                     }
3453 #    endif
3454 #  endif
3455 #endif
3456                     TAINT_PROPER("require");
3457                     tryname = SvPVX_const(namesv);
3458                     tryrsfp = doopen_pm(tryname, SvCUR(namesv));
3459                     if (tryrsfp) {
3460                         if (tryname[0] == '.' && tryname[1] == '/')
3461                             tryname += 2;
3462                         break;
3463                     }
3464                     else if (errno == EMFILE)
3465                         /* no point in trying other paths if out of handles */
3466                         break;
3467                   }
3468                 }
3469             }
3470         }
3471     }
3472     SAVECOPFILE_FREE(&PL_compiling);
3473     CopFILE_set(&PL_compiling, tryrsfp ? tryname : name);
3474     SvREFCNT_dec(namesv);
3475     if (!tryrsfp) {
3476         if (PL_op->op_type == OP_REQUIRE) {
3477             const char *msgstr = name;
3478             if(errno == EMFILE) {
3479                 SV * const msg
3480                     = sv_2mortal(Perl_newSVpvf(aTHX_ "%s:   %s", msgstr,
3481                                                Strerror(errno)));
3482                 msgstr = SvPV_nolen_const(msg);
3483             } else {
3484                 if (namesv) {                   /* did we lookup @INC? */
3485                     AV * const ar = GvAVn(PL_incgv);
3486                     I32 i;
3487                     SV * const msg = sv_2mortal(Perl_newSVpvf(aTHX_
3488                         "%s in @INC%s%s (@INC contains:",
3489                         msgstr,
3490                         (instr(msgstr, ".h ")
3491                          ? " (change .h to .ph maybe?)" : ""),
3492                         (instr(msgstr, ".ph ")
3493                          ? " (did you run h2ph?)" : "")
3494                                                               ));
3495
3496                     for (i = 0; i <= AvFILL(ar); i++) {
3497                         sv_catpvs(msg, " ");
3498                         sv_catsv(msg, *av_fetch(ar, i, TRUE));
3499                     }
3500                     sv_catpvs(msg, ")");
3501                     msgstr = SvPV_nolen_const(msg);
3502                 }
3503             }
3504             DIE(aTHX_ "Can't locate %s", msgstr);
3505         }
3506
3507         RETPUSHUNDEF;
3508     }
3509     else
3510         SETERRNO(0, SS_NORMAL);
3511
3512     /* Assume success here to prevent recursive requirement. */
3513     /* name is never assigned to again, so len is still strlen(name)  */
3514     /* Check whether a hook in @INC has already filled %INC */
3515     if (!hook_sv) {
3516         (void)hv_store(GvHVn(PL_incgv),
3517                        unixname, unixlen, newSVpv(CopFILE(&PL_compiling),0),0);
3518     } else {
3519         SV** const svp = hv_fetch(GvHVn(PL_incgv), unixname, unixlen, 0);
3520         if (!svp)
3521             (void)hv_store(GvHVn(PL_incgv),
3522                            unixname, unixlen, SvREFCNT_inc_simple(hook_sv), 0 );
3523     }
3524
3525     ENTER;
3526     SAVETMPS;
3527     lex_start(NULL, tryrsfp, TRUE);
3528
3529     SAVEHINTS();
3530     PL_hints = 0;
3531     SAVECOMPILEWARNINGS();
3532     if (PL_dowarn & G_WARN_ALL_ON)
3533         PL_compiling.cop_warnings = pWARN_ALL ;
3534     else if (PL_dowarn & G_WARN_ALL_OFF)
3535         PL_compiling.cop_warnings = pWARN_NONE ;
3536     else
3537         PL_compiling.cop_warnings = pWARN_STD ;
3538
3539     if (filter_sub || filter_cache) {
3540         SV * const datasv = filter_add(S_run_user_filter, NULL);
3541         IoLINES(datasv) = filter_has_file;
3542         IoTOP_GV(datasv) = (GV *)filter_state;
3543         IoBOTTOM_GV(datasv) = (GV *)filter_sub;
3544         IoFMT_GV(datasv) = (GV *)filter_cache;
3545     }
3546
3547     /* switch to eval mode */
3548     PUSHBLOCK(cx, CXt_EVAL, SP);
3549     PUSHEVAL(cx, name, NULL);
3550     cx->blk_eval.retop = PL_op->op_next;
3551
3552     SAVECOPLINE(&PL_compiling);
3553     CopLINE_set(&PL_compiling, 0);
3554
3555     PUTBACK;
3556
3557     /* Store and reset encoding. */
3558     encoding = PL_encoding;
3559     PL_encoding = NULL;
3560
3561     if (doeval(gimme, NULL, NULL, PL_curcop->cop_seq))
3562         op = DOCATCH(PL_eval_start);
3563     else
3564         op = PL_op->op_next;
3565
3566     /* Restore encoding. */
3567     PL_encoding = encoding;
3568
3569     return op;
3570 }
3571
3572 PP(pp_entereval)
3573 {
3574     dVAR; dSP;
3575     register PERL_CONTEXT *cx;
3576     SV *sv;
3577     const I32 gimme = GIMME_V;
3578     const I32 was = PL_sub_generation;
3579     char tbuf[TYPE_DIGITS(long) + 12];
3580     char *tmpbuf = tbuf;
3581     char *safestr;
3582     STRLEN len;
3583     bool ok;
3584     CV* runcv;
3585     U32 seq;
3586     HV *saved_hh = NULL;
3587     const char * const fakestr = "_<(eval )";
3588     const int fakelen = 9 + 1;
3589
3590     if (PL_op->op_private & OPpEVAL_HAS_HH) {
3591         saved_hh = (HV*) SvREFCNT_inc(POPs);
3592     }
3593     sv = POPs;
3594
3595     TAINT_IF(SvTAINTED(sv));
3596     TAINT_PROPER("eval");
3597
3598     ENTER;
3599     lex_start(sv, NULL, FALSE);
3600     SAVETMPS;
3601
3602     /* switch to eval mode */
3603
3604     if (PERLDB_NAMEEVAL && CopLINE(PL_curcop)) {
3605         SV * const temp_sv = sv_newmortal();
3606         Perl_sv_setpvf(aTHX_ temp_sv, "_<(eval %lu)[%s:%"IVdf"]",
3607                        (unsigned long)++PL_evalseq,
3608                        CopFILE(PL_curcop), (IV)CopLINE(PL_curcop));
3609         tmpbuf = SvPVX(temp_sv);
3610         len = SvCUR(temp_sv);
3611     }
3612     else
3613         len = my_snprintf(tmpbuf, sizeof(tbuf), "_<(eval %lu)", (unsigned long)++PL_evalseq);
3614     SAVECOPFILE_FREE(&PL_compiling);
3615     CopFILE_set(&PL_compiling, tmpbuf+2);
3616     SAVECOPLINE(&PL_compiling);
3617     CopLINE_set(&PL_compiling, 1);
3618     /* XXX For C<eval "...">s within BEGIN {} blocks, this ends up
3619        deleting the eval's FILEGV from the stash before gv_check() runs
3620        (i.e. before run-time proper). To work around the coredump that
3621        ensues, we always turn GvMULTI_on for any globals that were
3622        introduced within evals. See force_ident(). GSAR 96-10-12 */
3623     safestr = savepvn(tmpbuf, len);
3624     SAVEDELETE(PL_defstash, safestr, len);
3625     SAVEHINTS();
3626     PL_hints = PL_op->op_targ;
3627     if (saved_hh)
3628         GvHV(PL_hintgv) = saved_hh;
3629     SAVECOMPILEWARNINGS();
3630     PL_compiling.cop_warnings = DUP_WARNINGS(PL_curcop->cop_warnings);
3631     if (PL_compiling.cop_hints_hash) {
3632         Perl_refcounted_he_free(aTHX_ PL_compiling.cop_hints_hash);
3633     }
3634     PL_compiling.cop_hints_hash = PL_curcop->cop_hints_hash;
3635     if (PL_compiling.cop_hints_hash) {
3636         HINTS_REFCNT_LOCK;
3637         PL_compiling.cop_hints_hash->refcounted_he_refcnt++;
3638         HINTS_REFCNT_UNLOCK;
3639     }
3640     /* special case: an eval '' executed within the DB package gets lexically
3641      * placed in the first non-DB CV rather than the current CV - this
3642      * allows the debugger to execute code, find lexicals etc, in the
3643      * scope of the code being debugged. Passing &seq gets find_runcv
3644      * to do the dirty work for us */
3645     runcv = find_runcv(&seq);
3646
3647     PUSHBLOCK(cx, (CXt_EVAL|CXp_REAL), SP);
3648     PUSHEVAL(cx, 0, NULL);
3649     cx->blk_eval.retop = PL_op->op_next;
3650
3651     /* prepare to compile string */
3652
3653     if (PERLDB_LINE && PL_curstash != PL_debstash)
3654         save_lines(CopFILEAV(&PL_compiling), PL_parser->linestr);
3655     PUTBACK;
3656     ok = doeval(gimme, NULL, runcv, seq);
3657     if (PERLDB_INTER && was != (I32)PL_sub_generation /* Some subs defined here. */
3658         && ok) {
3659         /* Copy in anything fake and short. */
3660         my_strlcpy(safestr, fakestr, fakelen);
3661     }
3662     return ok ? DOCATCH(PL_eval_start) : PL_op->op_next;
3663 }
3664
3665 PP(pp_leaveeval)
3666 {
3667     dVAR; dSP;
3668     register SV **mark;
3669     SV **newsp;
3670     PMOP *newpm;
3671     I32 gimme;
3672     register PERL_CONTEXT *cx;
3673     OP *retop;
3674     const U8 save_flags = PL_op -> op_flags;
3675     I32 optype;
3676
3677     POPBLOCK(cx,newpm);
3678     POPEVAL(cx);
3679     retop = cx->blk_eval.retop;
3680
3681     TAINT_NOT;
3682     if (gimme == G_VOID)
3683         MARK = newsp;
3684     else if (gimme == G_SCALAR) {
3685         MARK = newsp + 1;
3686         if (MARK <= SP) {
3687             if (SvFLAGS(TOPs) & SVs_TEMP)
3688                 *MARK = TOPs;
3689             else
3690                 *MARK = sv_mortalcopy(TOPs);
3691         }
3692         else {
3693             MEXTEND(mark,0);
3694             *MARK = &PL_sv_undef;
3695         }
3696         SP = MARK;
3697     }
3698     else {
3699         /* in case LEAVE wipes old return values */
3700         for (mark = newsp + 1; mark <= SP; mark++) {
3701             if (!(SvFLAGS(*mark) & SVs_TEMP)) {
3702                 *mark = sv_mortalcopy(*mark);
3703                 TAINT_NOT;      /* Each item is independent */
3704             }
3705         }
3706     }
3707     PL_curpm = newpm;   /* Don't pop $1 et al till now */
3708
3709 #ifdef DEBUGGING
3710     assert(CvDEPTH(PL_compcv) == 1);
3711 #endif
3712     CvDEPTH(PL_compcv) = 0;
3713     lex_end();
3714
3715     if (optype == OP_REQUIRE &&
3716         !(gimme == G_SCALAR ? SvTRUE(*SP) : SP > newsp))
3717     {
3718         /* Unassume the success we assumed earlier. */
3719         SV * const nsv = cx->blk_eval.old_namesv;
3720         (void)hv_delete(GvHVn(PL_incgv), SvPVX_const(nsv), SvCUR(nsv), G_DISCARD);
3721         retop = Perl_die(aTHX_ "%"SVf" did not return a true value", SVfARG(nsv));
3722         /* die_where() did LEAVE, or we won't be here */
3723     }
3724     else {
3725         LEAVE;
3726         if (!(save_flags & OPf_SPECIAL))
3727             sv_setpvn(ERRSV,"",0);
3728     }
3729
3730     RETURNOP(retop);
3731 }
3732
3733 /* Common code for Perl_call_sv and Perl_fold_constants, put here to keep it
3734    close to the related Perl_create_eval_scope.  */
3735 void
3736 Perl_delete_eval_scope(pTHX)
3737 {
3738     SV **newsp;
3739     PMOP *newpm;
3740     I32 gimme;
3741     register PERL_CONTEXT *cx;
3742     I32 optype;
3743
3744     POPBLOCK(cx,newpm);
3745     POPEVAL(cx);
3746     PL_curpm = newpm;
3747     LEAVE;
3748     PERL_UNUSED_VAR(newsp);
3749     PERL_UNUSED_VAR(gimme);
3750     PERL_UNUSED_VAR(optype);
3751 }
3752
3753 /* Common-ish code salvaged from Perl_call_sv and pp_entertry, because it was
3754    also needed by Perl_fold_constants.  */
3755 PERL_CONTEXT *
3756 Perl_create_eval_scope(pTHX_ U32 flags)
3757 {
3758     PERL_CONTEXT *cx;
3759     const I32 gimme = GIMME_V;
3760
3761     ENTER;
3762     SAVETMPS;
3763
3764     PUSHBLOCK(cx, (CXt_EVAL|CXp_TRYBLOCK), PL_stack_sp);
3765     PUSHEVAL(cx, 0, 0);
3766
3767     PL_in_eval = EVAL_INEVAL;
3768     if (flags & G_KEEPERR)
3769         PL_in_eval |= EVAL_KEEPERR;
3770     else
3771         sv_setpvn(ERRSV,"",0);
3772     if (flags & G_FAKINGEVAL) {
3773         PL_eval_root = PL_op; /* Only needed so that goto works right. */
3774     }
3775     return cx;
3776 }
3777
3778 PP(pp_entertry)
3779 {
3780     dVAR;
3781     PERL_CONTEXT * const cx = create_eval_scope(0);
3782     cx->blk_eval.retop = cLOGOP->op_other->op_next;
3783     return DOCATCH(PL_op->op_next);
3784 }
3785
3786 PP(pp_leavetry)
3787 {
3788     dVAR; dSP;
3789     SV **newsp;
3790     PMOP *newpm;
3791     I32 gimme;
3792     register PERL_CONTEXT *cx;
3793     I32 optype;
3794
3795     POPBLOCK(cx,newpm);
3796     POPEVAL(cx);
3797     PERL_UNUSED_VAR(optype);
3798
3799     TAINT_NOT;
3800     if (gimme == G_VOID)
3801         SP = newsp;
3802     else if (gimme == G_SCALAR) {
3803         register SV **mark;
3804         MARK = newsp + 1;
3805         if (MARK <= SP) {
3806             if (SvFLAGS(TOPs) & (SVs_PADTMP|SVs_TEMP))
3807                 *MARK = TOPs;
3808             else
3809                 *MARK = sv_mortalcopy(TOPs);
3810         }
3811         else {
3812             MEXTEND(mark,0);
3813             *MARK = &PL_sv_undef;
3814         }
3815         SP = MARK;
3816     }
3817     else {
3818         /* in case LEAVE wipes old return values */
3819         register SV **mark;
3820         for (mark = newsp + 1; mark <= SP; mark++) {
3821             if (!(SvFLAGS(*mark) & (SVs_PADTMP|SVs_TEMP))) {
3822                 *mark = sv_mortalcopy(*mark);
3823                 TAINT_NOT;      /* Each item is independent */
3824             }
3825         }
3826     }
3827     PL_curpm = newpm;   /* Don't pop $1 et al till now */
3828
3829     LEAVE;
3830     sv_setpvn(ERRSV,"",0);
3831     RETURN;
3832 }
3833
3834 PP(pp_entergiven)
3835 {
3836     dVAR; dSP;
3837     register PERL_CONTEXT *cx;
3838     const I32 gimme = GIMME_V;
3839
3840     ENTER;
3841     SAVETMPS;
3842
3843     if (PL_op->op_targ == 0) {
3844         SV ** const defsv_p = &GvSV(PL_defgv);
3845         *defsv_p = newSVsv(POPs);
3846         SAVECLEARSV(*defsv_p);
3847     }
3848     else
3849         sv_setsv(PAD_SV(PL_op->op_targ), POPs);
3850
3851     PUSHBLOCK(cx, CXt_GIVEN, SP);
3852     PUSHGIVEN(cx);
3853
3854     RETURN;
3855 }
3856
3857 PP(pp_leavegiven)
3858 {
3859     dVAR; dSP;
3860     register PERL_CONTEXT *cx;
3861     I32 gimme;
3862     SV **newsp;
3863     PMOP *newpm;
3864     PERL_UNUSED_CONTEXT;
3865
3866     POPBLOCK(cx,newpm);
3867     assert(CxTYPE(cx) == CXt_GIVEN);
3868
3869     SP = newsp;
3870     PUTBACK;
3871
3872     PL_curpm = newpm;   /* pop $1 et al */
3873
3874     LEAVE;
3875
3876     return NORMAL;
3877 }
3878
3879 /* Helper routines used by pp_smartmatch */
3880 STATIC PMOP *
3881 S_make_matcher(pTHX_ REGEXP *re)
3882 {
3883     dVAR;
3884     PMOP *matcher = (PMOP *) newPMOP(OP_MATCH, OPf_WANT_SCALAR | OPf_STACKED);
3885     PM_SETRE(matcher, ReREFCNT_inc(re));
3886
3887     SAVEFREEOP((OP *) matcher);
3888     ENTER; SAVETMPS;
3889     SAVEOP();
3890     return matcher;
3891 }
3892
3893 STATIC bool
3894 S_matcher_matches_sv(pTHX_ PMOP *matcher, SV *sv)
3895 {
3896     dVAR;
3897     dSP;
3898
3899     PL_op = (OP *) matcher;
3900     XPUSHs(sv);
3901     PUTBACK;
3902     (void) pp_match();
3903     SPAGAIN;
3904     return (SvTRUEx(POPs));
3905 }
3906
3907 STATIC void
3908 S_destroy_matcher(pTHX_ PMOP *matcher)
3909 {
3910     dVAR;
3911     PERL_UNUSED_ARG(matcher);
3912     FREETMPS;
3913     LEAVE;
3914 }
3915
3916 /* Do a smart match */
3917 PP(pp_smartmatch)
3918 {
3919     return do_smartmatch(NULL, NULL);
3920 }
3921
3922 /* This version of do_smartmatch() implements the
3923  * table of smart matches that is found in perlsyn.
3924  */
3925 STATIC OP *
3926 S_do_smartmatch(pTHX_ HV *seen_this, HV *seen_other)
3927 {
3928     dVAR;
3929     dSP;
3930
3931     SV *e = TOPs;       /* e is for 'expression' */
3932     SV *d = TOPm1s;     /* d is for 'default', as in PL_defgv */
3933     SV *This, *Other;   /* 'This' (and Other to match) to play with C++ */
3934     REGEXP *this_regex, *other_regex;
3935
3936 #   define NOT_EMPTY_PROTO(cv) (!SvPOK(cv) || SvCUR(cv) == 0)
3937
3938 #   define SM_REF(type) ( \
3939            (SvROK(d) && (SvTYPE(This = SvRV(d)) == SVt_##type) && (Other = e)) \
3940         || (SvROK(e) && (SvTYPE(This = SvRV(e)) == SVt_##type) && (Other = d)))
3941
3942 #   define SM_CV_NEP   /* Find a code ref without an empty prototype */ \
3943         ((SvROK(d) && (SvTYPE(This = SvRV(d)) == SVt_PVCV)              \
3944             && NOT_EMPTY_PROTO(This) && (Other = e))                    \
3945         || (SvROK(e) && (SvTYPE(This = SvRV(e)) == SVt_PVCV)            \
3946             && NOT_EMPTY_PROTO(This) && (Other = d)))
3947
3948 #   define SM_REGEX ( \
3949            (SvROK(d) && (SvTYPE(This = SvRV(d)) == SVt_REGEXP)          \
3950         && (this_regex = (REGEXP*) This)                                \
3951         && (Other = e))                                                 \
3952     ||                                                                  \
3953            (SvROK(e) && (SvTYPE(This = SvRV(e)) == SVt_REGEXP)          \
3954         && (this_regex = (REGEXP*) This)                                \
3955         && (Other = d)) )
3956
3957
3958 #   define SM_OTHER_REF(type) \
3959         (SvROK(Other) && SvTYPE(SvRV(Other)) == SVt_##type)
3960
3961 #   define SM_OTHER_REGEX (SvROK(Other)                                 \
3962         && (SvTYPE(SvRV(Other)) == SVt_REGEXP)                          \
3963         && (other_regex = (REGEXP*) SvRV(Other)))
3964
3965
3966 #   define SM_SEEN_THIS(sv) hv_exists_ent(seen_this, \
3967         sv_2mortal(newSViv(PTR2IV(sv))), 0)
3968
3969 #   define SM_SEEN_OTHER(sv) hv_exists_ent(seen_other, \
3970         sv_2mortal(newSViv(PTR2IV(sv))), 0)
3971
3972     tryAMAGICbinSET(smart, 0);
3973
3974     SP -= 2;    /* Pop the values */
3975
3976     /* Take care only to invoke mg_get() once for each argument.
3977      * Currently we do this by copying the SV if it's magical. */
3978     if (d) {
3979         if (SvGMAGICAL(d))
3980             d = sv_mortalcopy(d);
3981     }
3982     else
3983         d = &PL_sv_undef;
3984
3985     assert(e);
3986     if (SvGMAGICAL(e))
3987         e = sv_mortalcopy(e);
3988
3989     if (SM_CV_NEP) {
3990         I32 c;
3991
3992         if ( SM_OTHER_REF(PVCV) && NOT_EMPTY_PROTO(SvRV(Other)) )
3993         {
3994             if (This == SvRV(Other))
3995                 RETPUSHYES;
3996             else
3997                 RETPUSHNO;
3998         }
3999
4000         ENTER;
4001         SAVETMPS;
4002         PUSHMARK(SP);
4003         PUSHs(Other);
4004         PUTBACK;
4005         c = call_sv(This, G_SCALAR);
4006         SPAGAIN;
4007         if (c == 0)
4008             PUSHs(&PL_sv_no);
4009         else if (SvTEMP(TOPs))
4010             SvREFCNT_inc_void(TOPs);
4011         FREETMPS;
4012         LEAVE;
4013         RETURN;
4014     }
4015     else if (SM_REF(PVHV)) {
4016         if (SM_OTHER_REF(PVHV)) {
4017             /* Check that the key-sets are identical */
4018             HE *he;
4019             HV *other_hv = (HV *) SvRV(Other);
4020             bool tied = FALSE;
4021             bool other_tied = FALSE;
4022             U32 this_key_count  = 0,
4023                 other_key_count = 0;
4024
4025             /* Tied hashes don't know how many keys they have. */
4026             if (SvTIED_mg(This, PERL_MAGIC_tied)) {
4027                 tied = TRUE;
4028             }
4029             else if (SvTIED_mg((SV *) other_hv, PERL_MAGIC_tied)) {
4030                 HV * const temp = other_hv;
4031                 other_hv = (HV *) This;
4032                 This  = (SV *) temp;
4033                 tied = TRUE;
4034             }
4035             if (SvTIED_mg((SV *) other_hv, PERL_MAGIC_tied))
4036                 other_tied = TRUE;
4037
4038             if (!tied && HvUSEDKEYS((HV *) This) != HvUSEDKEYS(other_hv))
4039                 RETPUSHNO;
4040
4041             /* The hashes have the same number of keys, so it suffices
4042                to check that one is a subset of the other. */
4043             (void) hv_iterinit((HV *) This);
4044             while ( (he = hv_iternext((HV *) This)) ) {
4045                 I32 key_len;
4046                 char * const key = hv_iterkey(he, &key_len);
4047
4048                 ++ this_key_count;
4049
4050                 if(!hv_exists(other_hv, key, key_len)) {
4051                     (void) hv_iterinit((HV *) This);    /* reset iterator */
4052                     RETPUSHNO;
4053                 }
4054             }
4055
4056             if (other_tied) {
4057                 (void) hv_iterinit(other_hv);
4058                 while ( hv_iternext(other_hv) )
4059                     ++other_key_count;
4060             }
4061             else
4062                 other_key_count = HvUSEDKEYS(other_hv);
4063
4064             if (this_key_count != other_key_count)
4065                 RETPUSHNO;
4066             else
4067                 RETPUSHYES;
4068         }
4069         else if (SM_OTHER_REF(PVAV)) {
4070             AV * const other_av = (AV *) SvRV(Other);
4071             const I32 other_len = av_len(other_av) + 1;
4072             I32 i;
4073
4074             for (i = 0; i < other_len; ++i) {
4075                 SV ** const svp = av_fetch(other_av, i, FALSE);
4076                 char *key;
4077                 STRLEN key_len;
4078
4079                 if (svp) {      /* ??? When can this not happen? */
4080                     key = SvPV(*svp, key_len);
4081                     if (hv_exists((HV *) This, key, key_len))
4082                         RETPUSHYES;
4083                 }
4084             }
4085             RETPUSHNO;
4086         }
4087         else if (SM_OTHER_REGEX) {
4088             PMOP * const matcher = make_matcher(other_regex);
4089             HE *he;
4090
4091             (void) hv_iterinit((HV *) This);
4092             while ( (he = hv_iternext((HV *) This)) ) {
4093                 if (matcher_matches_sv(matcher, hv_iterkeysv(he))) {
4094                     (void) hv_iterinit((HV *) This);
4095                     destroy_matcher(matcher);
4096                     RETPUSHYES;
4097                 }
4098             }
4099             destroy_matcher(matcher);
4100             RETPUSHNO;
4101         }
4102         else {
4103             if (hv_exists_ent((HV *) This, Other, 0))
4104                 RETPUSHYES;
4105             else
4106                 RETPUSHNO;
4107         }
4108     }
4109     else if (SM_REF(PVAV)) {
4110         if (SM_OTHER_REF(PVAV)) {
4111             AV *other_av = (AV *) SvRV(Other);
4112             if (av_len((AV *) This) != av_len(other_av))
4113                 RETPUSHNO;
4114             else {
4115                 I32 i;
4116                 const I32 other_len = av_len(other_av);
4117
4118                 if (NULL == seen_this) {
4119                     seen_this = newHV();
4120                     (void) sv_2mortal((SV *) seen_this);
4121                 }
4122                 if (NULL == seen_other) {
4123                     seen_this = newHV();
4124                     (void) sv_2mortal((SV *) seen_other);
4125                 }
4126                 for(i = 0; i <= other_len; ++i) {
4127                     SV * const * const this_elem = av_fetch((AV *)This, i, FALSE);
4128                     SV * const * const other_elem = av_fetch(other_av, i, FALSE);
4129
4130                     if (!this_elem || !other_elem) {
4131                         if (this_elem || other_elem)
4132                             RETPUSHNO;
4133                     }
4134                     else if (SM_SEEN_THIS(*this_elem)
4135                          || SM_SEEN_OTHER(*other_elem))
4136                     {
4137                         if (*this_elem != *other_elem)
4138                             RETPUSHNO;
4139                     }
4140                     else {
4141                         (void)hv_store_ent(seen_this,
4142                                 sv_2mortal(newSViv(PTR2IV(*this_elem))),
4143                                 &PL_sv_undef, 0);
4144                         (void)hv_store_ent(seen_other,
4145                                 sv_2mortal(newSViv(PTR2IV(*other_elem))),
4146                                 &PL_sv_undef, 0);
4147                         PUSHs(*this_elem);
4148                         PUSHs(*other_elem);
4149
4150                         PUTBACK;
4151                         (void) do_smartmatch(seen_this, seen_other);
4152                         SPAGAIN;
4153
4154                         if (!SvTRUEx(POPs))
4155                             RETPUSHNO;
4156                     }
4157                 }
4158                 RETPUSHYES;
4159             }
4160         }
4161         else if (SM_OTHER_REGEX) {
4162             PMOP * const matcher = make_matcher(other_regex);
4163             const I32 this_len = av_len((AV *) This);
4164             I32 i;
4165
4166             for(i = 0; i <= this_len; ++i) {
4167                 SV * const * const svp = av_fetch((AV *)This, i, FALSE);
4168                 if (svp && matcher_matches_sv(matcher, *svp)) {
4169                     destroy_matcher(matcher);
4170                     RETPUSHYES;
4171                 }
4172             }
4173             destroy_matcher(matcher);
4174             RETPUSHNO;
4175         }
4176         else if (SvIOK(Other) || SvNOK(Other)) {
4177             I32 i;
4178
4179             for(i = 0; i <= AvFILL((AV *) This); ++i) {
4180                 SV * const * const svp = av_fetch((AV *)This, i, FALSE);
4181                 if (!svp)
4182                     continue;
4183
4184                 PUSHs(Other);
4185                 PUSHs(*svp);
4186                 PUTBACK;
4187                 if (CopHINTS_get(PL_curcop) & HINT_INTEGER)
4188                     (void) pp_i_eq();
4189                 else
4190                     (void) pp_eq();
4191                 SPAGAIN;
4192                 if (SvTRUEx(POPs))
4193                     RETPUSHYES;
4194             }
4195             RETPUSHNO;
4196         }
4197         else if (SvPOK(Other)) {
4198             const I32 this_len = av_len((AV *) This);
4199             I32 i;
4200
4201             for(i = 0; i <= this_len; ++i) {
4202                 SV * const * const svp = av_fetch((AV *)This, i, FALSE);
4203                 if (!svp)
4204                     continue;
4205
4206                 PUSHs(Other);
4207                 PUSHs(*svp);
4208                 PUTBACK;
4209                 (void) pp_seq();
4210                 SPAGAIN;
4211                 if (SvTRUEx(POPs))
4212                     RETPUSHYES;
4213             }
4214             RETPUSHNO;
4215         }
4216     }
4217     else if (!SvOK(d) || !SvOK(e)) {
4218         if (!SvOK(d) && !SvOK(e))
4219             RETPUSHYES;
4220         else
4221             RETPUSHNO;
4222     }
4223     else if (SM_REGEX) {
4224         PMOP * const matcher = make_matcher(this_regex);
4225
4226         PUTBACK;
4227         PUSHs(matcher_matches_sv(matcher, Other)
4228             ? &PL_sv_yes
4229             : &PL_sv_no);
4230         destroy_matcher(matcher);
4231         RETURN;
4232     }
4233     else if (SM_REF(PVCV)) {
4234         I32 c;
4235         /* This must be a null-prototyped sub, because we
4236            already checked for the other kind. */
4237
4238         ENTER;
4239         SAVETMPS;
4240         PUSHMARK(SP);
4241         PUTBACK;
4242         c = call_sv(This, G_SCALAR);
4243         SPAGAIN;
4244         if (c == 0)
4245             PUSHs(&PL_sv_undef);
4246         else if (SvTEMP(TOPs))
4247             SvREFCNT_inc_void(TOPs);
4248
4249         if (SM_OTHER_REF(PVCV)) {
4250             /* This one has to be null-proto'd too.
4251                Call both of 'em, and compare the results */
4252             PUSHMARK(SP);
4253             c = call_sv(SvRV(Other), G_SCALAR);
4254             SPAGAIN;
4255             if (c == 0)
4256                 PUSHs(&PL_sv_undef);
4257             else if (SvTEMP(TOPs))
4258                 SvREFCNT_inc_void(TOPs);
4259             FREETMPS;
4260             LEAVE;
4261             PUTBACK;
4262             return pp_eq();
4263         }
4264
4265         FREETMPS;
4266         LEAVE;
4267         RETURN;
4268     }
4269     else if ( ((SvIOK(d) || SvNOK(d)) && (This = d) && (Other = e))
4270          ||   ((SvIOK(e) || SvNOK(e)) && (This = e) && (Other = d)) )
4271     {
4272         if (SvPOK(Other) && !looks_like_number(Other)) {
4273             /* String comparison */
4274             PUSHs(d); PUSHs(e);
4275             PUTBACK;
4276             return pp_seq();
4277         }
4278         /* Otherwise, numeric comparison */
4279         PUSHs(d); PUSHs(e);
4280         PUTBACK;
4281         if (CopHINTS_get(PL_curcop) & HINT_INTEGER)
4282             (void) pp_i_eq();
4283         else
4284             (void) pp_eq();
4285         SPAGAIN;
4286         if (SvTRUEx(POPs))
4287             RETPUSHYES;
4288         else
4289             RETPUSHNO;
4290     }
4291
4292     /* As a last resort, use string comparison */
4293     PUSHs(d); PUSHs(e);
4294     PUTBACK;
4295     return pp_seq();
4296 }
4297
4298 PP(pp_enterwhen)
4299 {
4300     dVAR; dSP;
4301     register PERL_CONTEXT *cx;
4302     const I32 gimme = GIMME_V;
4303
4304     /* This is essentially an optimization: if the match
4305        fails, we don't want to push a context and then
4306        pop it again right away, so we skip straight
4307        to the op that follows the leavewhen.
4308     */
4309     if ((0 == (PL_op->op_flags & OPf_SPECIAL)) && !SvTRUEx(POPs))
4310         return cLOGOP->op_other->op_next;
4311
4312     ENTER;
4313     SAVETMPS;
4314
4315     PUSHBLOCK(cx, CXt_WHEN, SP);
4316     PUSHWHEN(cx);
4317
4318     RETURN;
4319 }
4320
4321 PP(pp_leavewhen)
4322 {
4323     dVAR; dSP;
4324     register PERL_CONTEXT *cx;
4325     I32 gimme;
4326     SV **newsp;
4327     PMOP *newpm;
4328
4329     POPBLOCK(cx,newpm);
4330     assert(CxTYPE(cx) == CXt_WHEN);
4331
4332     SP = newsp;
4333     PUTBACK;
4334
4335     PL_curpm = newpm;   /* pop $1 et al */
4336
4337     LEAVE;
4338     return NORMAL;
4339 }
4340
4341 PP(pp_continue)
4342 {
4343     dVAR;
4344     I32 cxix;
4345     register PERL_CONTEXT *cx;
4346     I32 inner;
4347
4348     cxix = dopoptowhen(cxstack_ix);
4349     if (cxix < 0)
4350         DIE(aTHX_ "Can't \"continue\" outside a when block");
4351     if (cxix < cxstack_ix)
4352         dounwind(cxix);
4353
4354     /* clear off anything above the scope we're re-entering */
4355     inner = PL_scopestack_ix;
4356     TOPBLOCK(cx);
4357     if (PL_scopestack_ix < inner)
4358         leave_scope(PL_scopestack[PL_scopestack_ix]);
4359     PL_curcop = cx->blk_oldcop;
4360     return cx->blk_givwhen.leave_op;
4361 }
4362
4363 PP(pp_break)
4364 {
4365     dVAR;
4366     I32 cxix;
4367     register PERL_CONTEXT *cx;
4368     I32 inner;
4369
4370     cxix = dopoptogiven(cxstack_ix);
4371     if (cxix < 0) {
4372         if (PL_op->op_flags & OPf_SPECIAL)
4373             DIE(aTHX_ "Can't use when() outside a topicalizer");
4374         else
4375             DIE(aTHX_ "Can't \"break\" outside a given block");
4376     }
4377     if (CxFOREACH(&cxstack[cxix]) && (0 == (PL_op->op_flags & OPf_SPECIAL)))
4378         DIE(aTHX_ "Can't \"break\" in a loop topicalizer");
4379
4380     if (cxix < cxstack_ix)
4381         dounwind(cxix);
4382
4383     /* clear off anything above the scope we're re-entering */
4384     inner = PL_scopestack_ix;
4385     TOPBLOCK(cx);
4386     if (PL_scopestack_ix < inner)
4387         leave_scope(PL_scopestack[PL_scopestack_ix]);
4388     PL_curcop = cx->blk_oldcop;
4389
4390     if (CxFOREACH(cx))
4391         return CX_LOOP_NEXTOP_GET(cx);
4392     else
4393         return cx->blk_givwhen.leave_op;
4394 }
4395
4396 STATIC OP *
4397 S_doparseform(pTHX_ SV *sv)
4398 {
4399     STRLEN len;
4400     register char *s = SvPV_force(sv, len);
4401     register char * const send = s + len;
4402     register char *base = NULL;
4403     register I32 skipspaces = 0;
4404     bool noblank   = FALSE;
4405     bool repeat    = FALSE;
4406     bool postspace = FALSE;
4407     U32 *fops;
4408     register U32 *fpc;
4409     U32 *linepc = NULL;
4410     register I32 arg;
4411     bool ischop;
4412     bool unchopnum = FALSE;
4413     int maxops = 12; /* FF_LINEMARK + FF_END + 10 (\0 without preceding \n) */
4414
4415     if (len == 0)
4416         Perl_croak(aTHX_ "Null picture in formline");
4417
4418     /* estimate the buffer size needed */
4419     for (base = s; s <= send; s++) {
4420         if (*s == '\n' || *s == '@' || *s == '^')
4421             maxops += 10;
4422     }
4423     s = base;
4424     base = NULL;
4425
4426     Newx(fops, maxops, U32);
4427     fpc = fops;
4428
4429     if (s < send) {
4430         linepc = fpc;
4431         *fpc++ = FF_LINEMARK;
4432         noblank = repeat = FALSE;
4433         base = s;
4434     }
4435
4436     while (s <= send) {
4437         switch (*s++) {
4438         default:
4439             skipspaces = 0;
4440             continue;
4441
4442         case '~':
4443             if (*s == '~') {
4444                 repeat = TRUE;
4445                 *s = ' ';
4446             }
4447             noblank = TRUE;
4448             s[-1] = ' ';
4449             /* FALL THROUGH */
4450         case ' ': case '\t':
4451             skipspaces++;
4452             continue;
4453         case 0:
4454             if (s < send) {
4455                 skipspaces = 0;
4456                 continue;
4457             } /* else FALL THROUGH */
4458         case '\n':
4459             arg = s - base;
4460             skipspaces++;
4461             arg -= skipspaces;
4462             if (arg) {
4463                 if (postspace)
4464                     *fpc++ = FF_SPACE;
4465                 *fpc++ = FF_LITERAL;
4466                 *fpc++ = (U16)arg;
4467             }
4468             postspace = FALSE;
4469             if (s <= send)
4470                 skipspaces--;
4471             if (skipspaces) {
4472                 *fpc++ = FF_SKIP;
4473                 *fpc++ = (U16)skipspaces;
4474             }
4475             skipspaces = 0;
4476             if (s <= send)
4477                 *fpc++ = FF_NEWLINE;
4478             if (noblank) {
4479                 *fpc++ = FF_BLANK;
4480                 if (repeat)
4481                     arg = fpc - linepc + 1;
4482                 else
4483                     arg = 0;
4484                 *fpc++ = (U16)arg;
4485             }
4486             if (s < send) {
4487                 linepc = fpc;
4488                 *fpc++ = FF_LINEMARK;
4489                 noblank = repeat = FALSE;
4490                 base = s;
4491             }
4492             else
4493                 s++;
4494             continue;
4495
4496         case '@':
4497         case '^':
4498             ischop = s[-1] == '^';
4499
4500             if (postspace) {
4501                 *fpc++ = FF_SPACE;
4502                 postspace = FALSE;
4503             }
4504             arg = (s - base) - 1;
4505             if (arg) {
4506                 *fpc++ = FF_LITERAL;
4507                 *fpc++ = (U16)arg;
4508             }
4509
4510             base = s - 1;
4511             *fpc++ = FF_FETCH;
4512             if (*s == '*') {
4513                 s++;
4514                 *fpc++ = 2;  /* skip the @* or ^* */
4515                 if (ischop) {
4516                     *fpc++ = FF_LINESNGL;
4517                     *fpc++ = FF_CHOP;
4518                 } else
4519                     *fpc++ = FF_LINEGLOB;
4520             }
4521             else if (*s == '#' || (*s == '.' && s[1] == '#')) {
4522                 arg = ischop ? 512 : 0;
4523                 base = s - 1;
4524                 while (*s == '#')
4525                     s++;
4526                 if (*s == '.') {
4527                     const char * const f = ++s;
4528                     while (*s == '#')
4529                         s++;
4530                     arg |= 256 + (s - f);
4531                 }
4532                 *fpc++ = s - base;              /* fieldsize for FETCH */
4533                 *fpc++ = FF_DECIMAL;
4534                 *fpc++ = (U16)arg;
4535                 unchopnum |= ! ischop;
4536             }
4537             else if (*s == '0' && s[1] == '#') {  /* Zero padded decimals */
4538                 arg = ischop ? 512 : 0;
4539                 base = s - 1;
4540                 s++;                                /* skip the '0' first */
4541                 while (*s == '#')
4542                     s++;
4543                 if (*s == '.') {
4544                     const char * const f = ++s;
4545                     while (*s == '#')
4546                         s++;
4547                     arg |= 256 + (s - f);
4548                 }
4549                 *fpc++ = s - base;                /* fieldsize for FETCH */
4550                 *fpc++ = FF_0DECIMAL;
4551                 *fpc++ = (U16)arg;
4552                 unchopnum |= ! ischop;
4553             }
4554             else {
4555                 I32 prespace = 0;
4556                 bool ismore = FALSE;
4557
4558                 if (*s == '>') {
4559                     while (*++s == '>') ;
4560                     prespace = FF_SPACE;
4561                 }
4562                 else if (*s == '|') {
4563                     while (*++s == '|') ;
4564                     prespace = FF_HALFSPACE;
4565                     postspace = TRUE;
4566                 }
4567                 else {
4568                     if (*s == '<')
4569                         while (*++s == '<') ;
4570                     postspace = TRUE;
4571                 }
4572                 if (*s == '.' && s[1] == '.' && s[2] == '.') {
4573                     s += 3;
4574                     ismore = TRUE;
4575                 }
4576                 *fpc++ = s - base;              /* fieldsize for FETCH */
4577
4578                 *fpc++ = ischop ? FF_CHECKCHOP : FF_CHECKNL;
4579
4580                 if (prespace)
4581                     *fpc++ = (U16)prespace;
4582                 *fpc++ = FF_ITEM;
4583                 if (ismore)
4584                     *fpc++ = FF_MORE;
4585                 if (ischop)
4586                     *fpc++ = FF_CHOP;
4587             }
4588             base = s;
4589             skipspaces = 0;
4590             continue;
4591         }
4592     }
4593     *fpc++ = FF_END;
4594
4595     assert (fpc <= fops + maxops); /* ensure our buffer estimate was valid */
4596     arg = fpc - fops;
4597     { /* need to jump to the next word */
4598         int z;
4599         z = WORD_ALIGN - SvCUR(sv) % WORD_ALIGN;
4600         SvGROW(sv, SvCUR(sv) + z + arg * sizeof(U32) + 4);
4601         s = SvPVX(sv) + SvCUR(sv) + z;
4602     }
4603     Copy(fops, s, arg, U32);
4604     Safefree(fops);
4605     sv_magic(sv, NULL, PERL_MAGIC_fm, NULL, 0);
4606     SvCOMPILED_on(sv);
4607
4608     if (unchopnum && repeat)
4609         DIE(aTHX_ "Repeated format line will never terminate (~~ and @#)");
4610     return 0;
4611 }
4612
4613
4614 STATIC bool
4615 S_num_overflow(NV value, I32 fldsize, I32 frcsize)
4616 {
4617     /* Can value be printed in fldsize chars, using %*.*f ? */
4618     NV pwr = 1;
4619     NV eps = 0.5;
4620     bool res = FALSE;
4621     int intsize = fldsize - (value < 0 ? 1 : 0);
4622
4623     if (frcsize & 256)
4624         intsize--;
4625     frcsize &= 255;
4626     intsize -= frcsize;
4627
4628     while (intsize--) pwr *= 10.0;
4629     while (frcsize--) eps /= 10.0;
4630
4631     if( value >= 0 ){
4632         if (value + eps >= pwr)
4633             res = TRUE;
4634     } else {
4635         if (value - eps <= -pwr)
4636             res = TRUE;
4637     }
4638     return res;
4639 }
4640
4641 static I32
4642 S_run_user_filter(pTHX_ int idx, SV *buf_sv, int maxlen)
4643 {
4644     dVAR;
4645     SV * const datasv = FILTER_DATA(idx);
4646     const int filter_has_file = IoLINES(datasv);
4647     SV * const filter_state = (SV *)IoTOP_GV(datasv);
4648     SV * const filter_sub = (SV *)IoBOTTOM_GV(datasv);
4649     int status = 0;
4650     SV *upstream;
4651     STRLEN got_len;
4652     const char *got_p = NULL;
4653     const char *prune_from = NULL;
4654     bool read_from_cache = FALSE;
4655     STRLEN umaxlen;
4656
4657     assert(maxlen >= 0);
4658     umaxlen = maxlen;
4659
4660     /* I was having segfault trouble under Linux 2.2.5 after a
4661        parse error occured.  (Had to hack around it with a test
4662        for PL_parser->error_count == 0.)  Solaris doesn't segfault --
4663        not sure where the trouble is yet.  XXX */
4664
4665     if (IoFMT_GV(datasv)) {
4666         SV *const cache = (SV *)IoFMT_GV(datasv);
4667         if (SvOK(cache)) {
4668             STRLEN cache_len;
4669             const char *cache_p = SvPV(cache, cache_len);
4670             STRLEN take = 0;
4671
4672             if (umaxlen) {
4673                 /* Running in block mode and we have some cached data already.
4674                  */
4675                 if (cache_len >= umaxlen) {
4676                     /* In fact, so much data we don't even need to call
4677                        filter_read.  */
4678                     take = umaxlen;
4679                 }
4680             } else {
4681                 const char *const first_nl =
4682                     (const char *)memchr(cache_p, '\n', cache_len);
4683                 if (first_nl) {
4684                     take = first_nl + 1 - cache_p;
4685                 }
4686             }
4687             if (take) {
4688                 sv_catpvn(buf_sv, cache_p, take);
4689                 sv_chop(cache, cache_p + take);
4690                 /* Definately not EOF  */
4691                 return 1;
4692             }
4693
4694             sv_catsv(buf_sv, cache);
4695             if (umaxlen) {
4696                 umaxlen -= cache_len;
4697             }
4698             SvOK_off(cache);
4699             read_from_cache = TRUE;
4700         }
4701     }
4702
4703     /* Filter API says that the filter appends to the contents of the buffer.
4704        Usually the buffer is "", so the details don't matter. But if it's not,
4705        then clearly what it contains is already filtered by this filter, so we
4706        don't want to pass it in a second time.
4707        I'm going to use a mortal in case the upstream filter croaks.  */
4708     upstream = ((SvOK(buf_sv) && sv_len(buf_sv)) || SvGMAGICAL(buf_sv))
4709         ? sv_newmortal() : buf_sv;
4710     SvUPGRADE(upstream, SVt_PV);
4711
4712     if (filter_has_file) {
4713         status = FILTER_READ(idx+1, upstream, 0);
4714     }
4715
4716     if (filter_sub && status >= 0) {
4717         dSP;
4718         int count;
4719
4720         ENTER;
4721         SAVE_DEFSV;
4722         SAVETMPS;
4723         EXTEND(SP, 2);
4724
4725         DEFSV = upstream;
4726         PUSHMARK(SP);
4727         mPUSHi(0);
4728         if (filter_state) {
4729             PUSHs(filter_state);
4730         }
4731         PUTBACK;
4732         count = call_sv(filter_sub, G_SCALAR);
4733         SPAGAIN;
4734
4735         if (count > 0) {
4736             SV *out = POPs;
4737             if (SvOK(out)) {
4738                 status = SvIV(out);
4739             }
4740         }
4741
4742         PUTBACK;
4743         FREETMPS;
4744         LEAVE;
4745     }
4746
4747     if(SvOK(upstream)) {
4748         got_p = SvPV(upstream, got_len);
4749         if (umaxlen) {
4750             if (got_len > umaxlen) {
4751                 prune_from = got_p + umaxlen;
4752             }
4753         } else {
4754             const char *const first_nl =
4755                 (const char *)memchr(got_p, '\n', got_len);
4756             if (first_nl && first_nl + 1 < got_p + got_len) {
4757                 /* There's a second line here... */
4758                 prune_from = first_nl + 1;
4759             }
4760         }
4761     }
4762     if (prune_from) {
4763         /* Oh. Too long. Stuff some in our cache.  */
4764         STRLEN cached_len = got_p + got_len - prune_from;
4765         SV *cache = (SV *)IoFMT_GV(datasv);
4766
4767         if (!cache) {
4768             IoFMT_GV(datasv) = (GV*) (cache = newSV(got_len - umaxlen));
4769         } else if (SvOK(cache)) {
4770             /* Cache should be empty.  */
4771             assert(!SvCUR(cache));
4772         }
4773
4774         sv_setpvn(cache, prune_from, cached_len);
4775         /* If you ask for block mode, you may well split UTF-8 characters.
4776            "If it breaks, you get to keep both parts"
4777            (Your code is broken if you  don't put them back together again
4778            before something notices.) */
4779         if (SvUTF8(upstream)) {
4780             SvUTF8_on(cache);
4781         }
4782         SvCUR_set(upstream, got_len - cached_len);
4783         /* Can't yet be EOF  */
4784         if (status == 0)
4785             status = 1;
4786     }
4787
4788     /* If they are at EOF but buf_sv has something in it, then they may never
4789        have touched the SV upstream, so it may be undefined.  If we naively
4790        concatenate it then we get a warning about use of uninitialised value.
4791     */
4792     if (upstream != buf_sv && (SvOK(upstream) || SvGMAGICAL(upstream))) {
4793         sv_catsv(buf_sv, upstream);
4794     }
4795
4796     if (status <= 0) {
4797         IoLINES(datasv) = 0;
4798         SvREFCNT_dec(IoFMT_GV(datasv));
4799         if (filter_state) {
4800             SvREFCNT_dec(filter_state);
4801             IoTOP_GV(datasv) = NULL;
4802         }
4803         if (filter_sub) {
4804             SvREFCNT_dec(filter_sub);
4805             IoBOTTOM_GV(datasv) = NULL;
4806         }
4807         filter_del(S_run_user_filter);
4808     }
4809     if (status == 0 && read_from_cache) {
4810         /* If we read some data from the cache (and by getting here it implies
4811            that we emptied the cache) then we aren't yet at EOF, and mustn't
4812            report that to our caller.  */
4813         return 1;
4814     }
4815     return status;
4816 }
4817
4818 /* perhaps someone can come up with a better name for
4819    this?  it is not really "absolute", per se ... */
4820 static bool
4821 S_path_is_absolute(const char *name)
4822 {
4823     if (PERL_FILE_IS_ABSOLUTE(name)
4824 #ifdef MACOS_TRADITIONAL
4825         || (*name == ':')
4826 #else
4827         || (*name == '.' && (name[1] == '/' ||
4828                              (name[1] == '.' && name[2] == '/')))
4829 #endif
4830          )
4831     {
4832         return TRUE;
4833     }
4834     else
4835         return FALSE;
4836 }
4837
4838 /*
4839  * Local variables:
4840  * c-indentation-style: bsd
4841  * c-basic-offset: 4
4842  * indent-tabs-mode: t
4843  * End:
4844  *
4845  * ex: set ts=8 sts=4 sw=4 noet:
4846  */