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     else {
3125         assert(do_dump);
3126 #ifdef VMS
3127         if (!retop) retop = PL_main_start;
3128 #endif
3129         PL_restartop = retop;
3130         PL_do_undump = TRUE;
3131
3132         my_unexec();
3133
3134         PL_restartop = 0;               /* hmm, must be GNU unexec().. */
3135         PL_do_undump = FALSE;
3136     }
3137
3138     putback_return:
3139     PL_stack_sp = sp;
3140     _return:
3141     PERL_ASYNC_CHECK();
3142     return retop;
3143 }
3144
3145 PP(pp_exit)
3146 {
3147     dSP;
3148     I32 anum;
3149
3150     if (MAXARG < 1)
3151         anum = 0;
3152     else if (!TOPs) {
3153         anum = 0; (void)POPs;
3154     }
3155     else {
3156         anum = SvIVx(POPs);
3157 #ifdef VMS
3158         if (anum == 1
3159          && SvTRUE(cop_hints_fetch_pvs(PL_curcop, "vmsish_exit", 0)))
3160             anum = 0;
3161         VMSISH_HUSHED  =
3162             VMSISH_HUSHED || (PL_curcop->op_private & OPpHUSH_VMSISH);
3163 #endif
3164     }
3165     PL_exit_flags |= PERL_EXIT_EXPECTED;
3166     my_exit(anum);
3167     PUSHs(&PL_sv_undef);
3168     RETURN;
3169 }
3170
3171 /* Eval. */
3172
3173 STATIC void
3174 S_save_lines(pTHX_ AV *array, SV *sv)
3175 {
3176     const char *s = SvPVX_const(sv);
3177     const char * const send = SvPVX_const(sv) + SvCUR(sv);
3178     I32 line = 1;
3179
3180     PERL_ARGS_ASSERT_SAVE_LINES;
3181
3182     while (s && s < send) {
3183         const char *t;
3184         SV * const tmpstr = newSV_type(SVt_PVMG);
3185
3186         t = (const char *)memchr(s, '\n', send - s);
3187         if (t)
3188             t++;
3189         else
3190             t = send;
3191
3192         sv_setpvn(tmpstr, s, t - s);
3193         av_store(array, line++, tmpstr);
3194         s = t;
3195     }
3196 }
3197
3198 /*
3199 =for apidoc docatch
3200
3201 Check for the cases 0 or 3 of cur_env.je_ret, only used inside an eval context.
3202
3203 0 is used as continue inside eval,
3204
3205 3 is used for a die caught by an inner eval - continue inner loop
3206
3207 See cop.h: je_mustcatch, when set at any runlevel to TRUE, means eval ops must
3208 establish a local jmpenv to handle exception traps.
3209
3210 =cut
3211 */
3212 STATIC OP *
3213 S_docatch(pTHX_ OP *o)
3214 {
3215     int ret;
3216     OP * const oldop = PL_op;
3217     dJMPENV;
3218
3219 #ifdef DEBUGGING
3220     assert(CATCH_GET == TRUE);
3221 #endif
3222     PL_op = o;
3223
3224     JMPENV_PUSH(ret);
3225     switch (ret) {
3226     case 0:
3227         assert(cxstack_ix >= 0);
3228         assert(CxTYPE(&cxstack[cxstack_ix]) == CXt_EVAL);
3229         cxstack[cxstack_ix].blk_eval.cur_top_env = PL_top_env;
3230  redo_body:
3231         CALLRUNOPS(aTHX);
3232         break;
3233     case 3:
3234         /* die caught by an inner eval - continue inner loop */
3235         if (PL_restartop && PL_restartjmpenv == PL_top_env) {
3236             PL_restartjmpenv = NULL;
3237             PL_op = PL_restartop;
3238             PL_restartop = 0;
3239             goto redo_body;
3240         }
3241         /* FALLTHROUGH */
3242     default:
3243         JMPENV_POP;
3244         PL_op = oldop;
3245         JMPENV_JUMP(ret);
3246         NOT_REACHED; /* NOTREACHED */
3247     }
3248     JMPENV_POP;
3249     PL_op = oldop;
3250     return NULL;
3251 }
3252
3253
3254 /*
3255 =for apidoc find_runcv
3256
3257 Locate the CV corresponding to the currently executing sub or eval.
3258 If db_seqp is non_null, skip CVs that are in the DB package and populate
3259 *db_seqp with the cop sequence number at the point that the DB:: code was
3260 entered.  (This allows debuggers to eval in the scope of the breakpoint
3261 rather than in the scope of the debugger itself.)
3262
3263 =cut
3264 */
3265
3266 CV*
3267 Perl_find_runcv(pTHX_ U32 *db_seqp)
3268 {
3269     return Perl_find_runcv_where(aTHX_ 0, 0, db_seqp);
3270 }
3271
3272 /* If this becomes part of the API, it might need a better name. */
3273 CV *
3274 Perl_find_runcv_where(pTHX_ U8 cond, IV arg, U32 *db_seqp)
3275 {
3276     PERL_SI      *si;
3277     int          level = 0;
3278
3279     if (db_seqp)
3280         *db_seqp =
3281             PL_curcop == &PL_compiling
3282                 ? PL_cop_seqmax
3283                 : PL_curcop->cop_seq;
3284
3285     for (si = PL_curstackinfo; si; si = si->si_prev) {
3286         I32 ix;
3287         for (ix = si->si_cxix; ix >= 0; ix--) {
3288             const PERL_CONTEXT *cx = &(si->si_cxstack[ix]);
3289             CV *cv = NULL;
3290             if (CxTYPE(cx) == CXt_SUB || CxTYPE(cx) == CXt_FORMAT) {
3291                 cv = cx->blk_sub.cv;
3292                 /* skip DB:: code */
3293                 if (db_seqp && PL_debstash && CvSTASH(cv) == PL_debstash) {
3294                     *db_seqp = cx->blk_oldcop->cop_seq;
3295                     continue;
3296                 }
3297                 if (cx->cx_type & CXp_SUB_RE)
3298                     continue;
3299             }
3300             else if (CxTYPE(cx) == CXt_EVAL && !CxTRYBLOCK(cx))
3301                 cv = cx->blk_eval.cv;
3302             if (cv) {
3303                 switch (cond) {
3304                 case FIND_RUNCV_padid_eq:
3305                     if (!CvPADLIST(cv)
3306                      || CvPADLIST(cv)->xpadl_id != (U32)arg)
3307                         continue;
3308                     return cv;
3309                 case FIND_RUNCV_level_eq:
3310                     if (level++ != arg) continue;
3311                     /* GERONIMO! */
3312                 default:
3313                     return cv;
3314                 }
3315             }
3316         }
3317     }
3318     return cond == FIND_RUNCV_padid_eq ? NULL : PL_main_cv;
3319 }
3320
3321
3322 /* Run yyparse() in a setjmp wrapper. Returns:
3323  *   0: yyparse() successful
3324  *   1: yyparse() failed
3325  *   3: yyparse() died
3326  */
3327 STATIC int
3328 S_try_yyparse(pTHX_ int gramtype)
3329 {
3330     int ret;
3331     dJMPENV;
3332
3333     assert(CxTYPE(&cxstack[cxstack_ix]) == CXt_EVAL);
3334     JMPENV_PUSH(ret);
3335     switch (ret) {
3336     case 0:
3337         ret = yyparse(gramtype) ? 1 : 0;
3338         break;
3339     case 3:
3340         break;
3341     default:
3342         JMPENV_POP;
3343         JMPENV_JUMP(ret);
3344         NOT_REACHED; /* NOTREACHED */
3345     }
3346     JMPENV_POP;
3347     return ret;
3348 }
3349
3350
3351 /* Compile a require/do or an eval ''.
3352  *
3353  * outside is the lexically enclosing CV (if any) that invoked us.
3354  * seq     is the current COP scope value.
3355  * hh      is the saved hints hash, if any.
3356  *
3357  * Returns a bool indicating whether the compile was successful; if so,
3358  * PL_eval_start contains the first op of the compiled code; otherwise,
3359  * pushes undef.
3360  *
3361  * This function is called from two places: pp_require and pp_entereval.
3362  * These can be distinguished by whether PL_op is entereval.
3363  */
3364
3365 STATIC bool
3366 S_doeval(pTHX_ int gimme, CV* outside, U32 seq, HV *hh)
3367 {
3368     dSP;
3369     OP * const saveop = PL_op;
3370     bool clear_hints = saveop->op_type != OP_ENTEREVAL;
3371     COP * const oldcurcop = PL_curcop;
3372     bool in_require = (saveop->op_type == OP_REQUIRE);
3373     int yystatus;
3374     CV *evalcv;
3375
3376     PL_in_eval = (in_require
3377                   ? (EVAL_INREQUIRE | (PL_in_eval & EVAL_INEVAL))
3378                   : (EVAL_INEVAL |
3379                         ((PL_op->op_private & OPpEVAL_RE_REPARSING)
3380                             ? EVAL_RE_REPARSING : 0)));
3381
3382     PUSHMARK(SP);
3383
3384     evalcv = MUTABLE_CV(newSV_type(SVt_PVCV));
3385     CvEVAL_on(evalcv);
3386     assert(CxTYPE(&cxstack[cxstack_ix]) == CXt_EVAL);
3387     cxstack[cxstack_ix].blk_eval.cv = evalcv;
3388     cxstack[cxstack_ix].blk_gimme = gimme;
3389
3390     CvOUTSIDE_SEQ(evalcv) = seq;
3391     CvOUTSIDE(evalcv) = MUTABLE_CV(SvREFCNT_inc_simple(outside));
3392
3393     /* set up a scratch pad */
3394
3395     CvPADLIST_set(evalcv, pad_new(padnew_SAVE));
3396     PL_op = NULL; /* avoid PL_op and PL_curpad referring to different CVs */
3397
3398
3399     SAVEMORTALIZESV(evalcv);    /* must remain until end of current statement */
3400
3401     /* make sure we compile in the right package */
3402
3403     if (CopSTASH_ne(PL_curcop, PL_curstash)) {
3404         SAVEGENERICSV(PL_curstash);
3405         PL_curstash = (HV *)CopSTASH(PL_curcop);
3406         if (SvTYPE(PL_curstash) != SVt_PVHV) PL_curstash = NULL;
3407         else SvREFCNT_inc_simple_void(PL_curstash);
3408     }
3409     /* XXX:ajgo do we really need to alloc an AV for begin/checkunit */
3410     SAVESPTR(PL_beginav);
3411     PL_beginav = newAV();
3412     SAVEFREESV(PL_beginav);
3413     SAVESPTR(PL_unitcheckav);
3414     PL_unitcheckav = newAV();
3415     SAVEFREESV(PL_unitcheckav);
3416
3417
3418     ENTER_with_name("evalcomp");
3419     SAVESPTR(PL_compcv);
3420     PL_compcv = evalcv;
3421
3422     /* try to compile it */
3423
3424     PL_eval_root = NULL;
3425     PL_curcop = &PL_compiling;
3426     if ((saveop->op_type != OP_REQUIRE) && (saveop->op_flags & OPf_SPECIAL))
3427         PL_in_eval |= EVAL_KEEPERR;
3428     else
3429         CLEAR_ERRSV();
3430
3431     SAVEHINTS();
3432     if (clear_hints) {
3433         PL_hints = 0;
3434         hv_clear(GvHV(PL_hintgv));
3435     }
3436     else {
3437         PL_hints = saveop->op_private & OPpEVAL_COPHH
3438                      ? oldcurcop->cop_hints : saveop->op_targ;
3439
3440         /* making 'use re eval' not be in scope when compiling the
3441          * qr/mabye_has_runtime_code_block/ ensures that we don't get
3442          * infinite recursion when S_has_runtime_code() gives a false
3443          * positive: the second time round, HINT_RE_EVAL isn't set so we
3444          * don't bother calling S_has_runtime_code() */
3445         if (PL_in_eval & EVAL_RE_REPARSING)
3446             PL_hints &= ~HINT_RE_EVAL;
3447
3448         if (hh) {
3449             /* SAVEHINTS created a new HV in PL_hintgv, which we need to GC */
3450             SvREFCNT_dec(GvHV(PL_hintgv));
3451             GvHV(PL_hintgv) = hh;
3452         }
3453     }
3454     SAVECOMPILEWARNINGS();
3455     if (clear_hints) {
3456         if (PL_dowarn & G_WARN_ALL_ON)
3457             PL_compiling.cop_warnings = pWARN_ALL ;
3458         else if (PL_dowarn & G_WARN_ALL_OFF)
3459             PL_compiling.cop_warnings = pWARN_NONE ;
3460         else
3461             PL_compiling.cop_warnings = pWARN_STD ;
3462     }
3463     else {
3464         PL_compiling.cop_warnings =
3465             DUP_WARNINGS(oldcurcop->cop_warnings);
3466         cophh_free(CopHINTHASH_get(&PL_compiling));
3467         if (Perl_cop_fetch_label(aTHX_ oldcurcop, NULL, NULL)) {
3468             /* The label, if present, is the first entry on the chain. So rather
3469                than writing a blank label in front of it (which involves an
3470                allocation), just use the next entry in the chain.  */
3471             PL_compiling.cop_hints_hash
3472                 = cophh_copy(oldcurcop->cop_hints_hash->refcounted_he_next);
3473             /* Check the assumption that this removed the label.  */
3474             assert(Perl_cop_fetch_label(aTHX_ &PL_compiling, NULL, NULL) == NULL);
3475         }
3476         else
3477             PL_compiling.cop_hints_hash = cophh_copy(oldcurcop->cop_hints_hash);
3478     }
3479
3480     CALL_BLOCK_HOOKS(bhk_eval, saveop);
3481
3482     /* note that yyparse() may raise an exception, e.g. C<BEGIN{die}>,
3483      * so honour CATCH_GET and trap it here if necessary */
3484
3485     yystatus = (!in_require && CATCH_GET) ? S_try_yyparse(aTHX_ GRAMPROG) : yyparse(GRAMPROG);
3486
3487     if (yystatus || PL_parser->error_count || !PL_eval_root) {
3488         SV **newsp;                     /* Used by POPBLOCK. */
3489         PERL_CONTEXT *cx;
3490         I32 optype;                     /* Used by POPEVAL. */
3491         SV *namesv;
3492         SV *errsv = NULL;
3493
3494         cx = NULL;
3495         namesv = NULL;
3496         PERL_UNUSED_VAR(newsp);
3497         PERL_UNUSED_VAR(optype);
3498
3499         /* note that if yystatus == 3, then the EVAL CX block has already
3500          * been popped, and various vars restored */
3501         PL_op = saveop;
3502         if (yystatus != 3) {
3503             if (PL_eval_root) {
3504                 op_free(PL_eval_root);
3505                 PL_eval_root = NULL;
3506             }
3507             SP = PL_stack_base + POPMARK;       /* pop original mark */
3508             POPBLOCK(cx,PL_curpm);
3509             POPEVAL(cx);
3510             namesv = cx->blk_eval.old_namesv;
3511             /* POPBLOCK renders LEAVE_with_name("evalcomp") unnecessary. */
3512             LEAVE_with_name("eval"); /* pp_entereval knows about this LEAVE.  */
3513         }
3514
3515         errsv = ERRSV;
3516         if (in_require) {
3517             if (!cx) {
3518                 /* If cx is still NULL, it means that we didn't go in the
3519                  * POPEVAL branch. */
3520                 cx = &cxstack[cxstack_ix];
3521                 assert(CxTYPE(cx) == CXt_EVAL);
3522                 namesv = cx->blk_eval.old_namesv;
3523             }
3524             (void)hv_store(GvHVn(PL_incgv),
3525                            SvPVX_const(namesv),
3526                            SvUTF8(namesv) ? -(I32)SvCUR(namesv) : (I32)SvCUR(namesv),
3527                            &PL_sv_undef, 0);
3528             Perl_croak(aTHX_ "%"SVf"Compilation failed in require",
3529                        SVfARG(errsv
3530                                 ? errsv
3531                                 : newSVpvs_flags("Unknown error\n", SVs_TEMP)));
3532         }
3533         else {
3534             if (!*(SvPV_nolen_const(errsv))) {
3535                 sv_setpvs(errsv, "Compilation error");
3536             }
3537         }
3538         if (gimme != G_ARRAY) PUSHs(&PL_sv_undef);
3539         PUTBACK;
3540         return FALSE;
3541     }
3542     else
3543         LEAVE_with_name("evalcomp");
3544
3545     CopLINE_set(&PL_compiling, 0);
3546     SAVEFREEOP(PL_eval_root);
3547     cv_forget_slab(evalcv);
3548
3549     DEBUG_x(dump_eval());
3550
3551     /* Register with debugger: */
3552     if (PERLDB_INTER && saveop->op_type == OP_REQUIRE) {
3553         CV * const cv = get_cvs("DB::postponed", 0);
3554         if (cv) {
3555             dSP;
3556             PUSHMARK(SP);
3557             XPUSHs(MUTABLE_SV(CopFILEGV(&PL_compiling)));
3558             PUTBACK;
3559             call_sv(MUTABLE_SV(cv), G_DISCARD);
3560         }
3561     }
3562
3563     if (PL_unitcheckav) {
3564         OP *es = PL_eval_start;
3565         call_list(PL_scopestack_ix, PL_unitcheckav);
3566         PL_eval_start = es;
3567     }
3568
3569     /* compiled okay, so do it */
3570
3571     CvDEPTH(evalcv) = 1;
3572     SP = PL_stack_base + POPMARK;               /* pop original mark */
3573     PL_op = saveop;                     /* The caller may need it. */
3574     PL_parser->lex_state = LEX_NOTPARSING;      /* $^S needs this. */
3575
3576     PUTBACK;
3577     return TRUE;
3578 }
3579
3580 STATIC PerlIO *
3581 S_check_type_and_open(pTHX_ SV *name)
3582 {
3583     Stat_t st;
3584     STRLEN len;
3585     PerlIO * retio;
3586     const char *p = SvPV_const(name, len);
3587     int st_rc;
3588
3589     PERL_ARGS_ASSERT_CHECK_TYPE_AND_OPEN;
3590
3591     /* checking here captures a reasonable error message when
3592      * PERL_DISABLE_PMC is true, but when PMC checks are enabled, the
3593      * user gets a confusing message about looking for the .pmc file
3594      * rather than for the .pm file.
3595      * This check prevents a \0 in @INC causing problems.
3596      */
3597     if (!IS_SAFE_PATHNAME(p, len, "require"))
3598         return NULL;
3599
3600     /* on Win32 stat is expensive (it does an open() and close() twice and
3601        a couple other IO calls), the open will fail with a dir on its own with
3602        errno EACCES, so only do a stat to separate a dir from a real EACCES
3603        caused by user perms */
3604 #ifndef WIN32
3605     /* we use the value of errno later to see how stat() or open() failed.
3606      * We don't want it set if the stat succeeded but we still failed,
3607      * such as if the name exists, but is a directory */
3608     errno = 0;
3609
3610     st_rc = PerlLIO_stat(p, &st);
3611
3612     if (st_rc < 0 || S_ISDIR(st.st_mode) || S_ISBLK(st.st_mode)) {
3613         return NULL;
3614     }
3615 #endif
3616
3617 #if !defined(PERLIO_IS_STDIO)
3618     retio = PerlIO_openn(aTHX_ ":", PERL_SCRIPT_MODE, -1, 0, 0, NULL, 1, &name);
3619 #else
3620     retio = PerlIO_open(p, PERL_SCRIPT_MODE);
3621 #endif
3622 #ifdef WIN32
3623     /* EACCES stops the INC search early in pp_require to implement
3624        feature RT #113422 */
3625     if(!retio && errno == EACCES) { /* exists but probably a directory */
3626         int eno;
3627         st_rc = PerlLIO_stat(p, &st);
3628         if (st_rc >= 0) {
3629             if(S_ISDIR(st.st_mode) || S_ISBLK(st.st_mode))
3630                 eno = 0;
3631             else
3632                 eno = EACCES;
3633             errno = eno;
3634         }
3635     }
3636 #endif
3637     return retio;
3638 }
3639
3640 #ifndef PERL_DISABLE_PMC
3641 STATIC PerlIO *
3642 S_doopen_pm(pTHX_ SV *name)
3643 {
3644     STRLEN namelen;
3645     const char *p = SvPV_const(name, namelen);
3646
3647     PERL_ARGS_ASSERT_DOOPEN_PM;
3648
3649     /* check the name before trying for the .pmc name to avoid the
3650      * warning referring to the .pmc which the user probably doesn't
3651      * know or care about
3652      */
3653     if (!IS_SAFE_PATHNAME(p, namelen, "require"))
3654         return NULL;
3655
3656     if (namelen > 3 && memEQs(p + namelen - 3, 3, ".pm")) {
3657         SV *const pmcsv = sv_newmortal();
3658         Stat_t pmcstat;
3659
3660         SvSetSV_nosteal(pmcsv,name);
3661         sv_catpvs(pmcsv, "c");
3662
3663         if (PerlLIO_stat(SvPV_nolen_const(pmcsv), &pmcstat) >= 0)
3664             return check_type_and_open(pmcsv);
3665     }
3666     return check_type_and_open(name);
3667 }
3668 #else
3669 #  define doopen_pm(name) check_type_and_open(name)
3670 #endif /* !PERL_DISABLE_PMC */
3671
3672 /* require doesn't search for absolute names, or when the name is
3673    explicitly relative the current directory */
3674 PERL_STATIC_INLINE bool
3675 S_path_is_searchable(const char *name)
3676 {
3677     PERL_ARGS_ASSERT_PATH_IS_SEARCHABLE;
3678
3679     if (PERL_FILE_IS_ABSOLUTE(name)
3680 #ifdef WIN32
3681         || (*name == '.' && ((name[1] == '/' ||
3682                              (name[1] == '.' && name[2] == '/'))
3683                          || (name[1] == '\\' ||
3684                              ( name[1] == '.' && name[2] == '\\')))
3685             )
3686 #else
3687         || (*name == '.' && (name[1] == '/' ||
3688                              (name[1] == '.' && name[2] == '/')))
3689 #endif
3690          )
3691     {
3692         return FALSE;
3693     }
3694     else
3695         return TRUE;
3696 }
3697
3698
3699 /* also used for: pp_dofile() */
3700
3701 PP(pp_require)
3702 {
3703     dSP;
3704     PERL_CONTEXT *cx;
3705     SV *sv;
3706     const char *name;
3707     STRLEN len;
3708     char * unixname;
3709     STRLEN unixlen;
3710 #ifdef VMS
3711     int vms_unixname = 0;
3712     char *unixdir;
3713 #endif
3714     const char *tryname = NULL;
3715     SV *namesv = NULL;
3716     const I32 gimme = GIMME_V;
3717     int filter_has_file = 0;
3718     PerlIO *tryrsfp = NULL;
3719     SV *filter_cache = NULL;
3720     SV *filter_state = NULL;
3721     SV *filter_sub = NULL;
3722     SV *hook_sv = NULL;
3723     OP *op;
3724     int saved_errno;
3725     bool path_searchable;
3726
3727     sv = POPs;
3728     SvGETMAGIC(sv);
3729     if ( (SvNIOKp(sv) || SvVOK(sv)) && PL_op->op_type != OP_DOFILE) {
3730         sv = sv_2mortal(new_version(sv));
3731         if (!Perl_sv_derived_from_pvn(aTHX_ PL_patchlevel, STR_WITH_LEN("version"), 0))
3732             upg_version(PL_patchlevel, TRUE);
3733         if (cUNOP->op_first->op_type == OP_CONST && cUNOP->op_first->op_private & OPpCONST_NOVER) {
3734             if ( vcmp(sv,PL_patchlevel) <= 0 )
3735                 DIE(aTHX_ "Perls since %"SVf" too modern--this is %"SVf", stopped",
3736                     SVfARG(sv_2mortal(vnormal(sv))),
3737                     SVfARG(sv_2mortal(vnormal(PL_patchlevel)))
3738                 );
3739         }
3740         else {
3741             if ( vcmp(sv,PL_patchlevel) > 0 ) {
3742                 I32 first = 0;
3743                 AV *lav;
3744                 SV * const req = SvRV(sv);
3745                 SV * const pv = *hv_fetchs(MUTABLE_HV(req), "original", FALSE);
3746
3747                 /* get the left hand term */
3748                 lav = MUTABLE_AV(SvRV(*hv_fetchs(MUTABLE_HV(req), "version", FALSE)));
3749
3750                 first  = SvIV(*av_fetch(lav,0,0));
3751                 if (   first > (int)PERL_REVISION    /* probably 'use 6.0' */
3752                     || hv_exists(MUTABLE_HV(req), "qv", 2 ) /* qv style */
3753                     || av_tindex(lav) > 1            /* FP with > 3 digits */
3754                     || strstr(SvPVX(pv),".0")        /* FP with leading 0 */
3755                    ) {
3756                     DIE(aTHX_ "Perl %"SVf" required--this is only "
3757                         "%"SVf", stopped",
3758                         SVfARG(sv_2mortal(vnormal(req))),
3759                         SVfARG(sv_2mortal(vnormal(PL_patchlevel)))
3760                     );
3761                 }
3762                 else { /* probably 'use 5.10' or 'use 5.8' */
3763                     SV *hintsv;
3764                     I32 second = 0;
3765
3766                     if (av_tindex(lav)>=1)
3767                         second = SvIV(*av_fetch(lav,1,0));
3768
3769                     second /= second >= 600  ? 100 : 10;
3770                     hintsv = Perl_newSVpvf(aTHX_ "v%d.%d.0",
3771                                            (int)first, (int)second);
3772                     upg_version(hintsv, TRUE);
3773
3774                     DIE(aTHX_ "Perl %"SVf" required (did you mean %"SVf"?)"
3775                         "--this is only %"SVf", stopped",
3776                         SVfARG(sv_2mortal(vnormal(req))),
3777                         SVfARG(sv_2mortal(vnormal(sv_2mortal(hintsv)))),
3778                         SVfARG(sv_2mortal(vnormal(PL_patchlevel)))
3779                     );
3780                 }
3781             }
3782         }
3783
3784         RETPUSHYES;
3785     }
3786     if (!SvOK(sv))
3787         DIE(aTHX_ "Missing or undefined argument to require");
3788     name = SvPV_nomg_const(sv, len);
3789     if (!(name && len > 0 && *name))
3790         DIE(aTHX_ "Missing or undefined argument to require");
3791
3792     if (!IS_SAFE_PATHNAME(name, len, "require")) {
3793         DIE(aTHX_ "Can't locate %s:   %s",
3794             pv_escape(newSVpvs_flags("",SVs_TEMP),SvPVX(sv),SvCUR(sv),
3795                       SvCUR(sv)*2,NULL, SvUTF8(sv)?PERL_PV_ESCAPE_UNI:0),
3796             Strerror(ENOENT));
3797     }
3798     TAINT_PROPER("require");
3799
3800     path_searchable = path_is_searchable(name);
3801
3802 #ifdef VMS
3803     /* The key in the %ENV hash is in the syntax of file passed as the argument
3804      * usually this is in UNIX format, but sometimes in VMS format, which
3805      * can result in a module being pulled in more than once.
3806      * To prevent this, the key must be stored in UNIX format if the VMS
3807      * name can be translated to UNIX.
3808      */
3809
3810     if ((unixname =
3811           tounixspec(name, SvPVX(sv_2mortal(newSVpv("", VMS_MAXRSS-1)))))
3812          != NULL) {
3813         unixlen = strlen(unixname);
3814         vms_unixname = 1;
3815     }
3816     else
3817 #endif
3818     {
3819         /* if not VMS or VMS name can not be translated to UNIX, pass it
3820          * through.
3821          */
3822         unixname = (char *) name;
3823         unixlen = len;
3824     }
3825     if (PL_op->op_type == OP_REQUIRE) {
3826         SV * const * const svp = hv_fetch(GvHVn(PL_incgv),
3827                                           unixname, unixlen, 0);
3828         if ( svp ) {
3829             if (*svp != &PL_sv_undef)
3830                 RETPUSHYES;
3831             else
3832                 DIE(aTHX_ "Attempt to reload %s aborted.\n"
3833                             "Compilation failed in require", unixname);
3834         }
3835     }
3836
3837     LOADING_FILE_PROBE(unixname);
3838
3839     /* prepare to compile file */
3840
3841     if (!path_searchable) {
3842         /* At this point, name is SvPVX(sv)  */
3843         tryname = name;
3844         tryrsfp = doopen_pm(sv);
3845     }
3846     if (!tryrsfp && !(errno == EACCES && !path_searchable)) {
3847         AV * const ar = GvAVn(PL_incgv);
3848         SSize_t i;
3849 #ifdef VMS
3850         if (vms_unixname)
3851 #endif
3852         {
3853             SV *nsv = sv;
3854             namesv = newSV_type(SVt_PV);
3855             for (i = 0; i <= AvFILL(ar); i++) {
3856                 SV * const dirsv = *av_fetch(ar, i, TRUE);
3857
3858                 SvGETMAGIC(dirsv);
3859                 if (SvROK(dirsv)) {
3860                     int count;
3861                     SV **svp;
3862                     SV *loader = dirsv;
3863
3864                     if (SvTYPE(SvRV(loader)) == SVt_PVAV
3865                         && !SvOBJECT(SvRV(loader)))
3866                     {
3867                         loader = *av_fetch(MUTABLE_AV(SvRV(loader)), 0, TRUE);
3868                         SvGETMAGIC(loader);
3869                     }
3870
3871                     Perl_sv_setpvf(aTHX_ namesv, "/loader/0x%"UVxf"/%s",
3872                                    PTR2UV(SvRV(dirsv)), name);
3873                     tryname = SvPVX_const(namesv);
3874                     tryrsfp = NULL;
3875
3876                     if (SvPADTMP(nsv)) {
3877                         nsv = sv_newmortal();
3878                         SvSetSV_nosteal(nsv,sv);
3879                     }
3880
3881                     ENTER_with_name("call_INC");
3882                     SAVETMPS;
3883                     EXTEND(SP, 2);
3884
3885                     PUSHMARK(SP);
3886                     PUSHs(dirsv);
3887                     PUSHs(nsv);
3888                     PUTBACK;
3889                     if (SvGMAGICAL(loader)) {
3890                         SV *l = sv_newmortal();
3891                         sv_setsv_nomg(l, loader);
3892                         loader = l;
3893                     }
3894                     if (sv_isobject(loader))
3895                         count = call_method("INC", G_ARRAY);
3896                     else
3897                         count = call_sv(loader, G_ARRAY);
3898                     SPAGAIN;
3899
3900                     if (count > 0) {
3901                         int i = 0;
3902                         SV *arg;
3903
3904                         SP -= count - 1;
3905                         arg = SP[i++];
3906
3907                         if (SvROK(arg) && (SvTYPE(SvRV(arg)) <= SVt_PVLV)
3908                             && !isGV_with_GP(SvRV(arg))) {
3909                             filter_cache = SvRV(arg);
3910
3911                             if (i < count) {
3912                                 arg = SP[i++];
3913                             }
3914                         }
3915
3916                         if (SvROK(arg) && isGV_with_GP(SvRV(arg))) {
3917                             arg = SvRV(arg);
3918                         }
3919
3920                         if (isGV_with_GP(arg)) {
3921                             IO * const io = GvIO((const GV *)arg);
3922
3923                             ++filter_has_file;
3924
3925                             if (io) {
3926                                 tryrsfp = IoIFP(io);
3927                                 if (IoOFP(io) && IoOFP(io) != IoIFP(io)) {
3928                                     PerlIO_close(IoOFP(io));
3929                                 }
3930                                 IoIFP(io) = NULL;
3931                                 IoOFP(io) = NULL;
3932                             }
3933
3934                             if (i < count) {
3935                                 arg = SP[i++];
3936                             }
3937                         }
3938
3939                         if (SvROK(arg) && SvTYPE(SvRV(arg)) == SVt_PVCV) {
3940                             filter_sub = arg;
3941                             SvREFCNT_inc_simple_void_NN(filter_sub);
3942
3943                             if (i < count) {
3944                                 filter_state = SP[i];
3945                                 SvREFCNT_inc_simple_void(filter_state);
3946                             }
3947                         }
3948
3949                         if (!tryrsfp && (filter_cache || filter_sub)) {
3950                             tryrsfp = PerlIO_open(BIT_BUCKET,
3951                                                   PERL_SCRIPT_MODE);
3952                         }
3953                         SP--;
3954                     }
3955
3956                     /* FREETMPS may free our filter_cache */
3957                     SvREFCNT_inc_simple_void(filter_cache);
3958
3959                     PUTBACK;
3960                     FREETMPS;
3961                     LEAVE_with_name("call_INC");
3962
3963                     /* Now re-mortalize it. */
3964                     sv_2mortal(filter_cache);
3965
3966                     /* Adjust file name if the hook has set an %INC entry.
3967                        This needs to happen after the FREETMPS above.  */
3968                     svp = hv_fetch(GvHVn(PL_incgv), name, len, 0);
3969                     if (svp)
3970                         tryname = SvPV_nolen_const(*svp);
3971
3972                     if (tryrsfp) {
3973                         hook_sv = dirsv;
3974                         break;
3975                     }
3976
3977                     filter_has_file = 0;
3978                     filter_cache = NULL;
3979                     if (filter_state) {
3980                         SvREFCNT_dec_NN(filter_state);
3981                         filter_state = NULL;
3982                     }
3983                     if (filter_sub) {
3984                         SvREFCNT_dec_NN(filter_sub);
3985                         filter_sub = NULL;
3986                     }
3987                 }
3988                 else {
3989                   if (path_searchable) {
3990                     const char *dir;
3991                     STRLEN dirlen;
3992
3993                     if (SvOK(dirsv)) {
3994                         dir = SvPV_nomg_const(dirsv, dirlen);
3995                     } else {
3996                         dir = "";
3997                         dirlen = 0;
3998                     }
3999
4000                     if (!IS_SAFE_SYSCALL(dir, dirlen, "@INC entry", "require"))
4001                         continue;
4002 #ifdef VMS
4003                     if ((unixdir =
4004                           tounixpath(dir, SvPVX(sv_2mortal(newSVpv("", VMS_MAXRSS-1)))))
4005                          == NULL)
4006                         continue;
4007                     sv_setpv(namesv, unixdir);
4008                     sv_catpv(namesv, unixname);
4009 #else
4010 #  ifdef __SYMBIAN32__
4011                     if (PL_origfilename[0] &&
4012                         PL_origfilename[1] == ':' &&
4013                         !(dir[0] && dir[1] == ':'))
4014                         Perl_sv_setpvf(aTHX_ namesv,
4015                                        "%c:%s\\%s",
4016                                        PL_origfilename[0],
4017                                        dir, name);
4018                     else
4019                         Perl_sv_setpvf(aTHX_ namesv,
4020                                        "%s\\%s",
4021                                        dir, name);
4022 #  else
4023                     /* The equivalent of
4024                        Perl_sv_setpvf(aTHX_ namesv, "%s/%s", dir, name);
4025                        but without the need to parse the format string, or
4026                        call strlen on either pointer, and with the correct
4027                        allocation up front.  */
4028                     {
4029                         char *tmp = SvGROW(namesv, dirlen + len + 2);
4030
4031                         memcpy(tmp, dir, dirlen);
4032                         tmp +=dirlen;
4033
4034                         /* Avoid '<dir>//<file>' */
4035                         if (!dirlen || *(tmp-1) != '/') {
4036                             *tmp++ = '/';
4037                         } else {
4038                             /* So SvCUR_set reports the correct length below */
4039                             dirlen--;
4040                         }
4041
4042                         /* name came from an SV, so it will have a '\0' at the
4043                            end that we can copy as part of this memcpy().  */
4044                         memcpy(tmp, name, len + 1);
4045
4046                         SvCUR_set(namesv, dirlen + len + 1);
4047                         SvPOK_on(namesv);
4048                     }
4049 #  endif
4050 #endif
4051                     TAINT_PROPER("require");
4052                     tryname = SvPVX_const(namesv);
4053                     tryrsfp = doopen_pm(namesv);
4054                     if (tryrsfp) {
4055                         if (tryname[0] == '.' && tryname[1] == '/') {
4056                             ++tryname;
4057                             while (*++tryname == '/') {}
4058                         }
4059                         break;
4060                     }
4061                     else if (errno == EMFILE || errno == EACCES) {
4062                         /* no point in trying other paths if out of handles;
4063                          * on the other hand, if we couldn't open one of the
4064                          * files, then going on with the search could lead to
4065                          * unexpected results; see perl #113422
4066                          */
4067                         break;
4068                     }
4069                   }
4070                 }
4071             }
4072         }
4073     }
4074     saved_errno = errno; /* sv_2mortal can realloc things */
4075     sv_2mortal(namesv);
4076     if (!tryrsfp) {
4077         if (PL_op->op_type == OP_REQUIRE) {
4078             if(saved_errno == EMFILE || saved_errno == EACCES) {
4079                 /* diag_listed_as: Can't locate %s */
4080                 DIE(aTHX_ "Can't locate %s:   %s: %s",
4081                     name, tryname, Strerror(saved_errno));
4082             } else {
4083                 if (namesv) {                   /* did we lookup @INC? */
4084                     AV * const ar = GvAVn(PL_incgv);
4085                     SSize_t i;
4086                     SV *const msg = newSVpvs_flags("", SVs_TEMP);
4087                     SV *const inc = newSVpvs_flags("", SVs_TEMP);
4088                     for (i = 0; i <= AvFILL(ar); i++) {
4089                         sv_catpvs(inc, " ");
4090                         sv_catsv(inc, *av_fetch(ar, i, TRUE));
4091                     }
4092                     if (len >= 4 && memEQ(name + len - 3, ".pm", 4)) {
4093                         const char *c, *e = name + len - 3;
4094                         sv_catpv(msg, " (you may need to install the ");
4095                         for (c = name; c < e; c++) {
4096                             if (*c == '/') {
4097                                 sv_catpvs(msg, "::");
4098                             }
4099                             else {
4100                                 sv_catpvn(msg, c, 1);
4101                             }
4102                         }
4103                         sv_catpv(msg, " module)");
4104                     }
4105                     else if (len >= 2 && memEQ(name + len - 2, ".h", 3)) {
4106                         sv_catpv(msg, " (change .h to .ph maybe?) (did you run h2ph?)");
4107                     }
4108                     else if (len >= 3 && memEQ(name + len - 3, ".ph", 4)) {
4109                         sv_catpv(msg, " (did you run h2ph?)");
4110                     }
4111
4112                     /* diag_listed_as: Can't locate %s */
4113                     DIE(aTHX_
4114                         "Can't locate %s in @INC%" SVf " (@INC contains:%" SVf ")",
4115                         name, msg, inc);
4116                 }
4117             }
4118             DIE(aTHX_ "Can't locate %s", name);
4119         }
4120
4121         CLEAR_ERRSV();
4122         RETPUSHUNDEF;
4123     }
4124     else
4125         SETERRNO(0, SS_NORMAL);
4126
4127     /* Assume success here to prevent recursive requirement. */
4128     /* name is never assigned to again, so len is still strlen(name)  */
4129     /* Check whether a hook in @INC has already filled %INC */
4130     if (!hook_sv) {
4131         (void)hv_store(GvHVn(PL_incgv),
4132                        unixname, unixlen, newSVpv(tryname,0),0);
4133     } else {
4134         SV** const svp = hv_fetch(GvHVn(PL_incgv), unixname, unixlen, 0);
4135         if (!svp)
4136             (void)hv_store(GvHVn(PL_incgv),
4137                            unixname, unixlen, SvREFCNT_inc_simple(hook_sv), 0 );
4138     }
4139
4140     ENTER_with_name("eval");
4141     SAVETMPS;
4142     SAVECOPFILE_FREE(&PL_compiling);
4143     CopFILE_set(&PL_compiling, tryname);
4144     lex_start(NULL, tryrsfp, 0);
4145
4146     if (filter_sub || filter_cache) {
4147         /* We can use the SvPV of the filter PVIO itself as our cache, rather
4148            than hanging another SV from it. In turn, filter_add() optionally
4149            takes the SV to use as the filter (or creates a new SV if passed
4150            NULL), so simply pass in whatever value filter_cache has.  */
4151         SV * const fc = filter_cache ? newSV(0) : NULL;
4152         SV *datasv;
4153         if (fc) sv_copypv(fc, filter_cache);
4154         datasv = filter_add(S_run_user_filter, fc);
4155         IoLINES(datasv) = filter_has_file;
4156         IoTOP_GV(datasv) = MUTABLE_GV(filter_state);
4157         IoBOTTOM_GV(datasv) = MUTABLE_GV(filter_sub);
4158     }
4159
4160     /* switch to eval mode */
4161     PUSHBLOCK(cx, CXt_EVAL, SP);
4162     PUSHEVAL(cx, name);
4163     cx->blk_eval.retop = PL_op->op_next;
4164
4165     SAVECOPLINE(&PL_compiling);
4166     CopLINE_set(&PL_compiling, 0);
4167
4168     PUTBACK;
4169
4170     if (doeval(gimme, NULL, PL_curcop->cop_seq, NULL))
4171         op = DOCATCH(PL_eval_start);
4172     else
4173         op = PL_op->op_next;
4174
4175     LOADED_FILE_PROBE(unixname);
4176
4177     return op;
4178 }
4179
4180 /* This is a op added to hold the hints hash for
4181    pp_entereval. The hash can be modified by the code
4182    being eval'ed, so we return a copy instead. */
4183
4184 PP(pp_hintseval)
4185 {
4186     dSP;
4187     mXPUSHs(MUTABLE_SV(hv_copy_hints_hv(MUTABLE_HV(cSVOP_sv))));
4188     RETURN;
4189 }
4190
4191
4192 PP(pp_entereval)
4193 {
4194     dSP;
4195     PERL_CONTEXT *cx;
4196     SV *sv;
4197     const I32 gimme = GIMME_V;
4198     const U32 was = PL_breakable_sub_gen;
4199     char tbuf[TYPE_DIGITS(long) + 12];
4200     bool saved_delete = FALSE;
4201     char *tmpbuf = tbuf;
4202     STRLEN len;
4203     CV* runcv;
4204     U32 seq, lex_flags = 0;
4205     HV *saved_hh = NULL;
4206     const bool bytes = PL_op->op_private & OPpEVAL_BYTES;
4207
4208     if (PL_op->op_private & OPpEVAL_HAS_HH) {
4209         saved_hh = MUTABLE_HV(SvREFCNT_inc(POPs));
4210     }
4211     else if (PL_hints & HINT_LOCALIZE_HH || (
4212                 PL_op->op_private & OPpEVAL_COPHH
4213              && PL_curcop->cop_hints & HINT_LOCALIZE_HH
4214             )) {
4215         saved_hh = cop_hints_2hv(PL_curcop, 0);
4216         hv_magic(saved_hh, NULL, PERL_MAGIC_hints);
4217     }
4218     sv = POPs;
4219     if (!SvPOK(sv)) {
4220         /* make sure we've got a plain PV (no overload etc) before testing
4221          * for taint. Making a copy here is probably overkill, but better
4222          * safe than sorry */
4223         STRLEN len;
4224         const char * const p = SvPV_const(sv, len);
4225
4226         sv = newSVpvn_flags(p, len, SVs_TEMP | SvUTF8(sv));
4227         lex_flags |= LEX_START_COPIED;
4228
4229         if (bytes && SvUTF8(sv))
4230             SvPVbyte_force(sv, len);
4231     }
4232     else if (bytes && SvUTF8(sv)) {
4233         /* Don't modify someone else's scalar */
4234         STRLEN len;
4235         sv = newSVsv(sv);
4236         (void)sv_2mortal(sv);
4237         SvPVbyte_force(sv,len);
4238         lex_flags |= LEX_START_COPIED;
4239     }
4240
4241     TAINT_IF(SvTAINTED(sv));
4242     TAINT_PROPER("eval");
4243
4244     ENTER_with_name("eval");
4245     lex_start(sv, NULL, lex_flags | (PL_op->op_private & OPpEVAL_UNICODE
4246                            ? LEX_IGNORE_UTF8_HINTS
4247                            : bytes ? LEX_EVALBYTES : LEX_START_SAME_FILTER
4248                         )
4249              );
4250     SAVETMPS;
4251
4252     /* switch to eval mode */
4253
4254     if (PERLDB_NAMEEVAL && CopLINE(PL_curcop)) {
4255         SV * const temp_sv = sv_newmortal();
4256         Perl_sv_setpvf(aTHX_ temp_sv, "_<(eval %lu)[%s:%"IVdf"]",
4257                        (unsigned long)++PL_evalseq,
4258                        CopFILE(PL_curcop), (IV)CopLINE(PL_curcop));
4259         tmpbuf = SvPVX(temp_sv);
4260         len = SvCUR(temp_sv);
4261     }
4262     else
4263         len = my_snprintf(tmpbuf, sizeof(tbuf), "_<(eval %lu)", (unsigned long)++PL_evalseq);
4264     SAVECOPFILE_FREE(&PL_compiling);
4265     CopFILE_set(&PL_compiling, tmpbuf+2);
4266     SAVECOPLINE(&PL_compiling);
4267     CopLINE_set(&PL_compiling, 1);
4268     /* special case: an eval '' executed within the DB package gets lexically
4269      * placed in the first non-DB CV rather than the current CV - this
4270      * allows the debugger to execute code, find lexicals etc, in the
4271      * scope of the code being debugged. Passing &seq gets find_runcv
4272      * to do the dirty work for us */
4273     runcv = find_runcv(&seq);
4274
4275     PUSHBLOCK(cx, (CXt_EVAL|CXp_REAL), SP);
4276     PUSHEVAL(cx, 0);
4277     cx->blk_eval.retop = PL_op->op_next;
4278
4279     /* prepare to compile string */
4280
4281     if ((PERLDB_LINE || PERLDB_SAVESRC) && PL_curstash != PL_debstash)
4282         save_lines(CopFILEAV(&PL_compiling), PL_parser->linestr);
4283     else {
4284         /* XXX For C<eval "...">s within BEGIN {} blocks, this ends up
4285            deleting the eval's FILEGV from the stash before gv_check() runs
4286            (i.e. before run-time proper). To work around the coredump that
4287            ensues, we always turn GvMULTI_on for any globals that were
4288            introduced within evals. See force_ident(). GSAR 96-10-12 */
4289         char *const safestr = savepvn(tmpbuf, len);
4290         SAVEDELETE(PL_defstash, safestr, len);
4291         saved_delete = TRUE;
4292     }
4293
4294     PUTBACK;
4295
4296     if (doeval(gimme, runcv, seq, saved_hh)) {
4297         if (was != PL_breakable_sub_gen /* Some subs defined here. */
4298             ? (PERLDB_LINE || PERLDB_SAVESRC)
4299             :  PERLDB_SAVESRC_NOSUBS) {
4300             /* Retain the filegv we created.  */
4301         } else if (!saved_delete) {
4302             char *const safestr = savepvn(tmpbuf, len);
4303             SAVEDELETE(PL_defstash, safestr, len);
4304         }
4305         return DOCATCH(PL_eval_start);
4306     } else {
4307         /* We have already left the scope set up earlier thanks to the LEAVE
4308            in doeval().  */
4309         if (was != PL_breakable_sub_gen /* Some subs defined here. */
4310             ? (PERLDB_LINE || PERLDB_SAVESRC)
4311             :  PERLDB_SAVESRC_INVALID) {
4312             /* Retain the filegv we created.  */
4313         } else if (!saved_delete) {
4314             (void)hv_delete(PL_defstash, tmpbuf, len, G_DISCARD);
4315         }
4316         return PL_op->op_next;
4317     }
4318 }
4319
4320 PP(pp_leaveeval)
4321 {
4322     dSP;
4323     SV **newsp;
4324     PMOP *newpm;
4325     I32 gimme;
4326     PERL_CONTEXT *cx;
4327     OP *retop;
4328     const U8 save_flags = PL_op -> op_flags;
4329     I32 optype;
4330     SV *namesv;
4331     CV *evalcv;
4332
4333     PERL_ASYNC_CHECK();
4334     POPBLOCK(cx,newpm);
4335     POPEVAL(cx);
4336     namesv = cx->blk_eval.old_namesv;
4337     retop = cx->blk_eval.retop;
4338     evalcv = cx->blk_eval.cv;
4339
4340     SP = leave_common((gimme == G_VOID) ? SP : newsp, SP, newsp,
4341                                 gimme, SVs_TEMP, FALSE);
4342     PL_curpm = newpm;   /* Don't pop $1 et al till now */
4343
4344 #ifdef DEBUGGING
4345     assert(CvDEPTH(evalcv) == 1);
4346 #endif
4347     CvDEPTH(evalcv) = 0;
4348
4349     if (optype == OP_REQUIRE &&
4350         !(gimme == G_SCALAR ? SvTRUE(*SP) : SP > newsp))
4351     {
4352         /* Unassume the success we assumed earlier. */
4353         (void)hv_delete(GvHVn(PL_incgv),
4354                         SvPVX_const(namesv),
4355                         SvUTF8(namesv) ? -(I32)SvCUR(namesv) : (I32)SvCUR(namesv),
4356                         G_DISCARD);
4357         Perl_die(aTHX_ "%"SVf" did not return a true value", SVfARG(namesv));
4358         NOT_REACHED; /* NOTREACHED */
4359         /* die_unwind() did LEAVE, or we won't be here */
4360     }
4361     else {
4362         LEAVE_with_name("eval");
4363         if (!(save_flags & OPf_SPECIAL)) {
4364             CLEAR_ERRSV();
4365         }
4366     }
4367
4368     RETURNOP(retop);
4369 }
4370
4371 /* Common code for Perl_call_sv and Perl_fold_constants, put here to keep it
4372    close to the related Perl_create_eval_scope.  */
4373 void
4374 Perl_delete_eval_scope(pTHX)
4375 {
4376     SV **newsp;
4377     PMOP *newpm;
4378     I32 gimme;
4379     PERL_CONTEXT *cx;
4380     I32 optype;
4381
4382     POPBLOCK(cx,newpm);
4383     POPEVAL(cx);
4384     PL_curpm = newpm;
4385     LEAVE_with_name("eval_scope");
4386     PERL_UNUSED_VAR(newsp);
4387     PERL_UNUSED_VAR(gimme);
4388     PERL_UNUSED_VAR(optype);
4389 }
4390
4391 /* Common-ish code salvaged from Perl_call_sv and pp_entertry, because it was
4392    also needed by Perl_fold_constants.  */
4393 PERL_CONTEXT *
4394 Perl_create_eval_scope(pTHX_ U32 flags)
4395 {
4396     PERL_CONTEXT *cx;
4397     const I32 gimme = GIMME_V;
4398
4399     ENTER_with_name("eval_scope");
4400     SAVETMPS;
4401
4402     PUSHBLOCK(cx, (CXt_EVAL|CXp_TRYBLOCK), PL_stack_sp);
4403     PUSHEVAL(cx, 0);
4404
4405     PL_in_eval = EVAL_INEVAL;
4406     if (flags & G_KEEPERR)
4407         PL_in_eval |= EVAL_KEEPERR;
4408     else
4409         CLEAR_ERRSV();
4410     if (flags & G_FAKINGEVAL) {
4411         PL_eval_root = PL_op; /* Only needed so that goto works right. */
4412     }
4413     return cx;
4414 }
4415
4416 PP(pp_entertry)
4417 {
4418     PERL_CONTEXT * const cx = create_eval_scope(0);
4419     cx->blk_eval.retop = cLOGOP->op_other->op_next;
4420     return DOCATCH(PL_op->op_next);
4421 }
4422
4423 PP(pp_leavetry)
4424 {
4425     dSP;
4426     SV **newsp;
4427     PMOP *newpm;
4428     I32 gimme;
4429     PERL_CONTEXT *cx;
4430     I32 optype;
4431
4432     PERL_ASYNC_CHECK();
4433     POPBLOCK(cx,newpm);
4434     POPEVAL(cx);
4435     PERL_UNUSED_VAR(optype);
4436
4437     SP = leave_common(newsp, SP, newsp, gimme,
4438                                SVs_PADTMP|SVs_TEMP, FALSE);
4439     PL_curpm = newpm;   /* Don't pop $1 et al till now */
4440
4441     LEAVE_with_name("eval_scope");
4442     CLEAR_ERRSV();
4443     RETURN;
4444 }
4445
4446 PP(pp_entergiven)
4447 {
4448     dSP;
4449     PERL_CONTEXT *cx;
4450     const I32 gimme = GIMME_V;
4451
4452     ENTER_with_name("given");
4453     SAVETMPS;
4454
4455     if (PL_op->op_targ) {
4456         SAVEPADSVANDMORTALIZE(PL_op->op_targ);
4457         SvREFCNT_dec(PAD_SVl(PL_op->op_targ));
4458         PAD_SVl(PL_op->op_targ) = SvREFCNT_inc_NN(POPs);
4459     }
4460     else {
4461         SAVE_DEFSV;
4462         DEFSV_set(POPs);
4463     }
4464
4465     PUSHBLOCK(cx, CXt_GIVEN, SP);
4466     PUSHGIVEN(cx);
4467
4468     RETURN;
4469 }
4470
4471 PP(pp_leavegiven)
4472 {
4473     dSP;
4474     PERL_CONTEXT *cx;
4475     I32 gimme;
4476     SV **newsp;
4477     PMOP *newpm;
4478     PERL_UNUSED_CONTEXT;
4479
4480     POPBLOCK(cx,newpm);
4481     assert(CxTYPE(cx) == CXt_GIVEN);
4482
4483     SP = leave_common(newsp, SP, newsp, gimme,
4484                                SVs_PADTMP|SVs_TEMP, FALSE);
4485     PL_curpm = newpm;   /* Don't pop $1 et al till now */
4486
4487     LEAVE_with_name("given");
4488     RETURN;
4489 }
4490
4491 /* Helper routines used by pp_smartmatch */
4492 STATIC PMOP *
4493 S_make_matcher(pTHX_ REGEXP *re)
4494 {
4495     PMOP *matcher = (PMOP *) newPMOP(OP_MATCH, OPf_WANT_SCALAR | OPf_STACKED);
4496
4497     PERL_ARGS_ASSERT_MAKE_MATCHER;
4498
4499     PM_SETRE(matcher, ReREFCNT_inc(re));
4500
4501     SAVEFREEOP((OP *) matcher);
4502     ENTER_with_name("matcher"); SAVETMPS;
4503     SAVEOP();
4504     return matcher;
4505 }
4506
4507 STATIC bool
4508 S_matcher_matches_sv(pTHX_ PMOP *matcher, SV *sv)
4509 {
4510     dSP;
4511
4512     PERL_ARGS_ASSERT_MATCHER_MATCHES_SV;
4513
4514     PL_op = (OP *) matcher;
4515     XPUSHs(sv);
4516     PUTBACK;
4517     (void) Perl_pp_match(aTHX);
4518     SPAGAIN;
4519     return (SvTRUEx(POPs));
4520 }
4521
4522 STATIC void
4523 S_destroy_matcher(pTHX_ PMOP *matcher)
4524 {
4525     PERL_ARGS_ASSERT_DESTROY_MATCHER;
4526     PERL_UNUSED_ARG(matcher);
4527
4528     FREETMPS;
4529     LEAVE_with_name("matcher");
4530 }
4531
4532 /* Do a smart match */
4533 PP(pp_smartmatch)
4534 {
4535     DEBUG_M(Perl_deb(aTHX_ "Starting smart match resolution\n"));
4536     return do_smartmatch(NULL, NULL, 0);
4537 }
4538
4539 /* This version of do_smartmatch() implements the
4540  * table of smart matches that is found in perlsyn.
4541  */
4542 STATIC OP *
4543 S_do_smartmatch(pTHX_ HV *seen_this, HV *seen_other, const bool copied)
4544 {
4545     dSP;
4546
4547     bool object_on_left = FALSE;
4548     SV *e = TOPs;       /* e is for 'expression' */
4549     SV *d = TOPm1s;     /* d is for 'default', as in PL_defgv */
4550
4551     /* Take care only to invoke mg_get() once for each argument.
4552      * Currently we do this by copying the SV if it's magical. */
4553     if (d) {
4554         if (!copied && SvGMAGICAL(d))
4555             d = sv_mortalcopy(d);
4556     }
4557     else
4558         d = &PL_sv_undef;
4559
4560     assert(e);
4561     if (SvGMAGICAL(e))
4562         e = sv_mortalcopy(e);
4563
4564     /* First of all, handle overload magic of the rightmost argument */
4565     if (SvAMAGIC(e)) {
4566         SV * tmpsv;
4567         DEBUG_M(Perl_deb(aTHX_ "    applying rule Any-Object\n"));
4568         DEBUG_M(Perl_deb(aTHX_ "        attempting overload\n"));
4569
4570         tmpsv = amagic_call(d, e, smart_amg, AMGf_noleft);
4571         if (tmpsv) {
4572             SPAGAIN;
4573             (void)POPs;
4574             SETs(tmpsv);
4575             RETURN;
4576         }
4577         DEBUG_M(Perl_deb(aTHX_ "        failed to run overload method; continuing...\n"));
4578     }
4579
4580     SP -= 2;    /* Pop the values */
4581
4582
4583     /* ~~ undef */
4584     if (!SvOK(e)) {
4585         DEBUG_M(Perl_deb(aTHX_ "    applying rule Any-undef\n"));
4586         if (SvOK(d))
4587             RETPUSHNO;
4588         else
4589             RETPUSHYES;
4590     }
4591
4592     if (sv_isobject(e) && (SvTYPE(SvRV(e)) != SVt_REGEXP)) {
4593         DEBUG_M(Perl_deb(aTHX_ "    applying rule Any-Object\n"));
4594         Perl_croak(aTHX_ "Smart matching a non-overloaded object breaks encapsulation");
4595     }
4596     if (sv_isobject(d) && (SvTYPE(SvRV(d)) != SVt_REGEXP))
4597         object_on_left = TRUE;
4598
4599     /* ~~ sub */
4600     if (SvROK(e) && SvTYPE(SvRV(e)) == SVt_PVCV) {
4601         I32 c;
4602         if (object_on_left) {
4603             goto sm_any_sub; /* Treat objects like scalars */
4604         }
4605         else if (SvROK(d) && SvTYPE(SvRV(d)) == SVt_PVHV) {
4606             /* Test sub truth for each key */
4607             HE *he;
4608             bool andedresults = TRUE;
4609             HV *hv = (HV*) SvRV(d);
4610             I32 numkeys = hv_iterinit(hv);
4611             DEBUG_M(Perl_deb(aTHX_ "    applying rule Hash-CodeRef\n"));
4612             if (numkeys == 0)
4613                 RETPUSHYES;
4614             while ( (he = hv_iternext(hv)) ) {
4615                 DEBUG_M(Perl_deb(aTHX_ "        testing hash key...\n"));
4616                 ENTER_with_name("smartmatch_hash_key_test");
4617                 SAVETMPS;
4618                 PUSHMARK(SP);
4619                 PUSHs(hv_iterkeysv(he));
4620                 PUTBACK;
4621                 c = call_sv(e, G_SCALAR);
4622                 SPAGAIN;
4623                 if (c == 0)
4624                     andedresults = FALSE;
4625                 else
4626                     andedresults = SvTRUEx(POPs) && andedresults;
4627                 FREETMPS;
4628                 LEAVE_with_name("smartmatch_hash_key_test");
4629             }
4630             if (andedresults)
4631                 RETPUSHYES;
4632             else
4633                 RETPUSHNO;
4634         }
4635         else if (SvROK(d) && SvTYPE(SvRV(d)) == SVt_PVAV) {
4636             /* Test sub truth for each element */
4637             SSize_t i;
4638             bool andedresults = TRUE;
4639             AV *av = (AV*) SvRV(d);
4640             const I32 len = av_tindex(av);
4641             DEBUG_M(Perl_deb(aTHX_ "    applying rule Array-CodeRef\n"));
4642             if (len == -1)
4643                 RETPUSHYES;
4644             for (i = 0; i <= len; ++i) {
4645                 SV * const * const svp = av_fetch(av, i, FALSE);
4646                 DEBUG_M(Perl_deb(aTHX_ "        testing array element...\n"));
4647                 ENTER_with_name("smartmatch_array_elem_test");
4648                 SAVETMPS;
4649                 PUSHMARK(SP);
4650                 if (svp)
4651                     PUSHs(*svp);
4652                 PUTBACK;
4653                 c = call_sv(e, G_SCALAR);
4654                 SPAGAIN;
4655                 if (c == 0)
4656                     andedresults = FALSE;
4657                 else
4658                     andedresults = SvTRUEx(POPs) && andedresults;
4659                 FREETMPS;
4660                 LEAVE_with_name("smartmatch_array_elem_test");
4661             }
4662             if (andedresults)
4663                 RETPUSHYES;
4664             else
4665                 RETPUSHNO;
4666         }
4667         else {
4668           sm_any_sub:
4669             DEBUG_M(Perl_deb(aTHX_ "    applying rule Any-CodeRef\n"));
4670             ENTER_with_name("smartmatch_coderef");
4671             SAVETMPS;
4672             PUSHMARK(SP);
4673             PUSHs(d);
4674             PUTBACK;
4675             c = call_sv(e, G_SCALAR);
4676             SPAGAIN;
4677             if (c == 0)
4678                 PUSHs(&PL_sv_no);
4679             else if (SvTEMP(TOPs))
4680                 SvREFCNT_inc_void(TOPs);
4681             FREETMPS;
4682             LEAVE_with_name("smartmatch_coderef");
4683             RETURN;
4684         }
4685     }
4686     /* ~~ %hash */
4687     else if (SvROK(e) && SvTYPE(SvRV(e)) == SVt_PVHV) {
4688         if (object_on_left) {
4689             goto sm_any_hash; /* Treat objects like scalars */
4690         }
4691         else if (!SvOK(d)) {
4692             DEBUG_M(Perl_deb(aTHX_ "    applying rule Any-Hash ($a undef)\n"));
4693             RETPUSHNO;
4694         }
4695         else if (SvROK(d) && SvTYPE(SvRV(d)) == SVt_PVHV) {
4696             /* Check that the key-sets are identical */
4697             HE *he;
4698             HV *other_hv = MUTABLE_HV(SvRV(d));
4699             bool tied;
4700             bool other_tied;
4701             U32 this_key_count  = 0,
4702                 other_key_count = 0;
4703             HV *hv = MUTABLE_HV(SvRV(e));
4704
4705             DEBUG_M(Perl_deb(aTHX_ "    applying rule Hash-Hash\n"));
4706             /* Tied hashes don't know how many keys they have. */
4707             tied = cBOOL(SvTIED_mg((SV*)hv, PERL_MAGIC_tied));
4708             other_tied = cBOOL(SvTIED_mg((const SV *)other_hv, PERL_MAGIC_tied));
4709             if (!tied ) {
4710                 if(other_tied) {
4711                     /* swap HV sides */
4712                     HV * const temp = other_hv;
4713                     other_hv = hv;
4714                     hv = temp;
4715                     tied = TRUE;
4716                     other_tied = FALSE;
4717                 }
4718                 else if(HvUSEDKEYS((const HV *) hv) != HvUSEDKEYS(other_hv))
4719                     RETPUSHNO;
4720             }
4721
4722             /* The hashes have the same number of keys, so it suffices
4723                to check that one is a subset of the other. */
4724             (void) hv_iterinit(hv);
4725             while ( (he = hv_iternext(hv)) ) {
4726                 SV *key = hv_iterkeysv(he);
4727
4728                 DEBUG_M(Perl_deb(aTHX_ "        comparing hash key...\n"));
4729                 ++ this_key_count;
4730
4731                 if(!hv_exists_ent(other_hv, key, 0)) {
4732                     (void) hv_iterinit(hv);     /* reset iterator */
4733                     RETPUSHNO;
4734                 }
4735             }
4736
4737             if (other_tied) {
4738                 (void) hv_iterinit(other_hv);
4739                 while ( hv_iternext(other_hv) )
4740                     ++other_key_count;
4741             }
4742             else
4743                 other_key_count = HvUSEDKEYS(other_hv);
4744
4745             if (this_key_count != other_key_count)
4746                 RETPUSHNO;
4747             else
4748                 RETPUSHYES;
4749         }
4750         else if (SvROK(d) && SvTYPE(SvRV(d)) == SVt_PVAV) {
4751             AV * const other_av = MUTABLE_AV(SvRV(d));
4752             const SSize_t other_len = av_tindex(other_av) + 1;
4753             SSize_t i;
4754             HV *hv = MUTABLE_HV(SvRV(e));
4755
4756             DEBUG_M(Perl_deb(aTHX_ "    applying rule Array-Hash\n"));
4757             for (i = 0; i < other_len; ++i) {
4758                 SV ** const svp = av_fetch(other_av, i, FALSE);
4759                 DEBUG_M(Perl_deb(aTHX_ "        checking for key existence...\n"));
4760                 if (svp) {      /* ??? When can this not happen? */
4761                     if (hv_exists_ent(hv, *svp, 0))
4762                         RETPUSHYES;
4763                 }
4764             }
4765             RETPUSHNO;
4766         }
4767         else if (SvROK(d) && SvTYPE(SvRV(d)) == SVt_REGEXP) {
4768             DEBUG_M(Perl_deb(aTHX_ "    applying rule Regex-Hash\n"));
4769           sm_regex_hash:
4770             {
4771                 PMOP * const matcher = make_matcher((REGEXP*) SvRV(d));
4772                 HE *he;
4773                 HV *hv = MUTABLE_HV(SvRV(e));
4774
4775                 (void) hv_iterinit(hv);
4776                 while ( (he = hv_iternext(hv)) ) {
4777                     DEBUG_M(Perl_deb(aTHX_ "        testing key against pattern...\n"));
4778                     if (matcher_matches_sv(matcher, hv_iterkeysv(he))) {
4779                         (void) hv_iterinit(hv);
4780                         destroy_matcher(matcher);
4781                         RETPUSHYES;
4782                     }
4783                 }
4784                 destroy_matcher(matcher);
4785                 RETPUSHNO;
4786             }
4787         }
4788         else {
4789           sm_any_hash:
4790             DEBUG_M(Perl_deb(aTHX_ "    applying rule Any-Hash\n"));
4791             if (hv_exists_ent(MUTABLE_HV(SvRV(e)), d, 0))
4792                 RETPUSHYES;
4793             else
4794                 RETPUSHNO;
4795         }
4796     }
4797     /* ~~ @array */
4798     else if (SvROK(e) && SvTYPE(SvRV(e)) == SVt_PVAV) {
4799         if (object_on_left) {
4800             goto sm_any_array; /* Treat objects like scalars */
4801         }
4802         else if (SvROK(d) && SvTYPE(SvRV(d)) == SVt_PVHV) {
4803             AV * const other_av = MUTABLE_AV(SvRV(e));
4804             const SSize_t other_len = av_tindex(other_av) + 1;
4805             SSize_t i;
4806
4807             DEBUG_M(Perl_deb(aTHX_ "    applying rule Hash-Array\n"));
4808             for (i = 0; i < other_len; ++i) {
4809                 SV ** const svp = av_fetch(other_av, i, FALSE);
4810
4811                 DEBUG_M(Perl_deb(aTHX_ "        testing for key existence...\n"));
4812                 if (svp) {      /* ??? When can this not happen? */
4813                     if (hv_exists_ent(MUTABLE_HV(SvRV(d)), *svp, 0))
4814                         RETPUSHYES;
4815                 }
4816             }
4817             RETPUSHNO;
4818         }
4819         if (SvROK(d) && SvTYPE(SvRV(d)) == SVt_PVAV) {
4820             AV *other_av = MUTABLE_AV(SvRV(d));
4821             DEBUG_M(Perl_deb(aTHX_ "    applying rule Array-Array\n"));
4822             if (av_tindex(MUTABLE_AV(SvRV(e))) != av_tindex(other_av))
4823                 RETPUSHNO;
4824             else {
4825                 SSize_t i;
4826                 const SSize_t other_len = av_tindex(other_av);
4827
4828                 if (NULL == seen_this) {
4829                     seen_this = newHV();
4830                     (void) sv_2mortal(MUTABLE_SV(seen_this));
4831                 }
4832                 if (NULL == seen_other) {
4833                     seen_other = newHV();
4834                     (void) sv_2mortal(MUTABLE_SV(seen_other));
4835                 }
4836                 for(i = 0; i <= other_len; ++i) {
4837                     SV * const * const this_elem = av_fetch(MUTABLE_AV(SvRV(e)), i, FALSE);
4838                     SV * const * const other_elem = av_fetch(other_av, i, FALSE);
4839
4840                     if (!this_elem || !other_elem) {
4841                         if ((this_elem && SvOK(*this_elem))
4842                                 || (other_elem && SvOK(*other_elem)))
4843                             RETPUSHNO;
4844                     }
4845                     else if (hv_exists_ent(seen_this,
4846                                 sv_2mortal(newSViv(PTR2IV(*this_elem))), 0) ||
4847                             hv_exists_ent(seen_other,
4848                                 sv_2mortal(newSViv(PTR2IV(*other_elem))), 0))
4849                     {
4850                         if (*this_elem != *other_elem)
4851                             RETPUSHNO;
4852                     }
4853                     else {
4854                         (void)hv_store_ent(seen_this,
4855                                 sv_2mortal(newSViv(PTR2IV(*this_elem))),
4856                                 &PL_sv_undef, 0);
4857                         (void)hv_store_ent(seen_other,
4858                                 sv_2mortal(newSViv(PTR2IV(*other_elem))),
4859                                 &PL_sv_undef, 0);
4860                         PUSHs(*other_elem);
4861                         PUSHs(*this_elem);
4862
4863                         PUTBACK;
4864                         DEBUG_M(Perl_deb(aTHX_ "        recursively comparing array element...\n"));
4865                         (void) do_smartmatch(seen_this, seen_other, 0);
4866                         SPAGAIN;
4867                         DEBUG_M(Perl_deb(aTHX_ "        recursion finished\n"));
4868
4869                         if (!SvTRUEx(POPs))
4870                             RETPUSHNO;
4871                     }
4872                 }
4873                 RETPUSHYES;
4874             }
4875         }
4876         else if (SvROK(d) && SvTYPE(SvRV(d)) == SVt_REGEXP) {
4877             DEBUG_M(Perl_deb(aTHX_ "    applying rule Regex-Array\n"));
4878           sm_regex_array:
4879             {
4880                 PMOP * const matcher = make_matcher((REGEXP*) SvRV(d));
4881                 const SSize_t this_len = av_tindex(MUTABLE_AV(SvRV(e)));
4882                 SSize_t i;
4883
4884                 for(i = 0; i <= this_len; ++i) {
4885                     SV * const * const svp = av_fetch(MUTABLE_AV(SvRV(e)), i, FALSE);
4886                     DEBUG_M(Perl_deb(aTHX_ "        testing element against pattern...\n"));
4887                     if (svp && matcher_matches_sv(matcher, *svp)) {
4888                         destroy_matcher(matcher);
4889                         RETPUSHYES;
4890                     }
4891                 }
4892                 destroy_matcher(matcher);
4893                 RETPUSHNO;
4894             }
4895         }
4896         else if (!SvOK(d)) {
4897             /* undef ~~ array */
4898             const SSize_t this_len = av_tindex(MUTABLE_AV(SvRV(e)));
4899             SSize_t i;
4900
4901             DEBUG_M(Perl_deb(aTHX_ "    applying rule Undef-Array\n"));
4902             for (i = 0; i <= this_len; ++i) {
4903                 SV * const * const svp = av_fetch(MUTABLE_AV(SvRV(e)), i, FALSE);
4904                 DEBUG_M(Perl_deb(aTHX_ "        testing for undef element...\n"));
4905                 if (!svp || !SvOK(*svp))
4906                     RETPUSHYES;
4907             }
4908             RETPUSHNO;
4909         }
4910         else {
4911           sm_any_array:
4912             {
4913                 SSize_t i;
4914                 const SSize_t this_len = av_tindex(MUTABLE_AV(SvRV(e)));
4915
4916                 DEBUG_M(Perl_deb(aTHX_ "    applying rule Any-Array\n"));
4917                 for (i = 0; i <= this_len; ++i) {
4918                     SV * const * const svp = av_fetch(MUTABLE_AV(SvRV(e)), i, FALSE);
4919                     if (!svp)
4920                         continue;
4921
4922                     PUSHs(d);
4923                     PUSHs(*svp);
4924                     PUTBACK;
4925                     /* infinite recursion isn't supposed to happen here */
4926                     DEBUG_M(Perl_deb(aTHX_ "        recursively testing array element...\n"));
4927                     (void) do_smartmatch(NULL, NULL, 1);
4928                     SPAGAIN;
4929                     DEBUG_M(Perl_deb(aTHX_ "        recursion finished\n"));
4930                     if (SvTRUEx(POPs))
4931                         RETPUSHYES;
4932                 }
4933                 RETPUSHNO;
4934             }
4935         }
4936     }
4937     /* ~~ qr// */
4938     else if (SvROK(e) && SvTYPE(SvRV(e)) == SVt_REGEXP) {
4939         if (!object_on_left && SvROK(d) && SvTYPE(SvRV(d)) == SVt_PVHV) {
4940             SV *t = d; d = e; e = t;
4941             DEBUG_M(Perl_deb(aTHX_ "    applying rule Hash-Regex\n"));
4942             goto sm_regex_hash;
4943         }
4944         else if (!object_on_left && SvROK(d) && SvTYPE(SvRV(d)) == SVt_PVAV) {
4945             SV *t = d; d = e; e = t;
4946             DEBUG_M(Perl_deb(aTHX_ "    applying rule Array-Regex\n"));
4947             goto sm_regex_array;
4948         }
4949         else {
4950             PMOP * const matcher = make_matcher((REGEXP*) SvRV(e));
4951
4952             DEBUG_M(Perl_deb(aTHX_ "    applying rule Any-Regex\n"));
4953             PUTBACK;
4954             PUSHs(matcher_matches_sv(matcher, d)
4955                     ? &PL_sv_yes
4956                     : &PL_sv_no);
4957             destroy_matcher(matcher);
4958             RETURN;
4959         }
4960     }
4961     /* ~~ scalar */
4962     /* See if there is overload magic on left */
4963     else if (object_on_left && SvAMAGIC(d)) {
4964         SV *tmpsv;
4965         DEBUG_M(Perl_deb(aTHX_ "    applying rule Object-Any\n"));
4966         DEBUG_M(Perl_deb(aTHX_ "        attempting overload\n"));
4967         PUSHs(d); PUSHs(e);
4968         PUTBACK;
4969         tmpsv = amagic_call(d, e, smart_amg, AMGf_noright);
4970         if (tmpsv) {
4971             SPAGAIN;
4972             (void)POPs;
4973             SETs(tmpsv);
4974             RETURN;
4975         }
4976         SP -= 2;
4977         DEBUG_M(Perl_deb(aTHX_ "        failed to run overload method; falling back...\n"));
4978         goto sm_any_scalar;
4979     }
4980     else if (!SvOK(d)) {
4981         /* undef ~~ scalar ; we already know that the scalar is SvOK */
4982         DEBUG_M(Perl_deb(aTHX_ "    applying rule undef-Any\n"));
4983         RETPUSHNO;
4984     }
4985     else
4986   sm_any_scalar:
4987     if (SvNIOK(e) || (SvPOK(e) && looks_like_number(e) && SvNIOK(d))) {
4988         DEBUG_M(if (SvNIOK(e))
4989                     Perl_deb(aTHX_ "    applying rule Any-Num\n");
4990                 else
4991                     Perl_deb(aTHX_ "    applying rule Num-numish\n");
4992         );
4993         /* numeric comparison */
4994         PUSHs(d); PUSHs(e);
4995         PUTBACK;
4996         if (CopHINTS_get(PL_curcop) & HINT_INTEGER)
4997             (void) Perl_pp_i_eq(aTHX);
4998         else
4999             (void) Perl_pp_eq(aTHX);
5000         SPAGAIN;
5001         if (SvTRUEx(POPs))
5002             RETPUSHYES;
5003         else
5004             RETPUSHNO;
5005     }
5006
5007     /* As a last resort, use string comparison */
5008     DEBUG_M(Perl_deb(aTHX_ "    applying rule Any-Any\n"));
5009     PUSHs(d); PUSHs(e);
5010     PUTBACK;
5011     return Perl_pp_seq(aTHX);
5012 }
5013
5014 PP(pp_enterwhen)
5015 {
5016     dSP;
5017     PERL_CONTEXT *cx;
5018     const I32 gimme = GIMME_V;
5019
5020     /* This is essentially an optimization: if the match
5021        fails, we don't want to push a context and then
5022        pop it again right away, so we skip straight
5023        to the op that follows the leavewhen.
5024        RETURNOP calls PUTBACK which restores the stack pointer after the POPs.
5025     */
5026     if ((0 == (PL_op->op_flags & OPf_SPECIAL)) && !SvTRUEx(POPs))
5027         RETURNOP(cLOGOP->op_other->op_next);
5028
5029     ENTER_with_name("when");
5030     SAVETMPS;
5031
5032     PUSHBLOCK(cx, CXt_WHEN, SP);
5033     PUSHWHEN(cx);
5034
5035     RETURN;
5036 }
5037
5038 PP(pp_leavewhen)
5039 {
5040     dSP;
5041     I32 cxix;
5042     PERL_CONTEXT *cx;
5043     I32 gimme;
5044     SV **newsp;
5045     PMOP *newpm;
5046
5047     cxix = dopoptogiven(cxstack_ix);
5048     if (cxix < 0)
5049         /* diag_listed_as: Can't "when" outside a topicalizer */
5050         DIE(aTHX_ "Can't \"%s\" outside a topicalizer",
5051                    PL_op->op_flags & OPf_SPECIAL ? "default" : "when");
5052
5053     POPBLOCK(cx,newpm);
5054     assert(CxTYPE(cx) == CXt_WHEN);
5055
5056     SP = leave_common(newsp, SP, newsp, gimme,
5057                                SVs_PADTMP|SVs_TEMP, FALSE);
5058     PL_curpm = newpm;   /* pop $1 et al */
5059
5060     LEAVE_with_name("when");
5061
5062     if (cxix < cxstack_ix)
5063         dounwind(cxix);
5064
5065     cx = &cxstack[cxix];
5066
5067     if (CxFOREACH(cx)) {
5068         /* clear off anything above the scope we're re-entering */
5069         I32 inner = PL_scopestack_ix;
5070
5071         TOPBLOCK(cx);
5072         if (PL_scopestack_ix < inner)
5073             leave_scope(PL_scopestack[PL_scopestack_ix]);
5074         PL_curcop = cx->blk_oldcop;
5075
5076         PERL_ASYNC_CHECK();
5077         return cx->blk_loop.my_op->op_nextop;
5078     }
5079     else {
5080         PERL_ASYNC_CHECK();
5081         RETURNOP(cx->blk_givwhen.leave_op);
5082     }
5083 }
5084
5085 PP(pp_continue)
5086 {
5087     dSP;
5088     I32 cxix;
5089     PERL_CONTEXT *cx;
5090     I32 gimme;
5091     SV **newsp;
5092     PMOP *newpm;
5093
5094     PERL_UNUSED_VAR(gimme);
5095
5096     cxix = dopoptowhen(cxstack_ix);
5097     if (cxix < 0)
5098         DIE(aTHX_ "Can't \"continue\" outside a when block");
5099
5100     if (cxix < cxstack_ix)
5101         dounwind(cxix);
5102
5103     POPBLOCK(cx,newpm);
5104     assert(CxTYPE(cx) == CXt_WHEN);
5105
5106     SP = newsp;
5107     PL_curpm = newpm;   /* pop $1 et al */
5108
5109     LEAVE_with_name("when");
5110     RETURNOP(cx->blk_givwhen.leave_op->op_next);
5111 }
5112
5113 PP(pp_break)
5114 {
5115     I32 cxix;
5116     PERL_CONTEXT *cx;
5117
5118     cxix = dopoptogiven(cxstack_ix);
5119     if (cxix < 0)
5120         DIE(aTHX_ "Can't \"break\" outside a given block");
5121
5122     cx = &cxstack[cxix];
5123     if (CxFOREACH(cx))
5124         DIE(aTHX_ "Can't \"break\" in a loop topicalizer");
5125
5126     if (cxix < cxstack_ix)
5127         dounwind(cxix);
5128
5129     /* Restore the sp at the time we entered the given block */
5130     TOPBLOCK(cx);
5131
5132     return cx->blk_givwhen.leave_op;
5133 }
5134
5135 static MAGIC *
5136 S_doparseform(pTHX_ SV *sv)
5137 {
5138     STRLEN len;
5139     char *s = SvPV(sv, len);
5140     char *send;
5141     char *base = NULL; /* start of current field */
5142     I32 skipspaces = 0; /* number of contiguous spaces seen */
5143     bool noblank   = FALSE; /* ~ or ~~ seen on this line */
5144     bool repeat    = FALSE; /* ~~ seen on this line */
5145     bool postspace = FALSE; /* a text field may need right padding */
5146     U32 *fops;
5147     U32 *fpc;
5148     U32 *linepc = NULL;     /* position of last FF_LINEMARK */
5149     I32 arg;
5150     bool ischop;            /* it's a ^ rather than a @ */
5151     bool unchopnum = FALSE; /* at least one @ (i.e. non-chop) num field seen */
5152     int maxops = 12; /* FF_LINEMARK + FF_END + 10 (\0 without preceding \n) */
5153     MAGIC *mg = NULL;
5154     SV *sv_copy;
5155
5156     PERL_ARGS_ASSERT_DOPARSEFORM;
5157
5158     if (len == 0)
5159         Perl_croak(aTHX_ "Null picture in formline");
5160
5161     if (SvTYPE(sv) >= SVt_PVMG) {
5162         /* This might, of course, still return NULL.  */
5163         mg = mg_find(sv, PERL_MAGIC_fm);
5164     } else {
5165         sv_upgrade(sv, SVt_PVMG);
5166     }
5167
5168     if (mg) {
5169         /* still the same as previously-compiled string? */
5170         SV *old = mg->mg_obj;
5171         if ( !(!!SvUTF8(old) ^ !!SvUTF8(sv))
5172               && len == SvCUR(old)
5173               && strnEQ(SvPVX(old), SvPVX(sv), len)
5174         ) {
5175             DEBUG_f(PerlIO_printf(Perl_debug_log,"Re-using compiled format\n"));
5176             return mg;
5177         }
5178
5179         DEBUG_f(PerlIO_printf(Perl_debug_log, "Re-compiling format\n"));
5180         Safefree(mg->mg_ptr);
5181         mg->mg_ptr = NULL;
5182         SvREFCNT_dec(old);
5183         mg->mg_obj = NULL;
5184     }
5185     else {
5186         DEBUG_f(PerlIO_printf(Perl_debug_log, "Compiling format\n"));
5187         mg = sv_magicext(sv, NULL, PERL_MAGIC_fm, &PL_vtbl_fm, NULL, 0);
5188     }
5189
5190     sv_copy = newSVpvn_utf8(s, len, SvUTF8(sv));
5191     s = SvPV(sv_copy, len); /* work on the copy, not the original */
5192     send = s + len;
5193
5194
5195     /* estimate the buffer size needed */
5196     for (base = s; s <= send; s++) {
5197         if (*s == '\n' || *s == '@' || *s == '^')
5198             maxops += 10;
5199     }
5200     s = base;
5201     base = NULL;
5202
5203     Newx(fops, maxops, U32);
5204     fpc = fops;
5205
5206     if (s < send) {
5207         linepc = fpc;
5208         *fpc++ = FF_LINEMARK;
5209         noblank = repeat = FALSE;
5210         base = s;
5211     }
5212
5213     while (s <= send) {
5214         switch (*s++) {
5215         default:
5216             skipspaces = 0;
5217             continue;
5218
5219         case '~':
5220             if (*s == '~') {
5221                 repeat = TRUE;
5222                 skipspaces++;
5223                 s++;
5224             }
5225             noblank = TRUE;
5226             /* FALLTHROUGH */
5227         case ' ': case '\t':
5228             skipspaces++;
5229             continue;
5230         case 0:
5231             if (s < send) {
5232                 skipspaces = 0;
5233                 continue;
5234             } /* else FALL THROUGH */
5235         case '\n':
5236             arg = s - base;
5237             skipspaces++;
5238             arg -= skipspaces;
5239             if (arg) {
5240                 if (postspace)
5241                     *fpc++ = FF_SPACE;
5242                 *fpc++ = FF_LITERAL;
5243                 *fpc++ = (U32)arg;
5244             }
5245             postspace = FALSE;
5246             if (s <= send)
5247                 skipspaces--;
5248             if (skipspaces) {
5249                 *fpc++ = FF_SKIP;
5250                 *fpc++ = (U32)skipspaces;
5251             }
5252             skipspaces = 0;
5253             if (s <= send)
5254                 *fpc++ = FF_NEWLINE;
5255             if (noblank) {
5256                 *fpc++ = FF_BLANK;
5257                 if (repeat)
5258                     arg = fpc - linepc + 1;
5259                 else
5260                     arg = 0;
5261                 *fpc++ = (U32)arg;
5262             }
5263             if (s < send) {
5264                 linepc = fpc;
5265                 *fpc++ = FF_LINEMARK;
5266                 noblank = repeat = FALSE;
5267                 base = s;
5268             }
5269             else
5270                 s++;
5271             continue;
5272
5273         case '@':
5274         case '^':
5275             ischop = s[-1] == '^';
5276
5277             if (postspace) {
5278                 *fpc++ = FF_SPACE;
5279                 postspace = FALSE;
5280             }
5281             arg = (s - base) - 1;
5282             if (arg) {
5283                 *fpc++ = FF_LITERAL;
5284                 *fpc++ = (U32)arg;
5285             }
5286
5287             base = s - 1;
5288             *fpc++ = FF_FETCH;
5289             if (*s == '*') { /*  @* or ^*  */
5290                 s++;
5291                 *fpc++ = 2;  /* skip the @* or ^* */
5292                 if (ischop) {
5293                     *fpc++ = FF_LINESNGL;
5294                     *fpc++ = FF_CHOP;
5295                 } else
5296                     *fpc++ = FF_LINEGLOB;
5297             }
5298             else if (*s == '#' || (*s == '.' && s[1] == '#')) { /* @###, ^### */
5299                 arg = ischop ? FORM_NUM_BLANK : 0;
5300                 base = s - 1;
5301                 while (*s == '#')
5302                     s++;
5303                 if (*s == '.') {
5304                     const char * const f = ++s;
5305                     while (*s == '#')
5306                         s++;
5307                     arg |= FORM_NUM_POINT + (s - f);
5308                 }
5309                 *fpc++ = s - base;              /* fieldsize for FETCH */
5310                 *fpc++ = FF_DECIMAL;
5311                 *fpc++ = (U32)arg;
5312                 unchopnum |= ! ischop;
5313             }
5314             else if (*s == '0' && s[1] == '#') {  /* Zero padded decimals */
5315                 arg = ischop ? FORM_NUM_BLANK : 0;
5316                 base = s - 1;
5317                 s++;                                /* skip the '0' first */
5318                 while (*s == '#')
5319                     s++;
5320                 if (*s == '.') {
5321                     const char * const f = ++s;
5322                     while (*s == '#')
5323                         s++;
5324                     arg |= FORM_NUM_POINT + (s - f);
5325                 }
5326                 *fpc++ = s - base;                /* fieldsize for FETCH */
5327                 *fpc++ = FF_0DECIMAL;
5328                 *fpc++ = (U32)arg;
5329                 unchopnum |= ! ischop;
5330             }
5331             else {                              /* text field */
5332                 I32 prespace = 0;
5333                 bool ismore = FALSE;
5334
5335                 if (*s == '>') {
5336                     while (*++s == '>') ;
5337                     prespace = FF_SPACE;
5338                 }
5339                 else if (*s == '|') {
5340                     while (*++s == '|') ;
5341                     prespace = FF_HALFSPACE;
5342                     postspace = TRUE;
5343                 }
5344                 else {
5345                     if (*s == '<')
5346                         while (*++s == '<') ;
5347                     postspace = TRUE;
5348                 }
5349                 if (*s == '.' && s[1] == '.' && s[2] == '.') {
5350                     s += 3;
5351                     ismore = TRUE;
5352                 }
5353                 *fpc++ = s - base;              /* fieldsize for FETCH */
5354
5355                 *fpc++ = ischop ? FF_CHECKCHOP : FF_CHECKNL;
5356
5357                 if (prespace)
5358                     *fpc++ = (U32)prespace; /* add SPACE or HALFSPACE */
5359                 *fpc++ = FF_ITEM;
5360                 if (ismore)
5361                     *fpc++ = FF_MORE;
5362                 if (ischop)
5363                     *fpc++ = FF_CHOP;
5364             }
5365             base = s;
5366             skipspaces = 0;
5367             continue;
5368         }
5369     }
5370     *fpc++ = FF_END;
5371
5372     assert (fpc <= fops + maxops); /* ensure our buffer estimate was valid */
5373     arg = fpc - fops;
5374
5375     mg->mg_ptr = (char *) fops;
5376     mg->mg_len = arg * sizeof(U32);
5377     mg->mg_obj = sv_copy;
5378     mg->mg_flags |= MGf_REFCOUNTED;
5379
5380     if (unchopnum && repeat)
5381         Perl_die(aTHX_ "Repeated format line will never terminate (~~ and @#)");
5382
5383     return mg;
5384 }
5385
5386
5387 STATIC bool
5388 S_num_overflow(NV value, I32 fldsize, I32 frcsize)
5389 {
5390     /* Can value be printed in fldsize chars, using %*.*f ? */
5391     NV pwr = 1;
5392     NV eps = 0.5;
5393     bool res = FALSE;
5394     int intsize = fldsize - (value < 0 ? 1 : 0);
5395
5396     if (frcsize & FORM_NUM_POINT)
5397         intsize--;
5398     frcsize &= ~(FORM_NUM_POINT|FORM_NUM_BLANK);
5399     intsize -= frcsize;
5400
5401     while (intsize--) pwr *= 10.0;
5402     while (frcsize--) eps /= 10.0;
5403
5404     if( value >= 0 ){
5405         if (value + eps >= pwr)
5406             res = TRUE;
5407     } else {
5408         if (value - eps <= -pwr)
5409             res = TRUE;
5410     }
5411     return res;
5412 }
5413
5414 static I32
5415 S_run_user_filter(pTHX_ int idx, SV *buf_sv, int maxlen)
5416 {
5417     SV * const datasv = FILTER_DATA(idx);
5418     const int filter_has_file = IoLINES(datasv);
5419     SV * const filter_state = MUTABLE_SV(IoTOP_GV(datasv));
5420     SV * const filter_sub = MUTABLE_SV(IoBOTTOM_GV(datasv));
5421     int status = 0;
5422     SV *upstream;
5423     STRLEN got_len;
5424     char *got_p = NULL;
5425     char *prune_from = NULL;
5426     bool read_from_cache = FALSE;
5427     STRLEN umaxlen;
5428     SV *err = NULL;
5429
5430     PERL_ARGS_ASSERT_RUN_USER_FILTER;
5431
5432     assert(maxlen >= 0);
5433     umaxlen = maxlen;
5434
5435     /* I was having segfault trouble under Linux 2.2.5 after a
5436        parse error occurred.  (Had to hack around it with a test
5437        for PL_parser->error_count == 0.)  Solaris doesn't segfault --
5438        not sure where the trouble is yet.  XXX */
5439
5440     {
5441         SV *const cache = datasv;
5442         if (SvOK(cache)) {
5443             STRLEN cache_len;
5444             const char *cache_p = SvPV(cache, cache_len);
5445             STRLEN take = 0;
5446
5447             if (umaxlen) {
5448                 /* Running in block mode and we have some cached data already.
5449                  */
5450                 if (cache_len >= umaxlen) {
5451                     /* In fact, so much data we don't even need to call
5452                        filter_read.  */
5453                     take = umaxlen;
5454                 }
5455             } else {
5456                 const char *const first_nl =
5457                     (const char *)memchr(cache_p, '\n', cache_len);
5458                 if (first_nl) {
5459                     take = first_nl + 1 - cache_p;
5460                 }
5461             }
5462             if (take) {
5463                 sv_catpvn(buf_sv, cache_p, take);
5464                 sv_chop(cache, cache_p + take);
5465                 /* Definitely not EOF  */
5466                 return 1;
5467             }
5468
5469             sv_catsv(buf_sv, cache);
5470             if (umaxlen) {
5471                 umaxlen -= cache_len;
5472             }
5473             SvOK_off(cache);
5474             read_from_cache = TRUE;
5475         }
5476     }
5477
5478     /* Filter API says that the filter appends to the contents of the buffer.
5479        Usually the buffer is "", so the details don't matter. But if it's not,
5480        then clearly what it contains is already filtered by this filter, so we
5481        don't want to pass it in a second time.
5482        I'm going to use a mortal in case the upstream filter croaks.  */
5483     upstream = ((SvOK(buf_sv) && sv_len(buf_sv)) || SvGMAGICAL(buf_sv))
5484         ? sv_newmortal() : buf_sv;
5485     SvUPGRADE(upstream, SVt_PV);
5486
5487     if (filter_has_file) {
5488         status = FILTER_READ(idx+1, upstream, 0);
5489     }
5490
5491     if (filter_sub && status >= 0) {
5492         dSP;
5493         int count;
5494
5495         ENTER_with_name("call_filter_sub");
5496         SAVE_DEFSV;
5497         SAVETMPS;
5498         EXTEND(SP, 2);
5499
5500         DEFSV_set(upstream);
5501         PUSHMARK(SP);
5502         mPUSHi(0);
5503         if (filter_state) {
5504             PUSHs(filter_state);
5505         }
5506         PUTBACK;
5507         count = call_sv(filter_sub, G_SCALAR|G_EVAL);
5508         SPAGAIN;
5509
5510         if (count > 0) {
5511             SV *out = POPs;
5512             SvGETMAGIC(out);
5513             if (SvOK(out)) {
5514                 status = SvIV(out);
5515             }
5516             else {
5517                 SV * const errsv = ERRSV;
5518                 if (SvTRUE_NN(errsv))
5519                     err = newSVsv(errsv);
5520             }
5521         }
5522
5523         PUTBACK;
5524         FREETMPS;
5525         LEAVE_with_name("call_filter_sub");
5526     }
5527
5528     if (SvGMAGICAL(upstream)) {
5529         mg_get(upstream);
5530         if (upstream == buf_sv) mg_free(buf_sv);
5531     }
5532     if (SvIsCOW(upstream)) sv_force_normal(upstream);
5533     if(!err && SvOK(upstream)) {
5534         got_p = SvPV_nomg(upstream, got_len);
5535         if (umaxlen) {
5536             if (got_len > umaxlen) {
5537                 prune_from = got_p + umaxlen;
5538             }
5539         } else {
5540             char *const first_nl = (char *)memchr(got_p, '\n', got_len);
5541             if (first_nl && first_nl + 1 < got_p + got_len) {
5542                 /* There's a second line here... */
5543                 prune_from = first_nl + 1;
5544             }
5545         }
5546     }
5547     if (!err && prune_from) {
5548         /* Oh. Too long. Stuff some in our cache.  */
5549         STRLEN cached_len = got_p + got_len - prune_from;
5550         SV *const cache = datasv;
5551
5552         if (SvOK(cache)) {
5553             /* Cache should be empty.  */
5554             assert(!SvCUR(cache));
5555         }
5556
5557         sv_setpvn(cache, prune_from, cached_len);
5558         /* If you ask for block mode, you may well split UTF-8 characters.
5559            "If it breaks, you get to keep both parts"
5560            (Your code is broken if you  don't put them back together again
5561            before something notices.) */
5562         if (SvUTF8(upstream)) {
5563             SvUTF8_on(cache);
5564         }
5565         if (SvPOK(upstream)) SvCUR_set(upstream, got_len - cached_len);
5566         else
5567             /* Cannot just use sv_setpvn, as that could free the buffer
5568                before we have a chance to assign it. */
5569             sv_usepvn(upstream, savepvn(got_p, got_len - cached_len),
5570                       got_len - cached_len);
5571         *prune_from = 0;
5572         /* Can't yet be EOF  */
5573         if (status == 0)
5574             status = 1;
5575     }
5576
5577     /* If they are at EOF but buf_sv has something in it, then they may never
5578        have touched the SV upstream, so it may be undefined.  If we naively
5579        concatenate it then we get a warning about use of uninitialised value.
5580     */
5581     if (!err && upstream != buf_sv &&
5582         SvOK(upstream)) {
5583         sv_catsv_nomg(buf_sv, upstream);
5584     }
5585     else if (SvOK(upstream)) (void)SvPV_force_nolen(buf_sv);
5586
5587     if (status <= 0) {
5588         IoLINES(datasv) = 0;
5589         if (filter_state) {
5590             SvREFCNT_dec(filter_state);
5591             IoTOP_GV(datasv) = NULL;
5592         }
5593         if (filter_sub) {
5594             SvREFCNT_dec(filter_sub);
5595             IoBOTTOM_GV(datasv) = NULL;
5596         }
5597         filter_del(S_run_user_filter);
5598     }
5599
5600     if (err)
5601         croak_sv(err);
5602
5603     if (status == 0 && read_from_cache) {
5604         /* If we read some data from the cache (and by getting here it implies
5605            that we emptied the cache) then we aren't yet at EOF, and mustn't
5606            report that to our caller.  */
5607         return 1;
5608     }
5609     return status;
5610 }
5611
5612 /*
5613  * Local variables:
5614  * c-indentation-style: bsd
5615  * c-basic-offset: 4
5616  * indent-tabs-mode: nil
5617  * End:
5618  *
5619  * ex: set ts=8 sts=4 sw=4 et:
5620  */