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