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