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, LEX_START_SAME_FILTER);
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, LEX_START_SAME_FILTER);
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     PERL_ASYNC_CHECK();
4066     POPBLOCK(cx,newpm);
4067     POPEVAL(cx);
4068     namesv = cx->blk_eval.old_namesv;
4069     retop = cx->blk_eval.retop;
4070
4071     TAINT_NOT;
4072     if (gimme == G_VOID)
4073         MARK = newsp;
4074     else if (gimme == G_SCALAR) {
4075         MARK = newsp + 1;
4076         if (MARK <= SP) {
4077             if (SvFLAGS(TOPs) & SVs_TEMP)
4078                 *MARK = TOPs;
4079             else
4080                 *MARK = sv_mortalcopy(TOPs);
4081         }
4082         else {
4083             MEXTEND(mark,0);
4084             *MARK = &PL_sv_undef;
4085         }
4086         SP = MARK;
4087     }
4088     else {
4089         /* in case LEAVE wipes old return values */
4090         for (mark = newsp + 1; mark <= SP; mark++) {
4091             if (!(SvFLAGS(*mark) & SVs_TEMP)) {
4092                 *mark = sv_mortalcopy(*mark);
4093                 TAINT_NOT;      /* Each item is independent */
4094             }
4095         }
4096     }
4097     PL_curpm = newpm;   /* Don't pop $1 et al till now */
4098
4099 #ifdef DEBUGGING
4100     assert(CvDEPTH(PL_compcv) == 1);
4101 #endif
4102     CvDEPTH(PL_compcv) = 0;
4103
4104     if (optype == OP_REQUIRE &&
4105         !(gimme == G_SCALAR ? SvTRUE(*SP) : SP > newsp))
4106     {
4107         /* Unassume the success we assumed earlier. */
4108         (void)hv_delete(GvHVn(PL_incgv),
4109                         SvPVX_const(namesv), SvCUR(namesv),
4110                         G_DISCARD);
4111         retop = Perl_die(aTHX_ "%"SVf" did not return a true value",
4112                                SVfARG(namesv));
4113         /* die_unwind() did LEAVE, or we won't be here */
4114     }
4115     else {
4116         LEAVE_with_name("eval");
4117         if (!(save_flags & OPf_SPECIAL)) {
4118             CLEAR_ERRSV();
4119         }
4120     }
4121
4122     RETURNOP(retop);
4123 }
4124
4125 /* Common code for Perl_call_sv and Perl_fold_constants, put here to keep it
4126    close to the related Perl_create_eval_scope.  */
4127 void
4128 Perl_delete_eval_scope(pTHX)
4129 {
4130     SV **newsp;
4131     PMOP *newpm;
4132     I32 gimme;
4133     register PERL_CONTEXT *cx;
4134     I32 optype;
4135
4136     POPBLOCK(cx,newpm);
4137     POPEVAL(cx);
4138     PL_curpm = newpm;
4139     LEAVE_with_name("eval_scope");
4140     PERL_UNUSED_VAR(newsp);
4141     PERL_UNUSED_VAR(gimme);
4142     PERL_UNUSED_VAR(optype);
4143 }
4144
4145 /* Common-ish code salvaged from Perl_call_sv and pp_entertry, because it was
4146    also needed by Perl_fold_constants.  */
4147 PERL_CONTEXT *
4148 Perl_create_eval_scope(pTHX_ U32 flags)
4149 {
4150     PERL_CONTEXT *cx;
4151     const I32 gimme = GIMME_V;
4152
4153     ENTER_with_name("eval_scope");
4154     SAVETMPS;
4155
4156     PUSHBLOCK(cx, (CXt_EVAL|CXp_TRYBLOCK), PL_stack_sp);
4157     PUSHEVAL(cx, 0);
4158
4159     PL_in_eval = EVAL_INEVAL;
4160     if (flags & G_KEEPERR)
4161         PL_in_eval |= EVAL_KEEPERR;
4162     else
4163         CLEAR_ERRSV();
4164     if (flags & G_FAKINGEVAL) {
4165         PL_eval_root = PL_op; /* Only needed so that goto works right. */
4166     }
4167     return cx;
4168 }
4169
4170 PP(pp_entertry)
4171 {
4172     dVAR;
4173     PERL_CONTEXT * const cx = create_eval_scope(0);
4174     cx->blk_eval.retop = cLOGOP->op_other->op_next;
4175     return DOCATCH(PL_op->op_next);
4176 }
4177
4178 PP(pp_leavetry)
4179 {
4180     dVAR; dSP;
4181     SV **newsp;
4182     PMOP *newpm;
4183     I32 gimme;
4184     register PERL_CONTEXT *cx;
4185     I32 optype;
4186
4187     PERL_ASYNC_CHECK();
4188     POPBLOCK(cx,newpm);
4189     POPEVAL(cx);
4190     PERL_UNUSED_VAR(optype);
4191
4192     TAINT_NOT;
4193     if (gimme == G_VOID)
4194         SP = newsp;
4195     else if (gimme == G_SCALAR) {
4196         register SV **mark;
4197         MARK = newsp + 1;
4198         if (MARK <= SP) {
4199             if (SvFLAGS(TOPs) & (SVs_PADTMP|SVs_TEMP))
4200                 *MARK = TOPs;
4201             else
4202                 *MARK = sv_mortalcopy(TOPs);
4203         }
4204         else {
4205             MEXTEND(mark,0);
4206             *MARK = &PL_sv_undef;
4207         }
4208         SP = MARK;
4209     }
4210     else {
4211         /* in case LEAVE wipes old return values */
4212         register SV **mark;
4213         for (mark = newsp + 1; mark <= SP; mark++) {
4214             if (!(SvFLAGS(*mark) & (SVs_PADTMP|SVs_TEMP))) {
4215                 *mark = sv_mortalcopy(*mark);
4216                 TAINT_NOT;      /* Each item is independent */
4217             }
4218         }
4219     }
4220     PL_curpm = newpm;   /* Don't pop $1 et al till now */
4221
4222     LEAVE_with_name("eval_scope");
4223     CLEAR_ERRSV();
4224     RETURN;
4225 }
4226
4227 PP(pp_entergiven)
4228 {
4229     dVAR; dSP;
4230     register PERL_CONTEXT *cx;
4231     const I32 gimme = GIMME_V;
4232
4233     ENTER_with_name("given");
4234     SAVETMPS;
4235
4236     sv_setsv(PAD_SV(PL_op->op_targ), POPs);
4237
4238     PUSHBLOCK(cx, CXt_GIVEN, SP);
4239     PUSHGIVEN(cx);
4240
4241     RETURN;
4242 }
4243
4244 PP(pp_leavegiven)
4245 {
4246     dVAR; dSP;
4247     register PERL_CONTEXT *cx;
4248     I32 gimme;
4249     SV **newsp;
4250     PMOP *newpm;
4251     PERL_UNUSED_CONTEXT;
4252
4253     POPBLOCK(cx,newpm);
4254     assert(CxTYPE(cx) == CXt_GIVEN);
4255
4256     TAINT_NOT;
4257     if (gimme == G_VOID)
4258         SP = newsp;
4259     else if (gimme == G_SCALAR) {
4260         register SV **mark;
4261         MARK = newsp + 1;
4262         if (MARK <= SP) {
4263             if (SvFLAGS(TOPs) & (SVs_PADTMP|SVs_TEMP))
4264                 *MARK = TOPs;
4265             else
4266                 *MARK = sv_mortalcopy(TOPs);
4267         }
4268         else {
4269             MEXTEND(mark,0);
4270             *MARK = &PL_sv_undef;
4271         }
4272         SP = MARK;
4273     }
4274     else {
4275         /* in case LEAVE wipes old return values */
4276         register SV **mark;
4277         for (mark = newsp + 1; mark <= SP; mark++) {
4278             if (!(SvFLAGS(*mark) & (SVs_PADTMP|SVs_TEMP))) {
4279                 *mark = sv_mortalcopy(*mark);
4280                 TAINT_NOT;      /* Each item is independent */
4281             }
4282         }
4283     }
4284     PL_curpm = newpm;   /* Don't pop $1 et al till now */
4285
4286     LEAVE_with_name("given");
4287     RETURN;
4288 }
4289
4290 /* Helper routines used by pp_smartmatch */
4291 STATIC PMOP *
4292 S_make_matcher(pTHX_ REGEXP *re)
4293 {
4294     dVAR;
4295     PMOP *matcher = (PMOP *) newPMOP(OP_MATCH, OPf_WANT_SCALAR | OPf_STACKED);
4296
4297     PERL_ARGS_ASSERT_MAKE_MATCHER;
4298
4299     PM_SETRE(matcher, ReREFCNT_inc(re));
4300
4301     SAVEFREEOP((OP *) matcher);
4302     ENTER_with_name("matcher"); SAVETMPS;
4303     SAVEOP();
4304     return matcher;
4305 }
4306
4307 STATIC bool
4308 S_matcher_matches_sv(pTHX_ PMOP *matcher, SV *sv)
4309 {
4310     dVAR;
4311     dSP;
4312
4313     PERL_ARGS_ASSERT_MATCHER_MATCHES_SV;
4314
4315     PL_op = (OP *) matcher;
4316     XPUSHs(sv);
4317     PUTBACK;
4318     (void) Perl_pp_match(aTHX);
4319     SPAGAIN;
4320     return (SvTRUEx(POPs));
4321 }
4322
4323 STATIC void
4324 S_destroy_matcher(pTHX_ PMOP *matcher)
4325 {
4326     dVAR;
4327
4328     PERL_ARGS_ASSERT_DESTROY_MATCHER;
4329     PERL_UNUSED_ARG(matcher);
4330
4331     FREETMPS;
4332     LEAVE_with_name("matcher");
4333 }
4334
4335 /* Do a smart match */
4336 PP(pp_smartmatch)
4337 {
4338     DEBUG_M(Perl_deb(aTHX_ "Starting smart match resolution\n"));
4339     return do_smartmatch(NULL, NULL);
4340 }
4341
4342 /* This version of do_smartmatch() implements the
4343  * table of smart matches that is found in perlsyn.
4344  */
4345 STATIC OP *
4346 S_do_smartmatch(pTHX_ HV *seen_this, HV *seen_other)
4347 {
4348     dVAR;
4349     dSP;
4350
4351     bool object_on_left = FALSE;
4352     SV *e = TOPs;       /* e is for 'expression' */
4353     SV *d = TOPm1s;     /* d is for 'default', as in PL_defgv */
4354
4355     /* Take care only to invoke mg_get() once for each argument.
4356      * Currently we do this by copying the SV if it's magical. */
4357     if (d) {
4358         if (SvGMAGICAL(d))
4359             d = sv_mortalcopy(d);
4360     }
4361     else
4362         d = &PL_sv_undef;
4363
4364     assert(e);
4365     if (SvGMAGICAL(e))
4366         e = sv_mortalcopy(e);
4367
4368     /* First of all, handle overload magic of the rightmost argument */
4369     if (SvAMAGIC(e)) {
4370         SV * tmpsv;
4371         DEBUG_M(Perl_deb(aTHX_ "    applying rule Any-Object\n"));
4372         DEBUG_M(Perl_deb(aTHX_ "        attempting overload\n"));
4373
4374         tmpsv = amagic_call(d, e, smart_amg, 0);
4375         if (tmpsv) {
4376             SPAGAIN;
4377             (void)POPs;
4378             SETs(tmpsv);
4379             RETURN;
4380         }
4381         DEBUG_M(Perl_deb(aTHX_ "        failed to run overload method; continuing...\n"));
4382     }
4383
4384     SP -= 2;    /* Pop the values */
4385
4386
4387     /* ~~ undef */
4388     if (!SvOK(e)) {
4389         DEBUG_M(Perl_deb(aTHX_ "    applying rule Any-undef\n"));
4390         if (SvOK(d))
4391             RETPUSHNO;
4392         else
4393             RETPUSHYES;
4394     }
4395
4396     if (sv_isobject(e) && (SvTYPE(SvRV(e)) != SVt_REGEXP)) {
4397         DEBUG_M(Perl_deb(aTHX_ "    applying rule Any-Object\n"));
4398         Perl_croak(aTHX_ "Smart matching a non-overloaded object breaks encapsulation");
4399     }
4400     if (sv_isobject(d) && (SvTYPE(SvRV(d)) != SVt_REGEXP))
4401         object_on_left = TRUE;
4402
4403     /* ~~ sub */
4404     if (SvROK(e) && SvTYPE(SvRV(e)) == SVt_PVCV) {
4405         I32 c;
4406         if (object_on_left) {
4407             goto sm_any_sub; /* Treat objects like scalars */
4408         }
4409         else if (SvROK(d) && SvTYPE(SvRV(d)) == SVt_PVHV) {
4410             /* Test sub truth for each key */
4411             HE *he;
4412             bool andedresults = TRUE;
4413             HV *hv = (HV*) SvRV(d);
4414             I32 numkeys = hv_iterinit(hv);
4415             DEBUG_M(Perl_deb(aTHX_ "    applying rule Hash-CodeRef\n"));
4416             if (numkeys == 0)
4417                 RETPUSHYES;
4418             while ( (he = hv_iternext(hv)) ) {
4419                 DEBUG_M(Perl_deb(aTHX_ "        testing hash key...\n"));
4420                 ENTER_with_name("smartmatch_hash_key_test");
4421                 SAVETMPS;
4422                 PUSHMARK(SP);
4423                 PUSHs(hv_iterkeysv(he));
4424                 PUTBACK;
4425                 c = call_sv(e, G_SCALAR);
4426                 SPAGAIN;
4427                 if (c == 0)
4428                     andedresults = FALSE;
4429                 else
4430                     andedresults = SvTRUEx(POPs) && andedresults;
4431                 FREETMPS;
4432                 LEAVE_with_name("smartmatch_hash_key_test");
4433             }
4434             if (andedresults)
4435                 RETPUSHYES;
4436             else
4437                 RETPUSHNO;
4438         }
4439         else if (SvROK(d) && SvTYPE(SvRV(d)) == SVt_PVAV) {
4440             /* Test sub truth for each element */
4441             I32 i;
4442             bool andedresults = TRUE;
4443             AV *av = (AV*) SvRV(d);
4444             const I32 len = av_len(av);
4445             DEBUG_M(Perl_deb(aTHX_ "    applying rule Array-CodeRef\n"));
4446             if (len == -1)
4447                 RETPUSHYES;
4448             for (i = 0; i <= len; ++i) {
4449                 SV * const * const svp = av_fetch(av, i, FALSE);
4450                 DEBUG_M(Perl_deb(aTHX_ "        testing array element...\n"));
4451                 ENTER_with_name("smartmatch_array_elem_test");
4452                 SAVETMPS;
4453                 PUSHMARK(SP);
4454                 if (svp)
4455                     PUSHs(*svp);
4456                 PUTBACK;
4457                 c = call_sv(e, G_SCALAR);
4458                 SPAGAIN;
4459                 if (c == 0)
4460                     andedresults = FALSE;
4461                 else
4462                     andedresults = SvTRUEx(POPs) && andedresults;
4463                 FREETMPS;
4464                 LEAVE_with_name("smartmatch_array_elem_test");
4465             }
4466             if (andedresults)
4467                 RETPUSHYES;
4468             else
4469                 RETPUSHNO;
4470         }
4471         else {
4472           sm_any_sub:
4473             DEBUG_M(Perl_deb(aTHX_ "    applying rule Any-CodeRef\n"));
4474             ENTER_with_name("smartmatch_coderef");
4475             SAVETMPS;
4476             PUSHMARK(SP);
4477             PUSHs(d);
4478             PUTBACK;
4479             c = call_sv(e, G_SCALAR);
4480             SPAGAIN;
4481             if (c == 0)
4482                 PUSHs(&PL_sv_no);
4483             else if (SvTEMP(TOPs))
4484                 SvREFCNT_inc_void(TOPs);
4485             FREETMPS;
4486             LEAVE_with_name("smartmatch_coderef");
4487             RETURN;
4488         }
4489     }
4490     /* ~~ %hash */
4491     else if (SvROK(e) && SvTYPE(SvRV(e)) == SVt_PVHV) {
4492         if (object_on_left) {
4493             goto sm_any_hash; /* Treat objects like scalars */
4494         }
4495         else if (!SvOK(d)) {
4496             DEBUG_M(Perl_deb(aTHX_ "    applying rule Any-Hash ($a undef)\n"));
4497             RETPUSHNO;
4498         }
4499         else if (SvROK(d) && SvTYPE(SvRV(d)) == SVt_PVHV) {
4500             /* Check that the key-sets are identical */
4501             HE *he;
4502             HV *other_hv = MUTABLE_HV(SvRV(d));
4503             bool tied = FALSE;
4504             bool other_tied = FALSE;
4505             U32 this_key_count  = 0,
4506                 other_key_count = 0;
4507             HV *hv = MUTABLE_HV(SvRV(e));
4508
4509             DEBUG_M(Perl_deb(aTHX_ "    applying rule Hash-Hash\n"));
4510             /* Tied hashes don't know how many keys they have. */
4511             if (SvTIED_mg((SV*)hv, PERL_MAGIC_tied)) {
4512                 tied = TRUE;
4513             }
4514             else if (SvTIED_mg((const SV *)other_hv, PERL_MAGIC_tied)) {
4515                 HV * const temp = other_hv;
4516                 other_hv = hv;
4517                 hv = temp;
4518                 tied = TRUE;
4519             }
4520             if (SvTIED_mg((const SV *)other_hv, PERL_MAGIC_tied))
4521                 other_tied = TRUE;
4522
4523             if (!tied && HvUSEDKEYS((const HV *) hv) != HvUSEDKEYS(other_hv))
4524                 RETPUSHNO;
4525
4526             /* The hashes have the same number of keys, so it suffices
4527                to check that one is a subset of the other. */
4528             (void) hv_iterinit(hv);
4529             while ( (he = hv_iternext(hv)) ) {
4530                 SV *key = hv_iterkeysv(he);
4531
4532                 DEBUG_M(Perl_deb(aTHX_ "        comparing hash key...\n"));
4533                 ++ this_key_count;
4534
4535                 if(!hv_exists_ent(other_hv, key, 0)) {
4536                     (void) hv_iterinit(hv);     /* reset iterator */
4537                     RETPUSHNO;
4538                 }
4539             }
4540
4541             if (other_tied) {
4542                 (void) hv_iterinit(other_hv);
4543                 while ( hv_iternext(other_hv) )
4544                     ++other_key_count;
4545             }
4546             else
4547                 other_key_count = HvUSEDKEYS(other_hv);
4548
4549             if (this_key_count != other_key_count)
4550                 RETPUSHNO;
4551             else
4552                 RETPUSHYES;
4553         }
4554         else if (SvROK(d) && SvTYPE(SvRV(d)) == SVt_PVAV) {
4555             AV * const other_av = MUTABLE_AV(SvRV(d));
4556             const I32 other_len = av_len(other_av) + 1;
4557             I32 i;
4558             HV *hv = MUTABLE_HV(SvRV(e));
4559
4560             DEBUG_M(Perl_deb(aTHX_ "    applying rule Array-Hash\n"));
4561             for (i = 0; i < other_len; ++i) {
4562                 SV ** const svp = av_fetch(other_av, i, FALSE);
4563                 DEBUG_M(Perl_deb(aTHX_ "        checking for key existence...\n"));
4564                 if (svp) {      /* ??? When can this not happen? */
4565                     if (hv_exists_ent(hv, *svp, 0))
4566                         RETPUSHYES;
4567                 }
4568             }
4569             RETPUSHNO;
4570         }
4571         else if (SvROK(d) && SvTYPE(SvRV(d)) == SVt_REGEXP) {
4572             DEBUG_M(Perl_deb(aTHX_ "    applying rule Regex-Hash\n"));
4573           sm_regex_hash:
4574             {
4575                 PMOP * const matcher = make_matcher((REGEXP*) SvRV(d));
4576                 HE *he;
4577                 HV *hv = MUTABLE_HV(SvRV(e));
4578
4579                 (void) hv_iterinit(hv);
4580                 while ( (he = hv_iternext(hv)) ) {
4581                     DEBUG_M(Perl_deb(aTHX_ "        testing key against pattern...\n"));
4582                     if (matcher_matches_sv(matcher, hv_iterkeysv(he))) {
4583                         (void) hv_iterinit(hv);
4584                         destroy_matcher(matcher);
4585                         RETPUSHYES;
4586                     }
4587                 }
4588                 destroy_matcher(matcher);
4589                 RETPUSHNO;
4590             }
4591         }
4592         else {
4593           sm_any_hash:
4594             DEBUG_M(Perl_deb(aTHX_ "    applying rule Any-Hash\n"));
4595             if (hv_exists_ent(MUTABLE_HV(SvRV(e)), d, 0))
4596                 RETPUSHYES;
4597             else
4598                 RETPUSHNO;
4599         }
4600     }
4601     /* ~~ @array */
4602     else if (SvROK(e) && SvTYPE(SvRV(e)) == SVt_PVAV) {
4603         if (object_on_left) {
4604             goto sm_any_array; /* Treat objects like scalars */
4605         }
4606         else if (SvROK(d) && SvTYPE(SvRV(d)) == SVt_PVHV) {
4607             AV * const other_av = MUTABLE_AV(SvRV(e));
4608             const I32 other_len = av_len(other_av) + 1;
4609             I32 i;
4610
4611             DEBUG_M(Perl_deb(aTHX_ "    applying rule Hash-Array\n"));
4612             for (i = 0; i < other_len; ++i) {
4613                 SV ** const svp = av_fetch(other_av, i, FALSE);
4614
4615                 DEBUG_M(Perl_deb(aTHX_ "        testing for key existence...\n"));
4616                 if (svp) {      /* ??? When can this not happen? */
4617                     if (hv_exists_ent(MUTABLE_HV(SvRV(d)), *svp, 0))
4618                         RETPUSHYES;
4619                 }
4620             }
4621             RETPUSHNO;
4622         }
4623         if (SvROK(d) && SvTYPE(SvRV(d)) == SVt_PVAV) {
4624             AV *other_av = MUTABLE_AV(SvRV(d));
4625             DEBUG_M(Perl_deb(aTHX_ "    applying rule Array-Array\n"));
4626             if (av_len(MUTABLE_AV(SvRV(e))) != av_len(other_av))
4627                 RETPUSHNO;
4628             else {
4629                 I32 i;
4630                 const I32 other_len = av_len(other_av);
4631
4632                 if (NULL == seen_this) {
4633                     seen_this = newHV();
4634                     (void) sv_2mortal(MUTABLE_SV(seen_this));
4635                 }
4636                 if (NULL == seen_other) {
4637                     seen_other = newHV();
4638                     (void) sv_2mortal(MUTABLE_SV(seen_other));
4639                 }
4640                 for(i = 0; i <= other_len; ++i) {
4641                     SV * const * const this_elem = av_fetch(MUTABLE_AV(SvRV(e)), i, FALSE);
4642                     SV * const * const other_elem = av_fetch(other_av, i, FALSE);
4643
4644                     if (!this_elem || !other_elem) {
4645                         if ((this_elem && SvOK(*this_elem))
4646                                 || (other_elem && SvOK(*other_elem)))
4647                             RETPUSHNO;
4648                     }
4649                     else if (hv_exists_ent(seen_this,
4650                                 sv_2mortal(newSViv(PTR2IV(*this_elem))), 0) ||
4651                             hv_exists_ent(seen_other,
4652                                 sv_2mortal(newSViv(PTR2IV(*other_elem))), 0))
4653                     {
4654                         if (*this_elem != *other_elem)
4655                             RETPUSHNO;
4656                     }
4657                     else {
4658                         (void)hv_store_ent(seen_this,
4659                                 sv_2mortal(newSViv(PTR2IV(*this_elem))),
4660                                 &PL_sv_undef, 0);
4661                         (void)hv_store_ent(seen_other,
4662                                 sv_2mortal(newSViv(PTR2IV(*other_elem))),
4663                                 &PL_sv_undef, 0);
4664                         PUSHs(*other_elem);
4665                         PUSHs(*this_elem);
4666
4667                         PUTBACK;
4668                         DEBUG_M(Perl_deb(aTHX_ "        recursively comparing array element...\n"));
4669                         (void) do_smartmatch(seen_this, seen_other);
4670                         SPAGAIN;
4671                         DEBUG_M(Perl_deb(aTHX_ "        recursion finished\n"));
4672
4673                         if (!SvTRUEx(POPs))
4674                             RETPUSHNO;
4675                     }
4676                 }
4677                 RETPUSHYES;
4678             }
4679         }
4680         else if (SvROK(d) && SvTYPE(SvRV(d)) == SVt_REGEXP) {
4681             DEBUG_M(Perl_deb(aTHX_ "    applying rule Regex-Array\n"));
4682           sm_regex_array:
4683             {
4684                 PMOP * const matcher = make_matcher((REGEXP*) SvRV(d));
4685                 const I32 this_len = av_len(MUTABLE_AV(SvRV(e)));
4686                 I32 i;
4687
4688                 for(i = 0; i <= this_len; ++i) {
4689                     SV * const * const svp = av_fetch(MUTABLE_AV(SvRV(e)), i, FALSE);
4690                     DEBUG_M(Perl_deb(aTHX_ "        testing element against pattern...\n"));
4691                     if (svp && matcher_matches_sv(matcher, *svp)) {
4692                         destroy_matcher(matcher);
4693                         RETPUSHYES;
4694                     }
4695                 }
4696                 destroy_matcher(matcher);
4697                 RETPUSHNO;
4698             }
4699         }
4700         else if (!SvOK(d)) {
4701             /* undef ~~ array */
4702             const I32 this_len = av_len(MUTABLE_AV(SvRV(e)));
4703             I32 i;
4704
4705             DEBUG_M(Perl_deb(aTHX_ "    applying rule Undef-Array\n"));
4706             for (i = 0; i <= this_len; ++i) {
4707                 SV * const * const svp = av_fetch(MUTABLE_AV(SvRV(e)), i, FALSE);
4708                 DEBUG_M(Perl_deb(aTHX_ "        testing for undef element...\n"));
4709                 if (!svp || !SvOK(*svp))
4710                     RETPUSHYES;
4711             }
4712             RETPUSHNO;
4713         }
4714         else {
4715           sm_any_array:
4716             {
4717                 I32 i;
4718                 const I32 this_len = av_len(MUTABLE_AV(SvRV(e)));
4719
4720                 DEBUG_M(Perl_deb(aTHX_ "    applying rule Any-Array\n"));
4721                 for (i = 0; i <= this_len; ++i) {
4722                     SV * const * const svp = av_fetch(MUTABLE_AV(SvRV(e)), i, FALSE);
4723                     if (!svp)
4724                         continue;
4725
4726                     PUSHs(d);
4727                     PUSHs(*svp);
4728                     PUTBACK;
4729                     /* infinite recursion isn't supposed to happen here */
4730                     DEBUG_M(Perl_deb(aTHX_ "        recursively testing array element...\n"));
4731                     (void) do_smartmatch(NULL, NULL);
4732                     SPAGAIN;
4733                     DEBUG_M(Perl_deb(aTHX_ "        recursion finished\n"));
4734                     if (SvTRUEx(POPs))
4735                         RETPUSHYES;
4736                 }
4737                 RETPUSHNO;
4738             }
4739         }
4740     }
4741     /* ~~ qr// */
4742     else if (SvROK(e) && SvTYPE(SvRV(e)) == SVt_REGEXP) {
4743         if (!object_on_left && SvROK(d) && SvTYPE(SvRV(d)) == SVt_PVHV) {
4744             SV *t = d; d = e; e = t;
4745             DEBUG_M(Perl_deb(aTHX_ "    applying rule Hash-Regex\n"));
4746             goto sm_regex_hash;
4747         }
4748         else if (!object_on_left && SvROK(d) && SvTYPE(SvRV(d)) == SVt_PVAV) {
4749             SV *t = d; d = e; e = t;
4750             DEBUG_M(Perl_deb(aTHX_ "    applying rule Array-Regex\n"));
4751             goto sm_regex_array;
4752         }
4753         else {
4754             PMOP * const matcher = make_matcher((REGEXP*) SvRV(e));
4755
4756             DEBUG_M(Perl_deb(aTHX_ "    applying rule Any-Regex\n"));
4757             PUTBACK;
4758             PUSHs(matcher_matches_sv(matcher, d)
4759                     ? &PL_sv_yes
4760                     : &PL_sv_no);
4761             destroy_matcher(matcher);
4762             RETURN;
4763         }
4764     }
4765     /* ~~ scalar */
4766     /* See if there is overload magic on left */
4767     else if (object_on_left && SvAMAGIC(d)) {
4768         SV *tmpsv;
4769         DEBUG_M(Perl_deb(aTHX_ "    applying rule Object-Any\n"));
4770         DEBUG_M(Perl_deb(aTHX_ "        attempting overload\n"));
4771         PUSHs(d); PUSHs(e);
4772         PUTBACK;
4773         tmpsv = amagic_call(d, e, smart_amg, AMGf_noright);
4774         if (tmpsv) {
4775             SPAGAIN;
4776             (void)POPs;
4777             SETs(tmpsv);
4778             RETURN;
4779         }
4780         SP -= 2;
4781         DEBUG_M(Perl_deb(aTHX_ "        failed to run overload method; falling back...\n"));
4782         goto sm_any_scalar;
4783     }
4784     else if (!SvOK(d)) {
4785         /* undef ~~ scalar ; we already know that the scalar is SvOK */
4786         DEBUG_M(Perl_deb(aTHX_ "    applying rule undef-Any\n"));
4787         RETPUSHNO;
4788     }
4789     else
4790   sm_any_scalar:
4791     if (SvNIOK(e) || (SvPOK(e) && looks_like_number(e) && SvNIOK(d))) {
4792         DEBUG_M(if (SvNIOK(e))
4793                     Perl_deb(aTHX_ "    applying rule Any-Num\n");
4794                 else
4795                     Perl_deb(aTHX_ "    applying rule Num-numish\n");
4796         );
4797         /* numeric comparison */
4798         PUSHs(d); PUSHs(e);
4799         PUTBACK;
4800         if (CopHINTS_get(PL_curcop) & HINT_INTEGER)
4801             (void) Perl_pp_i_eq(aTHX);
4802         else
4803             (void) Perl_pp_eq(aTHX);
4804         SPAGAIN;
4805         if (SvTRUEx(POPs))
4806             RETPUSHYES;
4807         else
4808             RETPUSHNO;
4809     }
4810
4811     /* As a last resort, use string comparison */
4812     DEBUG_M(Perl_deb(aTHX_ "    applying rule Any-Any\n"));
4813     PUSHs(d); PUSHs(e);
4814     PUTBACK;
4815     return Perl_pp_seq(aTHX);
4816 }
4817
4818 PP(pp_enterwhen)
4819 {
4820     dVAR; dSP;
4821     register PERL_CONTEXT *cx;
4822     const I32 gimme = GIMME_V;
4823
4824     /* This is essentially an optimization: if the match
4825        fails, we don't want to push a context and then
4826        pop it again right away, so we skip straight
4827        to the op that follows the leavewhen.
4828        RETURNOP calls PUTBACK which restores the stack pointer after the POPs.
4829     */
4830     if ((0 == (PL_op->op_flags & OPf_SPECIAL)) && !SvTRUEx(POPs))
4831         RETURNOP(cLOGOP->op_other->op_next);
4832
4833     ENTER_with_name("eval");
4834     SAVETMPS;
4835
4836     PUSHBLOCK(cx, CXt_WHEN, SP);
4837     PUSHWHEN(cx);
4838
4839     RETURN;
4840 }
4841
4842 PP(pp_leavewhen)
4843 {
4844     dVAR; dSP;
4845     register PERL_CONTEXT *cx;
4846     I32 gimme;
4847     SV **newsp;
4848     PMOP *newpm;
4849
4850     POPBLOCK(cx,newpm);
4851     assert(CxTYPE(cx) == CXt_WHEN);
4852
4853     SP = newsp;
4854     PUTBACK;
4855
4856     PL_curpm = newpm;   /* pop $1 et al */
4857
4858     LEAVE_with_name("eval");
4859     return NORMAL;
4860 }
4861
4862 PP(pp_continue)
4863 {
4864     dVAR;
4865     I32 cxix;
4866     register PERL_CONTEXT *cx;
4867     I32 inner;
4868
4869     cxix = dopoptowhen(cxstack_ix);
4870     if (cxix < 0)
4871         DIE(aTHX_ "Can't \"continue\" outside a when block");
4872     if (cxix < cxstack_ix)
4873         dounwind(cxix);
4874
4875     /* clear off anything above the scope we're re-entering */
4876     inner = PL_scopestack_ix;
4877     TOPBLOCK(cx);
4878     if (PL_scopestack_ix < inner)
4879         leave_scope(PL_scopestack[PL_scopestack_ix]);
4880     PL_curcop = cx->blk_oldcop;
4881     return cx->blk_givwhen.leave_op;
4882 }
4883
4884 PP(pp_break)
4885 {
4886     dVAR;
4887     I32 cxix;
4888     register PERL_CONTEXT *cx;
4889     I32 inner;
4890     dSP;
4891
4892     cxix = dopoptogiven(cxstack_ix);
4893     if (cxix < 0) {
4894         if (PL_op->op_flags & OPf_SPECIAL)
4895             DIE(aTHX_ "Can't use when() outside a topicalizer");
4896         else
4897             DIE(aTHX_ "Can't \"break\" outside a given block");
4898     }
4899     if (CxFOREACH(&cxstack[cxix]) && (0 == (PL_op->op_flags & OPf_SPECIAL)))
4900         DIE(aTHX_ "Can't \"break\" in a loop topicalizer");
4901
4902     if (cxix < cxstack_ix)
4903         dounwind(cxix);
4904
4905     /* clear off anything above the scope we're re-entering */
4906     inner = PL_scopestack_ix;
4907     TOPBLOCK(cx);
4908     if (PL_scopestack_ix < inner)
4909         leave_scope(PL_scopestack[PL_scopestack_ix]);
4910     PL_curcop = cx->blk_oldcop;
4911
4912     if (CxFOREACH(cx))
4913         return (cx)->blk_loop.my_op->op_nextop;
4914     else
4915         /* RETURNOP calls PUTBACK which restores the old old sp */
4916         RETURNOP(cx->blk_givwhen.leave_op);
4917 }
4918
4919 STATIC OP *
4920 S_doparseform(pTHX_ SV *sv)
4921 {
4922     STRLEN len;
4923     register char *s = SvPV_force(sv, len);
4924     register char * const send = s + len;
4925     register char *base = NULL;
4926     register I32 skipspaces = 0;
4927     bool noblank   = FALSE;
4928     bool repeat    = FALSE;
4929     bool postspace = FALSE;
4930     U32 *fops;
4931     register U32 *fpc;
4932     U32 *linepc = NULL;
4933     register I32 arg;
4934     bool ischop;
4935     bool unchopnum = FALSE;
4936     int maxops = 12; /* FF_LINEMARK + FF_END + 10 (\0 without preceding \n) */
4937
4938     PERL_ARGS_ASSERT_DOPARSEFORM;
4939
4940     if (len == 0)
4941         Perl_croak(aTHX_ "Null picture in formline");
4942
4943     /* estimate the buffer size needed */
4944     for (base = s; s <= send; s++) {
4945         if (*s == '\n' || *s == '@' || *s == '^')
4946             maxops += 10;
4947     }
4948     s = base;
4949     base = NULL;
4950
4951     Newx(fops, maxops, U32);
4952     fpc = fops;
4953
4954     if (s < send) {
4955         linepc = fpc;
4956         *fpc++ = FF_LINEMARK;
4957         noblank = repeat = FALSE;
4958         base = s;
4959     }
4960
4961     while (s <= send) {
4962         switch (*s++) {
4963         default:
4964             skipspaces = 0;
4965             continue;
4966
4967         case '~':
4968             if (*s == '~') {
4969                 repeat = TRUE;
4970                 *s = ' ';
4971             }
4972             noblank = TRUE;
4973             s[-1] = ' ';
4974             /* FALL THROUGH */
4975         case ' ': case '\t':
4976             skipspaces++;
4977             continue;
4978         case 0:
4979             if (s < send) {
4980                 skipspaces = 0;
4981                 continue;
4982             } /* else FALL THROUGH */
4983         case '\n':
4984             arg = s - base;
4985             skipspaces++;
4986             arg -= skipspaces;
4987             if (arg) {
4988                 if (postspace)
4989                     *fpc++ = FF_SPACE;
4990                 *fpc++ = FF_LITERAL;
4991                 *fpc++ = (U16)arg;
4992             }
4993             postspace = FALSE;
4994             if (s <= send)
4995                 skipspaces--;
4996             if (skipspaces) {
4997                 *fpc++ = FF_SKIP;
4998                 *fpc++ = (U16)skipspaces;
4999             }
5000             skipspaces = 0;
5001             if (s <= send)
5002                 *fpc++ = FF_NEWLINE;
5003             if (noblank) {
5004                 *fpc++ = FF_BLANK;
5005                 if (repeat)
5006                     arg = fpc - linepc + 1;
5007                 else
5008                     arg = 0;
5009                 *fpc++ = (U16)arg;
5010             }
5011             if (s < send) {
5012                 linepc = fpc;
5013                 *fpc++ = FF_LINEMARK;
5014                 noblank = repeat = FALSE;
5015                 base = s;
5016             }
5017             else
5018                 s++;
5019             continue;
5020
5021         case '@':
5022         case '^':
5023             ischop = s[-1] == '^';
5024
5025             if (postspace) {
5026                 *fpc++ = FF_SPACE;
5027                 postspace = FALSE;
5028             }
5029             arg = (s - base) - 1;
5030             if (arg) {
5031                 *fpc++ = FF_LITERAL;
5032                 *fpc++ = (U16)arg;
5033             }
5034
5035             base = s - 1;
5036             *fpc++ = FF_FETCH;
5037             if (*s == '*') {
5038                 s++;
5039                 *fpc++ = 2;  /* skip the @* or ^* */
5040                 if (ischop) {
5041                     *fpc++ = FF_LINESNGL;
5042                     *fpc++ = FF_CHOP;
5043                 } else
5044                     *fpc++ = FF_LINEGLOB;
5045             }
5046             else if (*s == '#' || (*s == '.' && s[1] == '#')) {
5047                 arg = ischop ? 512 : 0;
5048                 base = s - 1;
5049                 while (*s == '#')
5050                     s++;
5051                 if (*s == '.') {
5052                     const char * const f = ++s;
5053                     while (*s == '#')
5054                         s++;
5055                     arg |= 256 + (s - f);
5056                 }
5057                 *fpc++ = s - base;              /* fieldsize for FETCH */
5058                 *fpc++ = FF_DECIMAL;
5059                 *fpc++ = (U16)arg;
5060                 unchopnum |= ! ischop;
5061             }
5062             else if (*s == '0' && s[1] == '#') {  /* Zero padded decimals */
5063                 arg = ischop ? 512 : 0;
5064                 base = s - 1;
5065                 s++;                                /* skip the '0' first */
5066                 while (*s == '#')
5067                     s++;
5068                 if (*s == '.') {
5069                     const char * const f = ++s;
5070                     while (*s == '#')
5071                         s++;
5072                     arg |= 256 + (s - f);
5073                 }
5074                 *fpc++ = s - base;                /* fieldsize for FETCH */
5075                 *fpc++ = FF_0DECIMAL;
5076                 *fpc++ = (U16)arg;
5077                 unchopnum |= ! ischop;
5078             }
5079             else {
5080                 I32 prespace = 0;
5081                 bool ismore = FALSE;
5082
5083                 if (*s == '>') {
5084                     while (*++s == '>') ;
5085                     prespace = FF_SPACE;
5086                 }
5087                 else if (*s == '|') {
5088                     while (*++s == '|') ;
5089                     prespace = FF_HALFSPACE;
5090                     postspace = TRUE;
5091                 }
5092                 else {
5093                     if (*s == '<')
5094                         while (*++s == '<') ;
5095                     postspace = TRUE;
5096                 }
5097                 if (*s == '.' && s[1] == '.' && s[2] == '.') {
5098                     s += 3;
5099                     ismore = TRUE;
5100                 }
5101                 *fpc++ = s - base;              /* fieldsize for FETCH */
5102
5103                 *fpc++ = ischop ? FF_CHECKCHOP : FF_CHECKNL;
5104
5105                 if (prespace)
5106                     *fpc++ = (U16)prespace;
5107                 *fpc++ = FF_ITEM;
5108                 if (ismore)
5109                     *fpc++ = FF_MORE;
5110                 if (ischop)
5111                     *fpc++ = FF_CHOP;
5112             }
5113             base = s;
5114             skipspaces = 0;
5115             continue;
5116         }
5117     }
5118     *fpc++ = FF_END;
5119
5120     assert (fpc <= fops + maxops); /* ensure our buffer estimate was valid */
5121     arg = fpc - fops;
5122     { /* need to jump to the next word */
5123         int z;
5124         z = WORD_ALIGN - SvCUR(sv) % WORD_ALIGN;
5125         SvGROW(sv, SvCUR(sv) + z + arg * sizeof(U32) + 4);
5126         s = SvPVX(sv) + SvCUR(sv) + z;
5127     }
5128     Copy(fops, s, arg, U32);
5129     Safefree(fops);
5130     sv_magic(sv, NULL, PERL_MAGIC_fm, NULL, 0);
5131     SvCOMPILED_on(sv);
5132
5133     if (unchopnum && repeat)
5134         DIE(aTHX_ "Repeated format line will never terminate (~~ and @#)");
5135     return 0;
5136 }
5137
5138
5139 STATIC bool
5140 S_num_overflow(NV value, I32 fldsize, I32 frcsize)
5141 {
5142     /* Can value be printed in fldsize chars, using %*.*f ? */
5143     NV pwr = 1;
5144     NV eps = 0.5;
5145     bool res = FALSE;
5146     int intsize = fldsize - (value < 0 ? 1 : 0);
5147
5148     if (frcsize & 256)
5149         intsize--;
5150     frcsize &= 255;
5151     intsize -= frcsize;
5152
5153     while (intsize--) pwr *= 10.0;
5154     while (frcsize--) eps /= 10.0;
5155
5156     if( value >= 0 ){
5157         if (value + eps >= pwr)
5158             res = TRUE;
5159     } else {
5160         if (value - eps <= -pwr)
5161             res = TRUE;
5162     }
5163     return res;
5164 }
5165
5166 static I32
5167 S_run_user_filter(pTHX_ int idx, SV *buf_sv, int maxlen)
5168 {
5169     dVAR;
5170     SV * const datasv = FILTER_DATA(idx);
5171     const int filter_has_file = IoLINES(datasv);
5172     SV * const filter_state = MUTABLE_SV(IoTOP_GV(datasv));
5173     SV * const filter_sub = MUTABLE_SV(IoBOTTOM_GV(datasv));
5174     int status = 0;
5175     SV *upstream;
5176     STRLEN got_len;
5177     char *got_p = NULL;
5178     char *prune_from = NULL;
5179     bool read_from_cache = FALSE;
5180     STRLEN umaxlen;
5181
5182     PERL_ARGS_ASSERT_RUN_USER_FILTER;
5183
5184     assert(maxlen >= 0);
5185     umaxlen = maxlen;
5186
5187     /* I was having segfault trouble under Linux 2.2.5 after a
5188        parse error occured.  (Had to hack around it with a test
5189        for PL_parser->error_count == 0.)  Solaris doesn't segfault --
5190        not sure where the trouble is yet.  XXX */
5191
5192     {
5193         SV *const cache = datasv;
5194         if (SvOK(cache)) {
5195             STRLEN cache_len;
5196             const char *cache_p = SvPV(cache, cache_len);
5197             STRLEN take = 0;
5198
5199             if (umaxlen) {
5200                 /* Running in block mode and we have some cached data already.
5201                  */
5202                 if (cache_len >= umaxlen) {
5203                     /* In fact, so much data we don't even need to call
5204                        filter_read.  */
5205                     take = umaxlen;
5206                 }
5207             } else {
5208                 const char *const first_nl =
5209                     (const char *)memchr(cache_p, '\n', cache_len);
5210                 if (first_nl) {
5211                     take = first_nl + 1 - cache_p;
5212                 }
5213             }
5214             if (take) {
5215                 sv_catpvn(buf_sv, cache_p, take);
5216                 sv_chop(cache, cache_p + take);
5217                 /* Definitely not EOF  */
5218                 return 1;
5219             }
5220
5221             sv_catsv(buf_sv, cache);
5222             if (umaxlen) {
5223                 umaxlen -= cache_len;
5224             }
5225             SvOK_off(cache);
5226             read_from_cache = TRUE;
5227         }
5228     }
5229
5230     /* Filter API says that the filter appends to the contents of the buffer.
5231        Usually the buffer is "", so the details don't matter. But if it's not,
5232        then clearly what it contains is already filtered by this filter, so we
5233        don't want to pass it in a second time.
5234        I'm going to use a mortal in case the upstream filter croaks.  */
5235     upstream = ((SvOK(buf_sv) && sv_len(buf_sv)) || SvGMAGICAL(buf_sv))
5236         ? sv_newmortal() : buf_sv;
5237     SvUPGRADE(upstream, SVt_PV);
5238
5239     if (filter_has_file) {
5240         status = FILTER_READ(idx+1, upstream, 0);
5241     }
5242
5243     if (filter_sub && status >= 0) {
5244         dSP;
5245         int count;
5246
5247         ENTER_with_name("call_filter_sub");
5248         SAVE_DEFSV;
5249         SAVETMPS;
5250         EXTEND(SP, 2);
5251
5252         DEFSV_set(upstream);
5253         PUSHMARK(SP);
5254         mPUSHi(0);
5255         if (filter_state) {
5256             PUSHs(filter_state);
5257         }
5258         PUTBACK;
5259         count = call_sv(filter_sub, G_SCALAR);
5260         SPAGAIN;
5261
5262         if (count > 0) {
5263             SV *out = POPs;
5264             if (SvOK(out)) {
5265                 status = SvIV(out);
5266             }
5267         }
5268
5269         PUTBACK;
5270         FREETMPS;
5271         LEAVE_with_name("call_filter_sub");
5272     }
5273
5274     if(SvOK(upstream)) {
5275         got_p = SvPV(upstream, got_len);
5276         if (umaxlen) {
5277             if (got_len > umaxlen) {
5278                 prune_from = got_p + umaxlen;
5279             }
5280         } else {
5281             char *const first_nl = (char *)memchr(got_p, '\n', got_len);
5282             if (first_nl && first_nl + 1 < got_p + got_len) {
5283                 /* There's a second line here... */
5284                 prune_from = first_nl + 1;
5285             }
5286         }
5287     }
5288     if (prune_from) {
5289         /* Oh. Too long. Stuff some in our cache.  */
5290         STRLEN cached_len = got_p + got_len - prune_from;
5291         SV *const cache = datasv;
5292
5293         if (SvOK(cache)) {
5294             /* Cache should be empty.  */
5295             assert(!SvCUR(cache));
5296         }
5297
5298         sv_setpvn(cache, prune_from, cached_len);
5299         /* If you ask for block mode, you may well split UTF-8 characters.
5300            "If it breaks, you get to keep both parts"
5301            (Your code is broken if you  don't put them back together again
5302            before something notices.) */
5303         if (SvUTF8(upstream)) {
5304             SvUTF8_on(cache);
5305         }
5306         SvCUR_set(upstream, got_len - cached_len);
5307         *prune_from = 0;
5308         /* Can't yet be EOF  */
5309         if (status == 0)
5310             status = 1;
5311     }
5312
5313     /* If they are at EOF but buf_sv has something in it, then they may never
5314        have touched the SV upstream, so it may be undefined.  If we naively
5315        concatenate it then we get a warning about use of uninitialised value.
5316     */
5317     if (upstream != buf_sv && (SvOK(upstream) || SvGMAGICAL(upstream))) {
5318         sv_catsv(buf_sv, upstream);
5319     }
5320
5321     if (status <= 0) {
5322         IoLINES(datasv) = 0;
5323         if (filter_state) {
5324             SvREFCNT_dec(filter_state);
5325             IoTOP_GV(datasv) = NULL;
5326         }
5327         if (filter_sub) {
5328             SvREFCNT_dec(filter_sub);
5329             IoBOTTOM_GV(datasv) = NULL;
5330         }
5331         filter_del(S_run_user_filter);
5332     }
5333     if (status == 0 && read_from_cache) {
5334         /* If we read some data from the cache (and by getting here it implies
5335            that we emptied the cache) then we aren't yet at EOF, and mustn't
5336            report that to our caller.  */
5337         return 1;
5338     }
5339     return status;
5340 }
5341
5342 /* perhaps someone can come up with a better name for
5343    this?  it is not really "absolute", per se ... */
5344 static bool
5345 S_path_is_absolute(const char *name)
5346 {
5347     PERL_ARGS_ASSERT_PATH_IS_ABSOLUTE;
5348
5349     if (PERL_FILE_IS_ABSOLUTE(name)
5350 #ifdef WIN32
5351         || (*name == '.' && ((name[1] == '/' ||
5352                              (name[1] == '.' && name[2] == '/'))
5353                          || (name[1] == '\\' ||
5354                              ( name[1] == '.' && name[2] == '\\')))
5355             )
5356 #else
5357         || (*name == '.' && (name[1] == '/' ||
5358                              (name[1] == '.' && name[2] == '/')))
5359 #endif
5360          )
5361     {
5362         return TRUE;
5363     }
5364     else
5365         return FALSE;
5366 }
5367
5368 /*
5369  * Local variables:
5370  * c-indentation-style: bsd
5371  * c-basic-offset: 4
5372  * indent-tabs-mode: t
5373  * End:
5374  *
5375  * ex: set ts=8 sts=4 sw=4 noet:
5376  */