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