pp_ctl.c

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