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