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