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_newmortal();
3471         Stat_t pmcstat;
3472
3473         SvSetSV_nosteal(pmcsv,name);
3474         sv_catpvn(pmcsv, "c", 1);
3475
3476         if (PerlLIO_stat(SvPV_nolen_const(pmcsv), &pmcstat) >= 0)
3477             return check_type_and_open(pmcsv);
3478     }
3479     return check_type_and_open(name);
3480 }
3481 #else
3482 #  define doopen_pm(name) check_type_and_open(name)
3483 #endif /* !PERL_DISABLE_PMC */
3484
3485 PP(pp_require)
3486 {
3487     dVAR; dSP;
3488     register PERL_CONTEXT *cx;
3489     SV *sv;
3490     const char *name;
3491     STRLEN len;
3492     char * unixname;
3493     STRLEN unixlen;
3494 #ifdef VMS
3495     int vms_unixname = 0;
3496 #endif
3497     const char *tryname = NULL;
3498     SV *namesv = NULL;
3499     const I32 gimme = GIMME_V;
3500     int filter_has_file = 0;
3501     PerlIO *tryrsfp = NULL;
3502     SV *filter_cache = NULL;
3503     SV *filter_state = NULL;
3504     SV *filter_sub = NULL;
3505     SV *hook_sv = NULL;
3506     SV *encoding;
3507     OP *op;
3508
3509     sv = POPs;
3510     if ( (SvNIOKp(sv) || SvVOK(sv)) && PL_op->op_type != OP_DOFILE) {
3511         sv = sv_2mortal(new_version(sv));
3512         if (!sv_derived_from(PL_patchlevel, "version"))
3513             upg_version(PL_patchlevel, TRUE);
3514         if (cUNOP->op_first->op_type == OP_CONST && cUNOP->op_first->op_private & OPpCONST_NOVER) {
3515             if ( vcmp(sv,PL_patchlevel) <= 0 )
3516                 DIE(aTHX_ "Perls since %"SVf" too modern--this is %"SVf", stopped",
3517                     SVfARG(sv_2mortal(vnormal(sv))),
3518                     SVfARG(sv_2mortal(vnormal(PL_patchlevel)))
3519                 );
3520         }
3521         else {
3522             if ( vcmp(sv,PL_patchlevel) > 0 ) {
3523                 I32 first = 0;
3524                 AV *lav;
3525                 SV * const req = SvRV(sv);
3526                 SV * const pv = *hv_fetchs(MUTABLE_HV(req), "original", FALSE);
3527
3528                 /* get the left hand term */
3529                 lav = MUTABLE_AV(SvRV(*hv_fetchs(MUTABLE_HV(req), "version", FALSE)));
3530
3531                 first  = SvIV(*av_fetch(lav,0,0));
3532                 if (   first > (int)PERL_REVISION    /* probably 'use 6.0' */
3533                     || hv_exists(MUTABLE_HV(req), "qv", 2 ) /* qv style */
3534                     || av_len(lav) > 1               /* FP with > 3 digits */
3535                     || strstr(SvPVX(pv),".0")        /* FP with leading 0 */
3536                    ) {
3537                     DIE(aTHX_ "Perl %"SVf" required--this is only "
3538                         "%"SVf", stopped",
3539                         SVfARG(sv_2mortal(vnormal(req))),
3540                         SVfARG(sv_2mortal(vnormal(PL_patchlevel)))
3541                     );
3542                 }
3543                 else { /* probably 'use 5.10' or 'use 5.8' */
3544                     SV *hintsv;
3545                     I32 second = 0;
3546
3547                     if (av_len(lav)>=1)
3548                         second = SvIV(*av_fetch(lav,1,0));
3549
3550                     second /= second >= 600  ? 100 : 10;
3551                     hintsv = Perl_newSVpvf(aTHX_ "v%d.%d.0",
3552                                            (int)first, (int)second);
3553                     upg_version(hintsv, TRUE);
3554
3555                     DIE(aTHX_ "Perl %"SVf" required (did you mean %"SVf"?)"
3556                         "--this is only %"SVf", stopped",
3557                         SVfARG(sv_2mortal(vnormal(req))),
3558                         SVfARG(sv_2mortal(vnormal(sv_2mortal(hintsv)))),
3559                         SVfARG(sv_2mortal(vnormal(PL_patchlevel)))
3560                     );
3561                 }
3562             }
3563         }
3564
3565         RETPUSHYES;
3566     }
3567     name = SvPV_const(sv, len);
3568     if (!(name && len > 0 && *name))
3569         DIE(aTHX_ "Null filename used");
3570     TAINT_PROPER("require");
3571
3572
3573 #ifdef VMS
3574     /* The key in the %ENV hash is in the syntax of file passed as the argument
3575      * usually this is in UNIX format, but sometimes in VMS format, which
3576      * can result in a module being pulled in more than once.
3577      * To prevent this, the key must be stored in UNIX format if the VMS
3578      * name can be translated to UNIX.
3579      */
3580     if ((unixname = tounixspec(name, NULL)) != NULL) {
3581         unixlen = strlen(unixname);
3582         vms_unixname = 1;
3583     }
3584     else
3585 #endif
3586     {
3587         /* if not VMS or VMS name can not be translated to UNIX, pass it
3588          * through.
3589          */
3590         unixname = (char *) name;
3591         unixlen = len;
3592     }
3593     if (PL_op->op_type == OP_REQUIRE) {
3594         SV * const * const svp = hv_fetch(GvHVn(PL_incgv),
3595                                           unixname, unixlen, 0);
3596         if ( svp ) {
3597             if (*svp != &PL_sv_undef)
3598                 RETPUSHYES;
3599             else
3600                 DIE(aTHX_ "Attempt to reload %s aborted.\n"
3601                             "Compilation failed in require", unixname);
3602         }
3603     }
3604
3605     /* prepare to compile file */
3606
3607     if (path_is_absolute(name)) {
3608         /* At this point, name is SvPVX(sv)  */
3609         tryname = name;
3610         tryrsfp = doopen_pm(sv);
3611     }
3612     if (!tryrsfp) {
3613         AV * const ar = GvAVn(PL_incgv);
3614         I32 i;
3615 #ifdef VMS
3616         if (vms_unixname)
3617 #endif
3618         {
3619             namesv = newSV_type(SVt_PV);
3620             for (i = 0; i <= AvFILL(ar); i++) {
3621                 SV * const dirsv = *av_fetch(ar, i, TRUE);
3622
3623                 if (SvTIED_mg((const SV *)ar, PERL_MAGIC_tied))
3624                     mg_get(dirsv);
3625                 if (SvROK(dirsv)) {
3626                     int count;
3627                     SV **svp;
3628                     SV *loader = dirsv;
3629
3630                     if (SvTYPE(SvRV(loader)) == SVt_PVAV
3631                         && !sv_isobject(loader))
3632                     {
3633                         loader = *av_fetch(MUTABLE_AV(SvRV(loader)), 0, TRUE);
3634                     }
3635
3636                     Perl_sv_setpvf(aTHX_ namesv, "/loader/0x%"UVxf"/%s",
3637                                    PTR2UV(SvRV(dirsv)), name);
3638                     tryname = SvPVX_const(namesv);
3639                     tryrsfp = NULL;
3640
3641                     ENTER_with_name("call_INC");
3642                     SAVETMPS;
3643                     EXTEND(SP, 2);
3644
3645                     PUSHMARK(SP);
3646                     PUSHs(dirsv);
3647                     PUSHs(sv);
3648                     PUTBACK;
3649                     if (sv_isobject(loader))
3650                         count = call_method("INC", G_ARRAY);
3651                     else
3652                         count = call_sv(loader, G_ARRAY);
3653                     SPAGAIN;
3654
3655                     if (count > 0) {
3656                         int i = 0;
3657                         SV *arg;
3658
3659                         SP -= count - 1;
3660                         arg = SP[i++];
3661
3662                         if (SvROK(arg) && (SvTYPE(SvRV(arg)) <= SVt_PVLV)
3663                             && !isGV_with_GP(SvRV(arg))) {
3664                             filter_cache = SvRV(arg);
3665                             SvREFCNT_inc_simple_void_NN(filter_cache);
3666
3667                             if (i < count) {
3668                                 arg = SP[i++];
3669                             }
3670                         }
3671
3672                         if (SvROK(arg) && isGV_with_GP(SvRV(arg))) {
3673                             arg = SvRV(arg);
3674                         }
3675
3676                         if (isGV_with_GP(arg)) {
3677                             IO * const io = GvIO((const GV *)arg);
3678
3679                             ++filter_has_file;
3680
3681                             if (io) {
3682                                 tryrsfp = IoIFP(io);
3683                                 if (IoOFP(io) && IoOFP(io) != IoIFP(io)) {
3684                                     PerlIO_close(IoOFP(io));
3685                                 }
3686                                 IoIFP(io) = NULL;
3687                                 IoOFP(io) = NULL;
3688                             }
3689
3690                             if (i < count) {
3691                                 arg = SP[i++];
3692                             }
3693                         }
3694
3695                         if (SvROK(arg) && SvTYPE(SvRV(arg)) == SVt_PVCV) {
3696                             filter_sub = arg;
3697                             SvREFCNT_inc_simple_void_NN(filter_sub);
3698
3699                             if (i < count) {
3700                                 filter_state = SP[i];
3701                                 SvREFCNT_inc_simple_void(filter_state);
3702                             }
3703                         }
3704
3705                         if (!tryrsfp && (filter_cache || filter_sub)) {
3706                             tryrsfp = PerlIO_open(BIT_BUCKET,
3707                                                   PERL_SCRIPT_MODE);
3708                         }
3709                         SP--;
3710                     }
3711
3712                     PUTBACK;
3713                     FREETMPS;
3714                     LEAVE_with_name("call_INC");
3715
3716                     /* Adjust file name if the hook has set an %INC entry.
3717                        This needs to happen after the FREETMPS above.  */
3718                     svp = hv_fetch(GvHVn(PL_incgv), name, len, 0);
3719                     if (svp)
3720                         tryname = SvPV_nolen_const(*svp);
3721
3722                     if (tryrsfp) {
3723                         hook_sv = dirsv;
3724                         break;
3725                     }
3726
3727                     filter_has_file = 0;
3728                     if (filter_cache) {
3729                         SvREFCNT_dec(filter_cache);
3730                         filter_cache = NULL;
3731                     }
3732                     if (filter_state) {
3733                         SvREFCNT_dec(filter_state);
3734                         filter_state = NULL;
3735                     }
3736                     if (filter_sub) {
3737                         SvREFCNT_dec(filter_sub);
3738                         filter_sub = NULL;
3739                     }
3740                 }
3741                 else {
3742                   if (!path_is_absolute(name)
3743                   ) {
3744                     const char *dir;
3745                     STRLEN dirlen;
3746
3747                     if (SvOK(dirsv)) {
3748                         dir = SvPV_const(dirsv, dirlen);
3749                     } else {
3750                         dir = "";
3751                         dirlen = 0;
3752                     }
3753
3754 #ifdef VMS
3755                     char *unixdir;
3756                     if ((unixdir = tounixpath(dir, NULL)) == NULL)
3757                         continue;
3758                     sv_setpv(namesv, unixdir);
3759                     sv_catpv(namesv, unixname);
3760 #else
3761 #  ifdef __SYMBIAN32__
3762                     if (PL_origfilename[0] &&
3763                         PL_origfilename[1] == ':' &&
3764                         !(dir[0] && dir[1] == ':'))
3765                         Perl_sv_setpvf(aTHX_ namesv,
3766                                        "%c:%s\\%s",
3767                                        PL_origfilename[0],
3768                                        dir, name);
3769                     else
3770                         Perl_sv_setpvf(aTHX_ namesv,
3771                                        "%s\\%s",
3772                                        dir, name);
3773 #  else
3774                     /* The equivalent of
3775                        Perl_sv_setpvf(aTHX_ namesv, "%s/%s", dir, name);
3776                        but without the need to parse the format string, or
3777                        call strlen on either pointer, and with the correct
3778                        allocation up front.  */
3779                     {
3780                         char *tmp = SvGROW(namesv, dirlen + len + 2);
3781
3782                         memcpy(tmp, dir, dirlen);
3783                         tmp +=dirlen;
3784                         *tmp++ = '/';
3785                         /* name came from an SV, so it will have a '\0' at the
3786                            end that we can copy as part of this memcpy().  */
3787                         memcpy(tmp, name, len + 1);
3788
3789                         SvCUR_set(namesv, dirlen + len + 1);
3790                         SvPOK_on(namesv);
3791                     }
3792 #  endif
3793 #endif
3794                     TAINT_PROPER("require");
3795                     tryname = SvPVX_const(namesv);
3796                     tryrsfp = doopen_pm(namesv);
3797                     if (tryrsfp) {
3798                         if (tryname[0] == '.' && tryname[1] == '/') {
3799                             ++tryname;
3800                             while (*++tryname == '/');
3801                         }
3802                         break;
3803                     }
3804                     else if (errno == EMFILE)
3805                         /* no point in trying other paths if out of handles */
3806                         break;
3807                   }
3808                 }
3809             }
3810         }
3811     }
3812     sv_2mortal(namesv);
3813     if (!tryrsfp) {
3814         if (PL_op->op_type == OP_REQUIRE) {
3815             if(errno == EMFILE) {
3816                 /* diag_listed_as: Can't locate %s */
3817                 DIE(aTHX_ "Can't locate %s:   %s", name, Strerror(errno));
3818             } else {
3819                 if (namesv) {                   /* did we lookup @INC? */
3820                     AV * const ar = GvAVn(PL_incgv);
3821                     I32 i;
3822                     SV *const inc = newSVpvs_flags("", SVs_TEMP);
3823                     for (i = 0; i <= AvFILL(ar); i++) {
3824                         sv_catpvs(inc, " ");
3825                         sv_catsv(inc, *av_fetch(ar, i, TRUE));
3826                     }
3827
3828                     /* diag_listed_as: Can't locate %s */
3829                     DIE(aTHX_
3830                         "Can't locate %s in @INC%s%s (@INC contains:%" SVf ")",
3831                         name,
3832                         (memEQ(name + len - 2, ".h", 3)
3833                          ? " (change .h to .ph maybe?) (did you run h2ph?)" : ""),
3834                         (memEQ(name + len - 3, ".ph", 4)
3835                          ? " (did you run h2ph?)" : ""),
3836                         inc
3837                         );
3838                 }
3839             }
3840             DIE(aTHX_ "Can't locate %s", name);
3841         }
3842
3843         RETPUSHUNDEF;
3844     }
3845     else
3846         SETERRNO(0, SS_NORMAL);
3847
3848     /* Assume success here to prevent recursive requirement. */
3849     /* name is never assigned to again, so len is still strlen(name)  */
3850     /* Check whether a hook in @INC has already filled %INC */
3851     if (!hook_sv) {
3852         (void)hv_store(GvHVn(PL_incgv),
3853                        unixname, unixlen, newSVpv(tryname,0),0);
3854     } else {
3855         SV** const svp = hv_fetch(GvHVn(PL_incgv), unixname, unixlen, 0);
3856         if (!svp)
3857             (void)hv_store(GvHVn(PL_incgv),
3858                            unixname, unixlen, SvREFCNT_inc_simple(hook_sv), 0 );
3859     }
3860
3861     ENTER_with_name("eval");
3862     SAVETMPS;
3863     SAVECOPFILE_FREE(&PL_compiling);
3864     CopFILE_set(&PL_compiling, tryname);
3865     lex_start(NULL, tryrsfp, 0);
3866
3867     SAVEHINTS();
3868     PL_hints = 0;
3869     hv_clear(GvHV(PL_hintgv));
3870
3871     SAVECOMPILEWARNINGS();
3872     if (PL_dowarn & G_WARN_ALL_ON)
3873         PL_compiling.cop_warnings = pWARN_ALL ;
3874     else if (PL_dowarn & G_WARN_ALL_OFF)
3875         PL_compiling.cop_warnings = pWARN_NONE ;
3876     else
3877         PL_compiling.cop_warnings = pWARN_STD ;
3878
3879     if (filter_sub || filter_cache) {
3880         /* We can use the SvPV of the filter PVIO itself as our cache, rather
3881            than hanging another SV from it. In turn, filter_add() optionally
3882            takes the SV to use as the filter (or creates a new SV if passed
3883            NULL), so simply pass in whatever value filter_cache has.  */
3884         SV * const datasv = filter_add(S_run_user_filter, filter_cache);
3885         IoLINES(datasv) = filter_has_file;
3886         IoTOP_GV(datasv) = MUTABLE_GV(filter_state);
3887         IoBOTTOM_GV(datasv) = MUTABLE_GV(filter_sub);
3888     }
3889
3890     /* switch to eval mode */
3891     PUSHBLOCK(cx, CXt_EVAL, SP);
3892     PUSHEVAL(cx, name);
3893     cx->blk_eval.retop = PL_op->op_next;
3894
3895     SAVECOPLINE(&PL_compiling);
3896     CopLINE_set(&PL_compiling, 0);
3897
3898     PUTBACK;
3899
3900     /* Store and reset encoding. */
3901     encoding = PL_encoding;
3902     PL_encoding = NULL;
3903
3904     if (doeval(gimme, NULL, NULL, PL_curcop->cop_seq))
3905         op = DOCATCH(PL_eval_start);
3906     else
3907         op = PL_op->op_next;
3908
3909     /* Restore encoding. */
3910     PL_encoding = encoding;
3911
3912     return op;
3913 }
3914
3915 /* This is a op added to hold the hints hash for
3916    pp_entereval. The hash can be modified by the code
3917    being eval'ed, so we return a copy instead. */
3918
3919 PP(pp_hintseval)
3920 {
3921     dVAR;
3922     dSP;
3923     mXPUSHs(MUTABLE_SV(hv_copy_hints_hv(MUTABLE_HV(cSVOP_sv))));
3924     RETURN;
3925 }
3926
3927
3928 PP(pp_entereval)
3929 {
3930     dVAR; dSP;
3931     register PERL_CONTEXT *cx;
3932     SV *sv;
3933     const I32 gimme = GIMME_V;
3934     const U32 was = PL_breakable_sub_gen;
3935     char tbuf[TYPE_DIGITS(long) + 12];
3936     bool saved_delete = FALSE;
3937     char *tmpbuf = tbuf;
3938     STRLEN len;
3939     CV* runcv;
3940     U32 seq;
3941     HV *saved_hh = NULL;
3942
3943     if (PL_op->op_private & OPpEVAL_HAS_HH) {
3944         saved_hh = MUTABLE_HV(SvREFCNT_inc(POPs));
3945     }
3946     sv = POPs;
3947     if (!SvPOK(sv)) {
3948         /* make sure we've got a plain PV (no overload etc) before testing
3949          * for taint. Making a copy here is probably overkill, but better
3950          * safe than sorry */
3951         STRLEN len;
3952         const char * const p = SvPV_const(sv, len);
3953
3954         sv = newSVpvn_flags(p, len, SVs_TEMP | SvUTF8(sv));
3955     }
3956
3957     TAINT_IF(SvTAINTED(sv));
3958     TAINT_PROPER("eval");
3959
3960     ENTER_with_name("eval");
3961     lex_start(sv, NULL, LEX_START_SAME_FILTER);
3962     SAVETMPS;
3963
3964     /* switch to eval mode */
3965
3966     if (PERLDB_NAMEEVAL && CopLINE(PL_curcop)) {
3967         SV * const temp_sv = sv_newmortal();
3968         Perl_sv_setpvf(aTHX_ temp_sv, "_<(eval %lu)[%s:%"IVdf"]",
3969                        (unsigned long)++PL_evalseq,
3970                        CopFILE(PL_curcop), (IV)CopLINE(PL_curcop));
3971         tmpbuf = SvPVX(temp_sv);
3972         len = SvCUR(temp_sv);
3973     }
3974     else
3975         len = my_snprintf(tmpbuf, sizeof(tbuf), "_<(eval %lu)", (unsigned long)++PL_evalseq);
3976     SAVECOPFILE_FREE(&PL_compiling);
3977     CopFILE_set(&PL_compiling, tmpbuf+2);
3978     SAVECOPLINE(&PL_compiling);
3979     CopLINE_set(&PL_compiling, 1);
3980     /* XXX For C<eval "...">s within BEGIN {} blocks, this ends up
3981        deleting the eval's FILEGV from the stash before gv_check() runs
3982        (i.e. before run-time proper). To work around the coredump that
3983        ensues, we always turn GvMULTI_on for any globals that were
3984        introduced within evals. See force_ident(). GSAR 96-10-12 */
3985     SAVEHINTS();
3986     PL_hints = PL_op->op_targ;
3987     if (saved_hh) {
3988         /* SAVEHINTS created a new HV in PL_hintgv, which we need to GC */
3989         SvREFCNT_dec(GvHV(PL_hintgv));
3990         GvHV(PL_hintgv) = saved_hh;
3991     }
3992     SAVECOMPILEWARNINGS();
3993     PL_compiling.cop_warnings = DUP_WARNINGS(PL_curcop->cop_warnings);
3994     cophh_free(CopHINTHASH_get(&PL_compiling));
3995     if (Perl_fetch_cop_label(aTHX_ PL_curcop, NULL, NULL)) {
3996         /* The label, if present, is the first entry on the chain. So rather
3997            than writing a blank label in front of it (which involves an
3998            allocation), just use the next entry in the chain.  */
3999         PL_compiling.cop_hints_hash
4000             = cophh_copy(PL_curcop->cop_hints_hash->refcounted_he_next);
4001         /* Check the assumption that this removed the label.  */
4002         assert(Perl_fetch_cop_label(aTHX_ &PL_compiling, NULL, NULL) == NULL);
4003     }
4004     else
4005         PL_compiling.cop_hints_hash = cophh_copy(PL_curcop->cop_hints_hash);
4006     /* special case: an eval '' executed within the DB package gets lexically
4007      * placed in the first non-DB CV rather than the current CV - this
4008      * allows the debugger to execute code, find lexicals etc, in the
4009      * scope of the code being debugged. Passing &seq gets find_runcv
4010      * to do the dirty work for us */
4011     runcv = find_runcv(&seq);
4012
4013     PUSHBLOCK(cx, (CXt_EVAL|CXp_REAL), SP);
4014     PUSHEVAL(cx, 0);
4015     cx->blk_eval.retop = PL_op->op_next;
4016
4017     /* prepare to compile string */
4018
4019     if ((PERLDB_LINE || PERLDB_SAVESRC) && PL_curstash != PL_debstash)
4020         save_lines(CopFILEAV(&PL_compiling), PL_parser->linestr);
4021     else {
4022         char *const safestr = savepvn(tmpbuf, len);
4023         SAVEDELETE(PL_defstash, safestr, len);
4024         saved_delete = TRUE;
4025     }
4026
4027     PUTBACK;
4028
4029     if (doeval(gimme, NULL, runcv, seq)) {
4030         if (was != PL_breakable_sub_gen /* Some subs defined here. */
4031             ? (PERLDB_LINE || PERLDB_SAVESRC)
4032             :  PERLDB_SAVESRC_NOSUBS) {
4033             /* Retain the filegv we created.  */
4034         } else if (!saved_delete) {
4035             char *const safestr = savepvn(tmpbuf, len);
4036             SAVEDELETE(PL_defstash, safestr, len);
4037         }
4038         return DOCATCH(PL_eval_start);
4039     } else {
4040         /* We have already left the scope set up earlier thanks to the LEAVE
4041            in doeval().  */
4042         if (was != PL_breakable_sub_gen /* Some subs defined here. */
4043             ? (PERLDB_LINE || PERLDB_SAVESRC)
4044             :  PERLDB_SAVESRC_INVALID) {
4045             /* Retain the filegv we created.  */
4046         } else if (!saved_delete) {
4047             (void)hv_delete(PL_defstash, tmpbuf, len, G_DISCARD);
4048         }
4049         return PL_op->op_next;
4050     }
4051 }
4052
4053 PP(pp_leaveeval)
4054 {
4055     dVAR; dSP;
4056     register SV **mark;
4057     SV **newsp;
4058     PMOP *newpm;
4059     I32 gimme;
4060     register PERL_CONTEXT *cx;
4061     OP *retop;
4062     const U8 save_flags = PL_op -> op_flags;
4063     I32 optype;
4064     SV *namesv;
4065
4066     PERL_ASYNC_CHECK();
4067     POPBLOCK(cx,newpm);
4068     POPEVAL(cx);
4069     namesv = cx->blk_eval.old_namesv;
4070     retop = cx->blk_eval.retop;
4071
4072     TAINT_NOT;
4073     if (gimme == G_VOID)
4074         MARK = newsp;
4075     else if (gimme == G_SCALAR) {
4076         MARK = newsp + 1;
4077         if (MARK <= SP) {
4078             if (SvFLAGS(TOPs) & SVs_TEMP)
4079                 *MARK = TOPs;
4080             else
4081                 *MARK = sv_mortalcopy(TOPs);
4082         }
4083         else {
4084             MEXTEND(mark,0);
4085             *MARK = &PL_sv_undef;
4086         }
4087         SP = MARK;
4088     }
4089     else {
4090         /* in case LEAVE wipes old return values */
4091         for (mark = newsp + 1; mark <= SP; mark++) {
4092             if (!(SvFLAGS(*mark) & SVs_TEMP)) {
4093                 *mark = sv_mortalcopy(*mark);
4094                 TAINT_NOT;      /* Each item is independent */
4095             }
4096         }
4097     }
4098     PL_curpm = newpm;   /* Don't pop $1 et al till now */
4099
4100 #ifdef DEBUGGING
4101     assert(CvDEPTH(PL_compcv) == 1);
4102 #endif
4103     CvDEPTH(PL_compcv) = 0;
4104
4105     if (optype == OP_REQUIRE &&
4106         !(gimme == G_SCALAR ? SvTRUE(*SP) : SP > newsp))
4107     {
4108         /* Unassume the success we assumed earlier. */
4109         (void)hv_delete(GvHVn(PL_incgv),
4110                         SvPVX_const(namesv), SvCUR(namesv),
4111                         G_DISCARD);
4112         retop = Perl_die(aTHX_ "%"SVf" did not return a true value",
4113                                SVfARG(namesv));
4114         /* die_unwind() did LEAVE, or we won't be here */
4115     }
4116     else {
4117         LEAVE_with_name("eval");
4118         if (!(save_flags & OPf_SPECIAL)) {
4119             CLEAR_ERRSV();
4120         }
4121     }
4122
4123     RETURNOP(retop);
4124 }
4125
4126 /* Common code for Perl_call_sv and Perl_fold_constants, put here to keep it
4127    close to the related Perl_create_eval_scope.  */
4128 void
4129 Perl_delete_eval_scope(pTHX)
4130 {
4131     SV **newsp;
4132     PMOP *newpm;
4133     I32 gimme;
4134     register PERL_CONTEXT *cx;
4135     I32 optype;
4136
4137     POPBLOCK(cx,newpm);
4138     POPEVAL(cx);
4139     PL_curpm = newpm;
4140     LEAVE_with_name("eval_scope");
4141     PERL_UNUSED_VAR(newsp);
4142     PERL_UNUSED_VAR(gimme);
4143     PERL_UNUSED_VAR(optype);
4144 }
4145
4146 /* Common-ish code salvaged from Perl_call_sv and pp_entertry, because it was
4147    also needed by Perl_fold_constants.  */
4148 PERL_CONTEXT *
4149 Perl_create_eval_scope(pTHX_ U32 flags)
4150 {
4151     PERL_CONTEXT *cx;
4152     const I32 gimme = GIMME_V;
4153
4154     ENTER_with_name("eval_scope");
4155     SAVETMPS;
4156
4157     PUSHBLOCK(cx, (CXt_EVAL|CXp_TRYBLOCK), PL_stack_sp);
4158     PUSHEVAL(cx, 0);
4159
4160     PL_in_eval = EVAL_INEVAL;
4161     if (flags & G_KEEPERR)
4162         PL_in_eval |= EVAL_KEEPERR;
4163     else
4164         CLEAR_ERRSV();
4165     if (flags & G_FAKINGEVAL) {
4166         PL_eval_root = PL_op; /* Only needed so that goto works right. */
4167     }
4168     return cx;
4169 }
4170
4171 PP(pp_entertry)
4172 {
4173     dVAR;
4174     PERL_CONTEXT * const cx = create_eval_scope(0);
4175     cx->blk_eval.retop = cLOGOP->op_other->op_next;
4176     return DOCATCH(PL_op->op_next);
4177 }
4178
4179 PP(pp_leavetry)
4180 {
4181     dVAR; dSP;
4182     SV **newsp;
4183     PMOP *newpm;
4184     I32 gimme;
4185     register PERL_CONTEXT *cx;
4186     I32 optype;
4187
4188     PERL_ASYNC_CHECK();
4189     POPBLOCK(cx,newpm);
4190     POPEVAL(cx);
4191     PERL_UNUSED_VAR(optype);
4192
4193     TAINT_NOT;
4194     if (gimme == G_VOID)
4195         SP = newsp;
4196     else if (gimme == G_SCALAR) {
4197         register SV **mark;
4198         MARK = newsp + 1;
4199         if (MARK <= SP) {
4200             if (SvFLAGS(TOPs) & (SVs_PADTMP|SVs_TEMP))
4201                 *MARK = TOPs;
4202             else
4203                 *MARK = sv_mortalcopy(TOPs);
4204         }
4205         else {
4206             MEXTEND(mark,0);
4207             *MARK = &PL_sv_undef;
4208         }
4209         SP = MARK;
4210     }
4211     else {
4212         /* in case LEAVE wipes old return values */
4213         register SV **mark;
4214         for (mark = newsp + 1; mark <= SP; mark++) {
4215             if (!(SvFLAGS(*mark) & (SVs_PADTMP|SVs_TEMP))) {
4216                 *mark = sv_mortalcopy(*mark);
4217                 TAINT_NOT;      /* Each item is independent */
4218             }
4219         }
4220     }
4221     PL_curpm = newpm;   /* Don't pop $1 et al till now */
4222
4223     LEAVE_with_name("eval_scope");
4224     CLEAR_ERRSV();
4225     RETURN;
4226 }
4227
4228 PP(pp_entergiven)
4229 {
4230     dVAR; dSP;
4231     register PERL_CONTEXT *cx;
4232     const I32 gimme = GIMME_V;
4233
4234     ENTER_with_name("given");
4235     SAVETMPS;
4236
4237     sv_setsv(PAD_SV(PL_op->op_targ), POPs);
4238
4239     PUSHBLOCK(cx, CXt_GIVEN, SP);
4240     PUSHGIVEN(cx);
4241
4242     RETURN;
4243 }
4244
4245 PP(pp_leavegiven)
4246 {
4247     dVAR; dSP;
4248     register PERL_CONTEXT *cx;
4249     I32 gimme;
4250     SV **newsp;
4251     PMOP *newpm;
4252     PERL_UNUSED_CONTEXT;
4253
4254     POPBLOCK(cx,newpm);
4255     assert(CxTYPE(cx) == CXt_GIVEN);
4256
4257     TAINT_NOT;
4258     if (gimme == G_VOID)
4259         SP = newsp;
4260     else if (gimme == G_SCALAR) {
4261         register SV **mark;
4262         MARK = newsp + 1;
4263         if (MARK <= SP) {
4264             if (SvFLAGS(TOPs) & (SVs_PADTMP|SVs_TEMP))
4265                 *MARK = TOPs;
4266             else
4267                 *MARK = sv_mortalcopy(TOPs);
4268         }
4269         else {
4270             MEXTEND(mark,0);
4271             *MARK = &PL_sv_undef;
4272         }
4273         SP = MARK;
4274     }
4275     else {
4276         /* in case LEAVE wipes old return values */
4277         register SV **mark;
4278         for (mark = newsp + 1; mark <= SP; mark++) {
4279             if (!(SvFLAGS(*mark) & (SVs_PADTMP|SVs_TEMP))) {
4280                 *mark = sv_mortalcopy(*mark);
4281                 TAINT_NOT;      /* Each item is independent */
4282             }
4283         }
4284     }
4285     PL_curpm = newpm;   /* Don't pop $1 et al till now */
4286
4287     LEAVE_with_name("given");
4288     RETURN;
4289 }
4290
4291 /* Helper routines used by pp_smartmatch */
4292 STATIC PMOP *
4293 S_make_matcher(pTHX_ REGEXP *re)
4294 {
4295     dVAR;
4296     PMOP *matcher = (PMOP *) newPMOP(OP_MATCH, OPf_WANT_SCALAR | OPf_STACKED);
4297
4298     PERL_ARGS_ASSERT_MAKE_MATCHER;
4299
4300     PM_SETRE(matcher, ReREFCNT_inc(re));
4301
4302     SAVEFREEOP((OP *) matcher);
4303     ENTER_with_name("matcher"); SAVETMPS;
4304     SAVEOP();
4305     return matcher;
4306 }
4307
4308 STATIC bool
4309 S_matcher_matches_sv(pTHX_ PMOP *matcher, SV *sv)
4310 {
4311     dVAR;
4312     dSP;
4313
4314     PERL_ARGS_ASSERT_MATCHER_MATCHES_SV;
4315
4316     PL_op = (OP *) matcher;
4317     XPUSHs(sv);
4318     PUTBACK;
4319     (void) Perl_pp_match(aTHX);
4320     SPAGAIN;
4321     return (SvTRUEx(POPs));
4322 }
4323
4324 STATIC void
4325 S_destroy_matcher(pTHX_ PMOP *matcher)
4326 {
4327     dVAR;
4328
4329     PERL_ARGS_ASSERT_DESTROY_MATCHER;
4330     PERL_UNUSED_ARG(matcher);
4331
4332     FREETMPS;
4333     LEAVE_with_name("matcher");
4334 }
4335
4336 /* Do a smart match */
4337 PP(pp_smartmatch)
4338 {
4339     DEBUG_M(Perl_deb(aTHX_ "Starting smart match resolution\n"));
4340     return do_smartmatch(NULL, NULL);
4341 }
4342
4343 /* This version of do_smartmatch() implements the
4344  * table of smart matches that is found in perlsyn.
4345  */
4346 STATIC OP *
4347 S_do_smartmatch(pTHX_ HV *seen_this, HV *seen_other)
4348 {
4349     dVAR;
4350     dSP;
4351
4352     bool object_on_left = FALSE;
4353     SV *e = TOPs;       /* e is for 'expression' */
4354     SV *d = TOPm1s;     /* d is for 'default', as in PL_defgv */
4355
4356     /* Take care only to invoke mg_get() once for each argument.
4357      * Currently we do this by copying the SV if it's magical. */
4358     if (d) {
4359         if (SvGMAGICAL(d))
4360             d = sv_mortalcopy(d);
4361     }
4362     else
4363         d = &PL_sv_undef;
4364
4365     assert(e);
4366     if (SvGMAGICAL(e))
4367         e = sv_mortalcopy(e);
4368
4369     /* First of all, handle overload magic of the rightmost argument */
4370     if (SvAMAGIC(e)) {
4371         SV * tmpsv;
4372         DEBUG_M(Perl_deb(aTHX_ "    applying rule Any-Object\n"));
4373         DEBUG_M(Perl_deb(aTHX_ "        attempting overload\n"));
4374
4375         tmpsv = amagic_call(d, e, smart_amg, 0);
4376         if (tmpsv) {
4377             SPAGAIN;
4378             (void)POPs;
4379             SETs(tmpsv);
4380             RETURN;
4381         }
4382         DEBUG_M(Perl_deb(aTHX_ "        failed to run overload method; continuing...\n"));
4383     }
4384
4385     SP -= 2;    /* Pop the values */
4386
4387
4388     /* ~~ undef */
4389     if (!SvOK(e)) {
4390         DEBUG_M(Perl_deb(aTHX_ "    applying rule Any-undef\n"));
4391         if (SvOK(d))
4392             RETPUSHNO;
4393         else
4394             RETPUSHYES;
4395     }
4396
4397     if (sv_isobject(e) && (SvTYPE(SvRV(e)) != SVt_REGEXP)) {
4398         DEBUG_M(Perl_deb(aTHX_ "    applying rule Any-Object\n"));
4399         Perl_croak(aTHX_ "Smart matching a non-overloaded object breaks encapsulation");
4400     }
4401     if (sv_isobject(d) && (SvTYPE(SvRV(d)) != SVt_REGEXP))
4402         object_on_left = TRUE;
4403
4404     /* ~~ sub */
4405     if (SvROK(e) && SvTYPE(SvRV(e)) == SVt_PVCV) {
4406         I32 c;
4407         if (object_on_left) {
4408             goto sm_any_sub; /* Treat objects like scalars */
4409         }
4410         else if (SvROK(d) && SvTYPE(SvRV(d)) == SVt_PVHV) {
4411             /* Test sub truth for each key */
4412             HE *he;
4413             bool andedresults = TRUE;
4414             HV *hv = (HV*) SvRV(d);
4415             I32 numkeys = hv_iterinit(hv);
4416             DEBUG_M(Perl_deb(aTHX_ "    applying rule Hash-CodeRef\n"));
4417             if (numkeys == 0)
4418                 RETPUSHYES;
4419             while ( (he = hv_iternext(hv)) ) {
4420                 DEBUG_M(Perl_deb(aTHX_ "        testing hash key...\n"));
4421                 ENTER_with_name("smartmatch_hash_key_test");
4422                 SAVETMPS;
4423                 PUSHMARK(SP);
4424                 PUSHs(hv_iterkeysv(he));
4425                 PUTBACK;
4426                 c = call_sv(e, G_SCALAR);
4427                 SPAGAIN;
4428                 if (c == 0)
4429                     andedresults = FALSE;
4430                 else
4431                     andedresults = SvTRUEx(POPs) && andedresults;
4432                 FREETMPS;
4433                 LEAVE_with_name("smartmatch_hash_key_test");
4434             }
4435             if (andedresults)
4436                 RETPUSHYES;
4437             else
4438                 RETPUSHNO;
4439         }
4440         else if (SvROK(d) && SvTYPE(SvRV(d)) == SVt_PVAV) {
4441             /* Test sub truth for each element */
4442             I32 i;
4443             bool andedresults = TRUE;
4444             AV *av = (AV*) SvRV(d);
4445             const I32 len = av_len(av);
4446             DEBUG_M(Perl_deb(aTHX_ "    applying rule Array-CodeRef\n"));
4447             if (len == -1)
4448                 RETPUSHYES;
4449             for (i = 0; i <= len; ++i) {
4450                 SV * const * const svp = av_fetch(av, i, FALSE);
4451                 DEBUG_M(Perl_deb(aTHX_ "        testing array element...\n"));
4452                 ENTER_with_name("smartmatch_array_elem_test");
4453                 SAVETMPS;
4454                 PUSHMARK(SP);
4455                 if (svp)
4456                     PUSHs(*svp);
4457                 PUTBACK;
4458                 c = call_sv(e, G_SCALAR);
4459                 SPAGAIN;
4460                 if (c == 0)
4461                     andedresults = FALSE;
4462                 else
4463                     andedresults = SvTRUEx(POPs) && andedresults;
4464                 FREETMPS;
4465                 LEAVE_with_name("smartmatch_array_elem_test");
4466             }
4467             if (andedresults)
4468                 RETPUSHYES;
4469             else
4470                 RETPUSHNO;
4471         }
4472         else {
4473           sm_any_sub:
4474             DEBUG_M(Perl_deb(aTHX_ "    applying rule Any-CodeRef\n"));
4475             ENTER_with_name("smartmatch_coderef");
4476             SAVETMPS;
4477             PUSHMARK(SP);
4478             PUSHs(d);
4479             PUTBACK;
4480             c = call_sv(e, G_SCALAR);
4481             SPAGAIN;
4482             if (c == 0)
4483                 PUSHs(&PL_sv_no);
4484             else if (SvTEMP(TOPs))
4485                 SvREFCNT_inc_void(TOPs);
4486             FREETMPS;
4487             LEAVE_with_name("smartmatch_coderef");
4488             RETURN;
4489         }
4490     }
4491     /* ~~ %hash */
4492     else if (SvROK(e) && SvTYPE(SvRV(e)) == SVt_PVHV) {
4493         if (object_on_left) {
4494             goto sm_any_hash; /* Treat objects like scalars */
4495         }
4496         else if (!SvOK(d)) {
4497             DEBUG_M(Perl_deb(aTHX_ "    applying rule Any-Hash ($a undef)\n"));
4498             RETPUSHNO;
4499         }
4500         else if (SvROK(d) && SvTYPE(SvRV(d)) == SVt_PVHV) {
4501             /* Check that the key-sets are identical */
4502             HE *he;
4503             HV *other_hv = MUTABLE_HV(SvRV(d));
4504             bool tied = FALSE;
4505             bool other_tied = FALSE;
4506             U32 this_key_count  = 0,
4507                 other_key_count = 0;
4508             HV *hv = MUTABLE_HV(SvRV(e));
4509
4510             DEBUG_M(Perl_deb(aTHX_ "    applying rule Hash-Hash\n"));
4511             /* Tied hashes don't know how many keys they have. */
4512             if (SvTIED_mg((SV*)hv, PERL_MAGIC_tied)) {
4513                 tied = TRUE;
4514             }
4515             else if (SvTIED_mg((const SV *)other_hv, PERL_MAGIC_tied)) {
4516                 HV * const temp = other_hv;
4517                 other_hv = hv;
4518                 hv = temp;
4519                 tied = TRUE;
4520             }
4521             if (SvTIED_mg((const SV *)other_hv, PERL_MAGIC_tied))
4522                 other_tied = TRUE;
4523
4524             if (!tied && HvUSEDKEYS((const HV *) hv) != HvUSEDKEYS(other_hv))
4525                 RETPUSHNO;
4526
4527             /* The hashes have the same number of keys, so it suffices
4528                to check that one is a subset of the other. */
4529             (void) hv_iterinit(hv);
4530             while ( (he = hv_iternext(hv)) ) {
4531                 SV *key = hv_iterkeysv(he);
4532
4533                 DEBUG_M(Perl_deb(aTHX_ "        comparing hash key...\n"));
4534                 ++ this_key_count;
4535
4536                 if(!hv_exists_ent(other_hv, key, 0)) {
4537                     (void) hv_iterinit(hv);     /* reset iterator */
4538                     RETPUSHNO;
4539                 }
4540             }
4541
4542             if (other_tied) {
4543                 (void) hv_iterinit(other_hv);
4544                 while ( hv_iternext(other_hv) )
4545                     ++other_key_count;
4546             }
4547             else
4548                 other_key_count = HvUSEDKEYS(other_hv);
4549
4550             if (this_key_count != other_key_count)
4551                 RETPUSHNO;
4552             else
4553                 RETPUSHYES;
4554         }
4555         else if (SvROK(d) && SvTYPE(SvRV(d)) == SVt_PVAV) {
4556             AV * const other_av = MUTABLE_AV(SvRV(d));
4557             const I32 other_len = av_len(other_av) + 1;
4558             I32 i;
4559             HV *hv = MUTABLE_HV(SvRV(e));
4560
4561             DEBUG_M(Perl_deb(aTHX_ "    applying rule Array-Hash\n"));
4562             for (i = 0; i < other_len; ++i) {
4563                 SV ** const svp = av_fetch(other_av, i, FALSE);
4564                 DEBUG_M(Perl_deb(aTHX_ "        checking for key existence...\n"));
4565                 if (svp) {      /* ??? When can this not happen? */
4566                     if (hv_exists_ent(hv, *svp, 0))
4567                         RETPUSHYES;
4568                 }
4569             }
4570             RETPUSHNO;
4571         }
4572         else if (SvROK(d) && SvTYPE(SvRV(d)) == SVt_REGEXP) {
4573             DEBUG_M(Perl_deb(aTHX_ "    applying rule Regex-Hash\n"));
4574           sm_regex_hash:
4575             {
4576                 PMOP * const matcher = make_matcher((REGEXP*) SvRV(d));
4577                 HE *he;
4578                 HV *hv = MUTABLE_HV(SvRV(e));
4579
4580                 (void) hv_iterinit(hv);
4581                 while ( (he = hv_iternext(hv)) ) {
4582                     DEBUG_M(Perl_deb(aTHX_ "        testing key against pattern...\n"));
4583                     if (matcher_matches_sv(matcher, hv_iterkeysv(he))) {
4584                         (void) hv_iterinit(hv);
4585                         destroy_matcher(matcher);
4586                         RETPUSHYES;
4587                     }
4588                 }
4589                 destroy_matcher(matcher);
4590                 RETPUSHNO;
4591             }
4592         }
4593         else {
4594           sm_any_hash:
4595             DEBUG_M(Perl_deb(aTHX_ "    applying rule Any-Hash\n"));
4596             if (hv_exists_ent(MUTABLE_HV(SvRV(e)), d, 0))
4597                 RETPUSHYES;
4598             else
4599                 RETPUSHNO;
4600         }
4601     }
4602     /* ~~ @array */
4603     else if (SvROK(e) && SvTYPE(SvRV(e)) == SVt_PVAV) {
4604         if (object_on_left) {
4605             goto sm_any_array; /* Treat objects like scalars */
4606         }
4607         else if (SvROK(d) && SvTYPE(SvRV(d)) == SVt_PVHV) {
4608             AV * const other_av = MUTABLE_AV(SvRV(e));
4609             const I32 other_len = av_len(other_av) + 1;
4610             I32 i;
4611
4612             DEBUG_M(Perl_deb(aTHX_ "    applying rule Hash-Array\n"));
4613             for (i = 0; i < other_len; ++i) {
4614                 SV ** const svp = av_fetch(other_av, i, FALSE);
4615
4616                 DEBUG_M(Perl_deb(aTHX_ "        testing for key existence...\n"));
4617                 if (svp) {      /* ??? When can this not happen? */
4618                     if (hv_exists_ent(MUTABLE_HV(SvRV(d)), *svp, 0))
4619                         RETPUSHYES;
4620                 }
4621             }
4622             RETPUSHNO;
4623         }
4624         if (SvROK(d) && SvTYPE(SvRV(d)) == SVt_PVAV) {
4625             AV *other_av = MUTABLE_AV(SvRV(d));
4626             DEBUG_M(Perl_deb(aTHX_ "    applying rule Array-Array\n"));
4627             if (av_len(MUTABLE_AV(SvRV(e))) != av_len(other_av))
4628                 RETPUSHNO;
4629             else {
4630                 I32 i;
4631                 const I32 other_len = av_len(other_av);
4632
4633                 if (NULL == seen_this) {
4634                     seen_this = newHV();
4635                     (void) sv_2mortal(MUTABLE_SV(seen_this));
4636                 }
4637                 if (NULL == seen_other) {
4638                     seen_other = newHV();
4639                     (void) sv_2mortal(MUTABLE_SV(seen_other));
4640                 }
4641                 for(i = 0; i <= other_len; ++i) {
4642                     SV * const * const this_elem = av_fetch(MUTABLE_AV(SvRV(e)), i, FALSE);
4643                     SV * const * const other_elem = av_fetch(other_av, i, FALSE);
4644
4645                     if (!this_elem || !other_elem) {
4646                         if ((this_elem && SvOK(*this_elem))
4647                                 || (other_elem && SvOK(*other_elem)))
4648                             RETPUSHNO;
4649                     }
4650                     else if (hv_exists_ent(seen_this,
4651                                 sv_2mortal(newSViv(PTR2IV(*this_elem))), 0) ||
4652                             hv_exists_ent(seen_other,
4653                                 sv_2mortal(newSViv(PTR2IV(*other_elem))), 0))
4654                     {
4655                         if (*this_elem != *other_elem)
4656                             RETPUSHNO;
4657                     }
4658                     else {
4659                         (void)hv_store_ent(seen_this,
4660                                 sv_2mortal(newSViv(PTR2IV(*this_elem))),
4661                                 &PL_sv_undef, 0);
4662                         (void)hv_store_ent(seen_other,
4663                                 sv_2mortal(newSViv(PTR2IV(*other_elem))),
4664                                 &PL_sv_undef, 0);
4665                         PUSHs(*other_elem);
4666                         PUSHs(*this_elem);
4667
4668                         PUTBACK;
4669                         DEBUG_M(Perl_deb(aTHX_ "        recursively comparing array element...\n"));
4670                         (void) do_smartmatch(seen_this, seen_other);
4671                         SPAGAIN;
4672                         DEBUG_M(Perl_deb(aTHX_ "        recursion finished\n"));
4673
4674                         if (!SvTRUEx(POPs))
4675                             RETPUSHNO;
4676                     }
4677                 }
4678                 RETPUSHYES;
4679             }
4680         }
4681         else if (SvROK(d) && SvTYPE(SvRV(d)) == SVt_REGEXP) {
4682             DEBUG_M(Perl_deb(aTHX_ "    applying rule Regex-Array\n"));
4683           sm_regex_array:
4684             {
4685                 PMOP * const matcher = make_matcher((REGEXP*) SvRV(d));
4686                 const I32 this_len = av_len(MUTABLE_AV(SvRV(e)));
4687                 I32 i;
4688
4689                 for(i = 0; i <= this_len; ++i) {
4690                     SV * const * const svp = av_fetch(MUTABLE_AV(SvRV(e)), i, FALSE);
4691                     DEBUG_M(Perl_deb(aTHX_ "        testing element against pattern...\n"));
4692                     if (svp && matcher_matches_sv(matcher, *svp)) {
4693                         destroy_matcher(matcher);
4694                         RETPUSHYES;
4695                     }
4696                 }
4697                 destroy_matcher(matcher);
4698                 RETPUSHNO;
4699             }
4700         }
4701         else if (!SvOK(d)) {
4702             /* undef ~~ array */
4703             const I32 this_len = av_len(MUTABLE_AV(SvRV(e)));
4704             I32 i;
4705
4706             DEBUG_M(Perl_deb(aTHX_ "    applying rule Undef-Array\n"));
4707             for (i = 0; i <= this_len; ++i) {
4708                 SV * const * const svp = av_fetch(MUTABLE_AV(SvRV(e)), i, FALSE);
4709                 DEBUG_M(Perl_deb(aTHX_ "        testing for undef element...\n"));
4710                 if (!svp || !SvOK(*svp))
4711                     RETPUSHYES;
4712             }
4713             RETPUSHNO;
4714         }
4715         else {
4716           sm_any_array:
4717             {
4718                 I32 i;
4719                 const I32 this_len = av_len(MUTABLE_AV(SvRV(e)));
4720
4721                 DEBUG_M(Perl_deb(aTHX_ "    applying rule Any-Array\n"));
4722                 for (i = 0; i <= this_len; ++i) {
4723                     SV * const * const svp = av_fetch(MUTABLE_AV(SvRV(e)), i, FALSE);
4724                     if (!svp)
4725                         continue;
4726
4727                     PUSHs(d);
4728                     PUSHs(*svp);
4729                     PUTBACK;
4730                     /* infinite recursion isn't supposed to happen here */
4731                     DEBUG_M(Perl_deb(aTHX_ "        recursively testing array element...\n"));
4732                     (void) do_smartmatch(NULL, NULL);
4733                     SPAGAIN;
4734                     DEBUG_M(Perl_deb(aTHX_ "        recursion finished\n"));
4735                     if (SvTRUEx(POPs))
4736                         RETPUSHYES;
4737                 }
4738                 RETPUSHNO;
4739             }
4740         }
4741     }
4742     /* ~~ qr// */
4743     else if (SvROK(e) && SvTYPE(SvRV(e)) == SVt_REGEXP) {
4744         if (!object_on_left && SvROK(d) && SvTYPE(SvRV(d)) == SVt_PVHV) {
4745             SV *t = d; d = e; e = t;
4746             DEBUG_M(Perl_deb(aTHX_ "    applying rule Hash-Regex\n"));
4747             goto sm_regex_hash;
4748         }
4749         else if (!object_on_left && SvROK(d) && SvTYPE(SvRV(d)) == SVt_PVAV) {
4750             SV *t = d; d = e; e = t;
4751             DEBUG_M(Perl_deb(aTHX_ "    applying rule Array-Regex\n"));
4752             goto sm_regex_array;
4753         }
4754         else {
4755             PMOP * const matcher = make_matcher((REGEXP*) SvRV(e));
4756
4757             DEBUG_M(Perl_deb(aTHX_ "    applying rule Any-Regex\n"));
4758             PUTBACK;
4759             PUSHs(matcher_matches_sv(matcher, d)
4760                     ? &PL_sv_yes
4761                     : &PL_sv_no);
4762             destroy_matcher(matcher);
4763             RETURN;
4764         }
4765     }
4766     /* ~~ scalar */
4767     /* See if there is overload magic on left */
4768     else if (object_on_left && SvAMAGIC(d)) {
4769         SV *tmpsv;
4770         DEBUG_M(Perl_deb(aTHX_ "    applying rule Object-Any\n"));
4771         DEBUG_M(Perl_deb(aTHX_ "        attempting overload\n"));
4772         PUSHs(d); PUSHs(e);
4773         PUTBACK;
4774         tmpsv = amagic_call(d, e, smart_amg, AMGf_noright);
4775         if (tmpsv) {
4776             SPAGAIN;
4777             (void)POPs;
4778             SETs(tmpsv);
4779             RETURN;
4780         }
4781         SP -= 2;
4782         DEBUG_M(Perl_deb(aTHX_ "        failed to run overload method; falling back...\n"));
4783         goto sm_any_scalar;
4784     }
4785     else if (!SvOK(d)) {
4786         /* undef ~~ scalar ; we already know that the scalar is SvOK */
4787         DEBUG_M(Perl_deb(aTHX_ "    applying rule undef-Any\n"));
4788         RETPUSHNO;
4789     }
4790     else
4791   sm_any_scalar:
4792     if (SvNIOK(e) || (SvPOK(e) && looks_like_number(e) && SvNIOK(d))) {
4793         DEBUG_M(if (SvNIOK(e))
4794                     Perl_deb(aTHX_ "    applying rule Any-Num\n");
4795                 else
4796                     Perl_deb(aTHX_ "    applying rule Num-numish\n");
4797         );
4798         /* numeric comparison */
4799         PUSHs(d); PUSHs(e);
4800         PUTBACK;
4801         if (CopHINTS_get(PL_curcop) & HINT_INTEGER)
4802             (void) Perl_pp_i_eq(aTHX);
4803         else
4804             (void) Perl_pp_eq(aTHX);
4805         SPAGAIN;
4806         if (SvTRUEx(POPs))
4807             RETPUSHYES;
4808         else
4809             RETPUSHNO;
4810     }
4811
4812     /* As a last resort, use string comparison */
4813     DEBUG_M(Perl_deb(aTHX_ "    applying rule Any-Any\n"));
4814     PUSHs(d); PUSHs(e);
4815     PUTBACK;
4816     return Perl_pp_seq(aTHX);
4817 }
4818
4819 PP(pp_enterwhen)
4820 {
4821     dVAR; dSP;
4822     register PERL_CONTEXT *cx;
4823     const I32 gimme = GIMME_V;
4824
4825     /* This is essentially an optimization: if the match
4826        fails, we don't want to push a context and then
4827        pop it again right away, so we skip straight
4828        to the op that follows the leavewhen.
4829        RETURNOP calls PUTBACK which restores the stack pointer after the POPs.
4830     */
4831     if ((0 == (PL_op->op_flags & OPf_SPECIAL)) && !SvTRUEx(POPs))
4832         RETURNOP(cLOGOP->op_other->op_next);
4833
4834     ENTER_with_name("eval");
4835     SAVETMPS;
4836
4837     PUSHBLOCK(cx, CXt_WHEN, SP);
4838     PUSHWHEN(cx);
4839
4840     RETURN;
4841 }
4842
4843 PP(pp_leavewhen)
4844 {
4845     dVAR; dSP;
4846     register PERL_CONTEXT *cx;
4847     I32 gimme;
4848     SV **newsp;
4849     PMOP *newpm;
4850
4851     POPBLOCK(cx,newpm);
4852     assert(CxTYPE(cx) == CXt_WHEN);
4853
4854     SP = newsp;
4855     PUTBACK;
4856
4857     PL_curpm = newpm;   /* pop $1 et al */
4858
4859     LEAVE_with_name("eval");
4860     return NORMAL;
4861 }
4862
4863 PP(pp_continue)
4864 {
4865     dVAR;
4866     I32 cxix;
4867     register PERL_CONTEXT *cx;
4868     I32 inner;
4869
4870     cxix = dopoptowhen(cxstack_ix);
4871     if (cxix < 0)
4872         DIE(aTHX_ "Can't \"continue\" outside a when block");
4873     if (cxix < cxstack_ix)
4874         dounwind(cxix);
4875
4876     /* clear off anything above the scope we're re-entering */
4877     inner = PL_scopestack_ix;
4878     TOPBLOCK(cx);
4879     if (PL_scopestack_ix < inner)
4880         leave_scope(PL_scopestack[PL_scopestack_ix]);
4881     PL_curcop = cx->blk_oldcop;
4882     return cx->blk_givwhen.leave_op;
4883 }
4884
4885 PP(pp_break)
4886 {
4887     dVAR;
4888     I32 cxix;
4889     register PERL_CONTEXT *cx;
4890     I32 inner;
4891     dSP;
4892
4893     cxix = dopoptogiven(cxstack_ix);
4894     if (cxix < 0) {
4895         if (PL_op->op_flags & OPf_SPECIAL)
4896             DIE(aTHX_ "Can't use when() outside a topicalizer");
4897         else
4898             DIE(aTHX_ "Can't \"break\" outside a given block");
4899     }
4900     if (CxFOREACH(&cxstack[cxix]) && (0 == (PL_op->op_flags & OPf_SPECIAL)))
4901         DIE(aTHX_ "Can't \"break\" in a loop topicalizer");
4902
4903     if (cxix < cxstack_ix)
4904         dounwind(cxix);
4905
4906     /* clear off anything above the scope we're re-entering */
4907     inner = PL_scopestack_ix;
4908     TOPBLOCK(cx);
4909     if (PL_scopestack_ix < inner)
4910         leave_scope(PL_scopestack[PL_scopestack_ix]);
4911     PL_curcop = cx->blk_oldcop;
4912
4913     if (CxFOREACH(cx))
4914         return (cx)->blk_loop.my_op->op_nextop;
4915     else
4916         /* RETURNOP calls PUTBACK which restores the old old sp */
4917         RETURNOP(cx->blk_givwhen.leave_op);
4918 }
4919
4920 STATIC OP *
4921 S_doparseform(pTHX_ SV *sv)
4922 {
4923     STRLEN len;
4924     register char *s = SvPV_force(sv, len);
4925     register char * const send = s + len;
4926     register char *base = NULL;
4927     register I32 skipspaces = 0;
4928     bool noblank   = FALSE;
4929     bool repeat    = FALSE;
4930     bool postspace = FALSE;
4931     U32 *fops;
4932     register U32 *fpc;
4933     U32 *linepc = NULL;
4934     register I32 arg;
4935     bool ischop;
4936     bool unchopnum = FALSE;
4937     int maxops = 12; /* FF_LINEMARK + FF_END + 10 (\0 without preceding \n) */
4938
4939     PERL_ARGS_ASSERT_DOPARSEFORM;
4940
4941     if (len == 0)
4942         Perl_croak(aTHX_ "Null picture in formline");
4943
4944     /* estimate the buffer size needed */
4945     for (base = s; s <= send; s++) {
4946         if (*s == '\n' || *s == '@' || *s == '^')
4947             maxops += 10;
4948     }
4949     s = base;
4950     base = NULL;
4951
4952     Newx(fops, maxops, U32);
4953     fpc = fops;
4954
4955     if (s < send) {
4956         linepc = fpc;
4957         *fpc++ = FF_LINEMARK;
4958         noblank = repeat = FALSE;
4959         base = s;
4960     }
4961
4962     while (s <= send) {
4963         switch (*s++) {
4964         default:
4965             skipspaces = 0;
4966             continue;
4967
4968         case '~':
4969             if (*s == '~') {
4970                 repeat = TRUE;
4971                 *s = ' ';
4972             }
4973             noblank = TRUE;
4974             s[-1] = ' ';
4975             /* FALL THROUGH */
4976         case ' ': case '\t':
4977             skipspaces++;
4978             continue;
4979         case 0:
4980             if (s < send) {
4981                 skipspaces = 0;
4982                 continue;
4983             } /* else FALL THROUGH */
4984         case '\n':
4985             arg = s - base;
4986             skipspaces++;
4987             arg -= skipspaces;
4988             if (arg) {
4989                 if (postspace)
4990                     *fpc++ = FF_SPACE;
4991                 *fpc++ = FF_LITERAL;
4992                 *fpc++ = (U16)arg;
4993             }
4994             postspace = FALSE;
4995             if (s <= send)
4996                 skipspaces--;
4997             if (skipspaces) {
4998                 *fpc++ = FF_SKIP;
4999                 *fpc++ = (U16)skipspaces;
5000             }
5001             skipspaces = 0;
5002             if (s <= send)
5003                 *fpc++ = FF_NEWLINE;
5004             if (noblank) {
5005                 *fpc++ = FF_BLANK;
5006                 if (repeat)
5007                     arg = fpc - linepc + 1;
5008                 else
5009                     arg = 0;
5010                 *fpc++ = (U16)arg;
5011             }
5012             if (s < send) {
5013                 linepc = fpc;
5014                 *fpc++ = FF_LINEMARK;
5015                 noblank = repeat = FALSE;
5016                 base = s;
5017             }
5018             else
5019                 s++;
5020             continue;
5021
5022         case '@':
5023         case '^':
5024             ischop = s[-1] == '^';
5025
5026             if (postspace) {
5027                 *fpc++ = FF_SPACE;
5028                 postspace = FALSE;
5029             }
5030             arg = (s - base) - 1;
5031             if (arg) {
5032                 *fpc++ = FF_LITERAL;
5033                 *fpc++ = (U16)arg;
5034             }
5035
5036             base = s - 1;
5037             *fpc++ = FF_FETCH;
5038             if (*s == '*') {
5039                 s++;
5040                 *fpc++ = 2;  /* skip the @* or ^* */
5041                 if (ischop) {
5042                     *fpc++ = FF_LINESNGL;
5043                     *fpc++ = FF_CHOP;
5044                 } else
5045                     *fpc++ = FF_LINEGLOB;
5046             }
5047             else if (*s == '#' || (*s == '.' && s[1] == '#')) {
5048                 arg = ischop ? 512 : 0;
5049                 base = s - 1;
5050                 while (*s == '#')
5051                     s++;
5052                 if (*s == '.') {
5053                     const char * const f = ++s;
5054                     while (*s == '#')
5055                         s++;
5056                     arg |= 256 + (s - f);
5057                 }
5058                 *fpc++ = s - base;              /* fieldsize for FETCH */
5059                 *fpc++ = FF_DECIMAL;
5060                 *fpc++ = (U16)arg;
5061                 unchopnum |= ! ischop;
5062             }
5063             else if (*s == '0' && s[1] == '#') {  /* Zero padded decimals */
5064                 arg = ischop ? 512 : 0;
5065                 base = s - 1;
5066                 s++;                                /* skip the '0' first */
5067                 while (*s == '#')
5068                     s++;
5069                 if (*s == '.') {
5070                     const char * const f = ++s;
5071                     while (*s == '#')
5072                         s++;
5073                     arg |= 256 + (s - f);
5074                 }
5075                 *fpc++ = s - base;                /* fieldsize for FETCH */
5076                 *fpc++ = FF_0DECIMAL;
5077                 *fpc++ = (U16)arg;
5078                 unchopnum |= ! ischop;
5079             }
5080             else {
5081                 I32 prespace = 0;
5082                 bool ismore = FALSE;
5083
5084                 if (*s == '>') {
5085                     while (*++s == '>') ;
5086                     prespace = FF_SPACE;
5087                 }
5088                 else if (*s == '|') {
5089                     while (*++s == '|') ;
5090                     prespace = FF_HALFSPACE;
5091                     postspace = TRUE;
5092                 }
5093                 else {
5094                     if (*s == '<')
5095                         while (*++s == '<') ;
5096                     postspace = TRUE;
5097                 }
5098                 if (*s == '.' && s[1] == '.' && s[2] == '.') {
5099                     s += 3;
5100                     ismore = TRUE;
5101                 }
5102                 *fpc++ = s - base;              /* fieldsize for FETCH */
5103
5104                 *fpc++ = ischop ? FF_CHECKCHOP : FF_CHECKNL;
5105
5106                 if (prespace)
5107                     *fpc++ = (U16)prespace;
5108                 *fpc++ = FF_ITEM;
5109                 if (ismore)
5110                     *fpc++ = FF_MORE;
5111                 if (ischop)
5112                     *fpc++ = FF_CHOP;
5113             }
5114             base = s;
5115             skipspaces = 0;
5116             continue;
5117         }
5118     }
5119     *fpc++ = FF_END;
5120
5121     assert (fpc <= fops + maxops); /* ensure our buffer estimate was valid */
5122     arg = fpc - fops;
5123     { /* need to jump to the next word */
5124         int z;
5125         z = WORD_ALIGN - SvCUR(sv) % WORD_ALIGN;
5126         SvGROW(sv, SvCUR(sv) + z + arg * sizeof(U32) + 4);
5127         s = SvPVX(sv) + SvCUR(sv) + z;
5128     }
5129     Copy(fops, s, arg, U32);
5130     Safefree(fops);
5131     sv_magic(sv, NULL, PERL_MAGIC_fm, NULL, 0);
5132     SvCOMPILED_on(sv);
5133
5134     if (unchopnum && repeat)
5135         DIE(aTHX_ "Repeated format line will never terminate (~~ and @#)");
5136     return 0;
5137 }
5138
5139
5140 STATIC bool
5141 S_num_overflow(NV value, I32 fldsize, I32 frcsize)
5142 {
5143     /* Can value be printed in fldsize chars, using %*.*f ? */
5144     NV pwr = 1;
5145     NV eps = 0.5;
5146     bool res = FALSE;
5147     int intsize = fldsize - (value < 0 ? 1 : 0);
5148
5149     if (frcsize & 256)
5150         intsize--;
5151     frcsize &= 255;
5152     intsize -= frcsize;
5153
5154     while (intsize--) pwr *= 10.0;
5155     while (frcsize--) eps /= 10.0;
5156
5157     if( value >= 0 ){
5158         if (value + eps >= pwr)
5159             res = TRUE;
5160     } else {
5161         if (value - eps <= -pwr)
5162             res = TRUE;
5163     }
5164     return res;
5165 }
5166
5167 static I32
5168 S_run_user_filter(pTHX_ int idx, SV *buf_sv, int maxlen)
5169 {
5170     dVAR;
5171     SV * const datasv = FILTER_DATA(idx);
5172     const int filter_has_file = IoLINES(datasv);
5173     SV * const filter_state = MUTABLE_SV(IoTOP_GV(datasv));
5174     SV * const filter_sub = MUTABLE_SV(IoBOTTOM_GV(datasv));
5175     int status = 0;
5176     SV *upstream;
5177     STRLEN got_len;
5178     char *got_p = NULL;
5179     char *prune_from = NULL;
5180     bool read_from_cache = FALSE;
5181     STRLEN umaxlen;
5182
5183     PERL_ARGS_ASSERT_RUN_USER_FILTER;
5184
5185     assert(maxlen >= 0);
5186     umaxlen = maxlen;
5187
5188     /* I was having segfault trouble under Linux 2.2.5 after a
5189        parse error occured.  (Had to hack around it with a test
5190        for PL_parser->error_count == 0.)  Solaris doesn't segfault --
5191        not sure where the trouble is yet.  XXX */
5192
5193     {
5194         SV *const cache = datasv;
5195         if (SvOK(cache)) {
5196             STRLEN cache_len;
5197             const char *cache_p = SvPV(cache, cache_len);
5198             STRLEN take = 0;
5199
5200             if (umaxlen) {
5201                 /* Running in block mode and we have some cached data already.
5202                  */
5203                 if (cache_len >= umaxlen) {
5204                     /* In fact, so much data we don't even need to call
5205                        filter_read.  */
5206                     take = umaxlen;
5207                 }
5208             } else {
5209                 const char *const first_nl =
5210                     (const char *)memchr(cache_p, '\n', cache_len);
5211                 if (first_nl) {
5212                     take = first_nl + 1 - cache_p;
5213                 }
5214             }
5215             if (take) {
5216                 sv_catpvn(buf_sv, cache_p, take);
5217                 sv_chop(cache, cache_p + take);
5218                 /* Definitely not EOF  */
5219                 return 1;
5220             }
5221
5222             sv_catsv(buf_sv, cache);
5223             if (umaxlen) {
5224                 umaxlen -= cache_len;
5225             }
5226             SvOK_off(cache);
5227             read_from_cache = TRUE;
5228         }
5229     }
5230
5231     /* Filter API says that the filter appends to the contents of the buffer.
5232        Usually the buffer is "", so the details don't matter. But if it's not,
5233        then clearly what it contains is already filtered by this filter, so we
5234        don't want to pass it in a second time.
5235        I'm going to use a mortal in case the upstream filter croaks.  */
5236     upstream = ((SvOK(buf_sv) && sv_len(buf_sv)) || SvGMAGICAL(buf_sv))
5237         ? sv_newmortal() : buf_sv;
5238     SvUPGRADE(upstream, SVt_PV);
5239
5240     if (filter_has_file) {
5241         status = FILTER_READ(idx+1, upstream, 0);
5242     }
5243
5244     if (filter_sub && status >= 0) {
5245         dSP;
5246         int count;
5247
5248         ENTER_with_name("call_filter_sub");
5249         SAVE_DEFSV;
5250         SAVETMPS;
5251         EXTEND(SP, 2);
5252
5253         DEFSV_set(upstream);
5254         PUSHMARK(SP);
5255         mPUSHi(0);
5256         if (filter_state) {
5257             PUSHs(filter_state);
5258         }
5259         PUTBACK;
5260         count = call_sv(filter_sub, G_SCALAR);
5261         SPAGAIN;
5262
5263         if (count > 0) {
5264             SV *out = POPs;
5265             if (SvOK(out)) {
5266                 status = SvIV(out);
5267             }
5268         }
5269
5270         PUTBACK;
5271         FREETMPS;
5272         LEAVE_with_name("call_filter_sub");
5273     }
5274
5275     if(SvOK(upstream)) {
5276         got_p = SvPV(upstream, got_len);
5277         if (umaxlen) {
5278             if (got_len > umaxlen) {
5279                 prune_from = got_p + umaxlen;
5280             }
5281         } else {
5282             char *const first_nl = (char *)memchr(got_p, '\n', got_len);
5283             if (first_nl && first_nl + 1 < got_p + got_len) {
5284                 /* There's a second line here... */
5285                 prune_from = first_nl + 1;
5286             }
5287         }
5288     }
5289     if (prune_from) {
5290         /* Oh. Too long. Stuff some in our cache.  */
5291         STRLEN cached_len = got_p + got_len - prune_from;
5292         SV *const cache = datasv;
5293
5294         if (SvOK(cache)) {
5295             /* Cache should be empty.  */
5296             assert(!SvCUR(cache));
5297         }
5298
5299         sv_setpvn(cache, prune_from, cached_len);
5300         /* If you ask for block mode, you may well split UTF-8 characters.
5301            "If it breaks, you get to keep both parts"
5302            (Your code is broken if you  don't put them back together again
5303            before something notices.) */
5304         if (SvUTF8(upstream)) {
5305             SvUTF8_on(cache);
5306         }
5307         SvCUR_set(upstream, got_len - cached_len);
5308         *prune_from = 0;
5309         /* Can't yet be EOF  */
5310         if (status == 0)
5311             status = 1;
5312     }
5313
5314     /* If they are at EOF but buf_sv has something in it, then they may never
5315        have touched the SV upstream, so it may be undefined.  If we naively
5316        concatenate it then we get a warning about use of uninitialised value.
5317     */
5318     if (upstream != buf_sv && (SvOK(upstream) || SvGMAGICAL(upstream))) {
5319         sv_catsv(buf_sv, upstream);
5320     }
5321
5322     if (status <= 0) {
5323         IoLINES(datasv) = 0;
5324         if (filter_state) {
5325             SvREFCNT_dec(filter_state);
5326             IoTOP_GV(datasv) = NULL;
5327         }
5328         if (filter_sub) {
5329             SvREFCNT_dec(filter_sub);
5330             IoBOTTOM_GV(datasv) = NULL;
5331         }
5332         filter_del(S_run_user_filter);
5333     }
5334     if (status == 0 && read_from_cache) {
5335         /* If we read some data from the cache (and by getting here it implies
5336            that we emptied the cache) then we aren't yet at EOF, and mustn't
5337            report that to our caller.  */
5338         return 1;
5339     }
5340     return status;
5341 }
5342
5343 /* perhaps someone can come up with a better name for
5344    this?  it is not really "absolute", per se ... */
5345 static bool
5346 S_path_is_absolute(const char *name)
5347 {
5348     PERL_ARGS_ASSERT_PATH_IS_ABSOLUTE;
5349
5350     if (PERL_FILE_IS_ABSOLUTE(name)
5351 #ifdef WIN32
5352         || (*name == '.' && ((name[1] == '/' ||
5353                              (name[1] == '.' && name[2] == '/'))
5354                          || (name[1] == '\\' ||
5355                              ( name[1] == '.' && name[2] == '\\')))
5356             )
5357 #else
5358         || (*name == '.' && (name[1] == '/' ||
5359                              (name[1] == '.' && name[2] == '/')))
5360 #endif
5361          )
5362     {
5363         return TRUE;
5364     }
5365     else
5366         return FALSE;
5367 }
5368
5369 /*
5370  * Local variables:
5371  * c-indentation-style: bsd
5372  * c-basic-offset: 4
5373  * indent-tabs-mode: t
5374  * End:
5375  *
5376  * ex: set ts=8 sts=4 sw=4 noet:
5377  */