pp_hot.c

   1 /*    pp_hot.c
   2  *
   3  *    Copyright (C) 1991, 1992, 1993, 1994, 1995, 1996, 1997, 1998, 1999,
   4  *    2000, 2001, 2002, 2003, 2004, 2005, 2006, 2007 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  * Then he heard Merry change the note, and up went the Horn-cry of Buckland,
  13  * shaking the air.
  14  *
  15  *            Awake!  Awake!  Fear, Fire, Foes!  Awake!
  16  *                     Fire, Foes!  Awake!
  17  */
  18
  19 /* This file contains 'hot' pp ("push/pop") functions that
  20  * execute the opcodes that make up a perl program. A typical pp function
  21  * expects to find its arguments on the stack, and usually pushes its
  22  * results onto the stack, hence the 'pp' terminology. Each OP structure
  23  * contains a pointer to the relevant pp_foo() function.
  24  *
  25  * By 'hot', we mean common ops whose execution speed is critical.
  26  * By gathering them together into a single file, we encourage
  27  * CPU cache hits on hot code. Also it could be taken as a warning not to
  28  * change any code in this file unless you're sure it won't affect
  29  * performance.
  30  */
  31
  32 #include "EXTERN.h"
  33 #define PERL_IN_PP_HOT_C
  34 #include "perl.h"
  35
  36 /* Hot code. */
  37
  38 PP(pp_const)
  39 {
  40     dVAR;
  41     dSP;
  42     XPUSHs(cSVOP_sv);
  43     RETURN;
  44 }
  45
  46 PP(pp_nextstate)
  47 {
  48     dVAR;
  49     PL_curcop = (COP*)PL_op;
  50     TAINT_NOT;          /* Each statement is presumed innocent */
  51     PL_stack_sp = PL_stack_base + cxstack[cxstack_ix].blk_oldsp;
  52     FREETMPS;
  53     return NORMAL;
  54 }
  55
  56 PP(pp_gvsv)
  57 {
  58     dVAR;
  59     dSP;
  60     EXTEND(SP,1);
  61     if (PL_op->op_private & OPpLVAL_INTRO)
  62         PUSHs(save_scalar(cGVOP_gv));
  63     else
  64         PUSHs(GvSVn(cGVOP_gv));
  65     RETURN;
  66 }
  67
  68 PP(pp_null)
  69 {
  70     dVAR;
  71     return NORMAL;
  72 }
  73
  74 PP(pp_pushmark)
  75 {
  76     dVAR;
  77     PUSHMARK(PL_stack_sp);
  78     return NORMAL;
  79 }
  80
  81 PP(pp_stringify)
  82 {
  83     dVAR; dSP; dTARGET;
  84     sv_copypv(TARG,TOPs);
  85     SETTARG;
  86     RETURN;
  87 }
  88
  89 PP(pp_gv)
  90 {
  91     dVAR; dSP;
  92     XPUSHs((SV*)cGVOP_gv);
  93     RETURN;
  94 }
  95
  96 PP(pp_and)
  97 {
  98     dVAR; dSP;
  99     if (!SvTRUE(TOPs))
 100         RETURN;
 101     else {
 102         if (PL_op->op_type == OP_AND)
 103             --SP;
 104         RETURNOP(cLOGOP->op_other);
 105     }
 106 }
 107
 108 PP(pp_sassign)
 109 {
 110     dVAR; dSP; dPOPTOPssrl;
 111
 112     if (PL_op->op_private & OPpASSIGN_BACKWARDS) {
 113         SV * const temp = left;
 114         left = right; right = temp;
 115     }
 116     if (PL_tainting && PL_tainted && !SvTAINTED(left))
 117         TAINT_NOT;
 118     if (PL_op->op_private & OPpASSIGN_CV_TO_GV) {
 119         SV * const cv = SvRV(left);
 120         const U32 cv_type = SvTYPE(cv);
 121         const U32 gv_type = SvTYPE(right);
 122         const bool got_coderef = cv_type == SVt_PVCV || cv_type == SVt_PVFM;
 123
 124         if (!got_coderef) {
 125             assert(SvROK(cv));
 126         }
 127
 128         /* Can do the optimisation if right (LVALUE) is not a typeglob,
 129            left (RVALUE) is a reference to something, and we're in void
 130            context. */
 131         if (!got_coderef && gv_type != SVt_PVGV && GIMME_V == G_VOID) {
 132             /* Is the target symbol table currently empty?  */
 133             GV * const gv = gv_fetchsv(right, GV_NOINIT, SVt_PVGV);
 134             if (SvTYPE(gv) != SVt_PVGV && !SvOK(gv)) {
 135                 /* Good. Create a new proxy constant subroutine in the target.
 136                    The gv becomes a(nother) reference to the constant.  */
 137                 SV *const value = SvRV(cv);
 138
 139                 SvUPGRADE((SV *)gv, SVt_IV);
 140                 SvPCS_IMPORTED_on(gv);
 141                 SvRV_set(gv, value);
 142                 SvREFCNT_inc_simple_void(value);
 143                 SETs(right);
 144                 RETURN;
 145             }
 146         }
 147
 148         /* Need to fix things up.  */
 149         if (gv_type != SVt_PVGV) {
 150             /* Need to fix GV.  */
 151             right = (SV*)gv_fetchsv(right, GV_ADD, SVt_PVGV);
 152         }
 153
 154         if (!got_coderef) {
 155             /* We've been returned a constant rather than a full subroutine,
 156                but they expect a subroutine reference to apply.  */
 157             if (SvROK(cv)) {
 158                 ENTER;
 159                 SvREFCNT_inc_void(SvRV(cv));
 160                 /* newCONSTSUB takes a reference count on the passed in SV
 161                    from us.  We set the name to NULL, otherwise we get into
 162                    all sorts of fun as the reference to our new sub is
 163                    donated to the GV that we're about to assign to.
 164                 */
 165                 SvRV_set(left, (SV *)newCONSTSUB(GvSTASH(right), NULL,
 166                                                  SvRV(cv)));
 167                 SvREFCNT_dec(cv);
 168                 LEAVE;
 169             } else {
 170                 /* What can happen for the corner case *{"BONK"} = \&{"BONK"};
 171                    is that
 172                    First:   ops for \&{"BONK"}; return us the constant in the
 173                             symbol table
 174                    Second:  ops for *{"BONK"} cause that symbol table entry
 175                             (and our reference to it) to be upgraded from RV
 176                             to typeblob)
 177                    Thirdly: We get here. cv is actually PVGV now, and its
 178                             GvCV() is actually the subroutine we're looking for
 179
 180                    So change the reference so that it points to the subroutine
 181                    of that typeglob, as that's what they were after all along.
 182                 */
 183                 GV *const upgraded = (GV *) cv;
 184                 CV *const source = GvCV(upgraded);
 185
 186                 assert(source);
 187                 assert(CvFLAGS(source) & CVf_CONST);
 188
 189                 SvREFCNT_inc_void(source);
 190                 SvREFCNT_dec(upgraded);
 191                 SvRV_set(left, (SV *)source);
 192             }
 193         }
 194
 195     }
 196     SvSetMagicSV(right, left);
 197     SETs(right);
 198     RETURN;
 199 }
 200
 201 PP(pp_cond_expr)
 202 {
 203     dVAR; dSP;
 204     if (SvTRUEx(POPs))
 205         RETURNOP(cLOGOP->op_other);
 206     else
 207         RETURNOP(cLOGOP->op_next);
 208 }
 209
 210 PP(pp_unstack)
 211 {
 212     dVAR;
 213     I32 oldsave;
 214     TAINT_NOT;          /* Each statement is presumed innocent */
 215     PL_stack_sp = PL_stack_base + cxstack[cxstack_ix].blk_oldsp;
 216     FREETMPS;
 217     oldsave = PL_scopestack[PL_scopestack_ix - 1];
 218     LEAVE_SCOPE(oldsave);
 219     return NORMAL;
 220 }
 221
 222 PP(pp_concat)
 223 {
 224   dVAR; dSP; dATARGET; tryAMAGICbin(concat,opASSIGN);
 225   {
 226     dPOPTOPssrl;
 227     bool lbyte;
 228     STRLEN rlen;
 229     const char *rpv = NULL;
 230     bool rbyte = FALSE;
 231     bool rcopied = FALSE;
 232
 233     if (TARG == right && right != left) {
 234         /* mg_get(right) may happen here ... */
 235         rpv = SvPV_const(right, rlen);
 236         rbyte = !DO_UTF8(right);
 237         right = newSVpvn_flags(rpv, rlen, SVs_TEMP);
 238         rpv = SvPV_const(right, rlen);  /* no point setting UTF-8 here */
 239         rcopied = TRUE;
 240     }
 241
 242     if (TARG != left) {
 243         STRLEN llen;
 244         const char* const lpv = SvPV_const(left, llen); /* mg_get(left) may happen here */
 245         lbyte = !DO_UTF8(left);
 246         sv_setpvn(TARG, lpv, llen);
 247         if (!lbyte)
 248             SvUTF8_on(TARG);
 249         else
 250             SvUTF8_off(TARG);
 251     }
 252     else { /* TARG == left */
 253         STRLEN llen;
 254         SvGETMAGIC(left);               /* or mg_get(left) may happen here */
 255         if (!SvOK(TARG)) {
 256             if (left == right && ckWARN(WARN_UNINITIALIZED))
 257                 report_uninit(right);
 258             sv_setpvn(left, "", 0);
 259         }
 260         (void)SvPV_nomg_const(left, llen);    /* Needed to set UTF8 flag */
 261         lbyte = !DO_UTF8(left);
 262         if (IN_BYTES)
 263             SvUTF8_off(TARG);
 264     }
 265
 266     /* or mg_get(right) may happen here */
 267     if (!rcopied) {
 268         rpv = SvPV_const(right, rlen);
 269         rbyte = !DO_UTF8(right);
 270     }
 271     if (lbyte != rbyte) {
 272         if (lbyte)
 273             sv_utf8_upgrade_nomg(TARG);
 274         else {
 275             if (!rcopied)
 276                 right = newSVpvn_flags(rpv, rlen, SVs_TEMP);
 277             sv_utf8_upgrade_nomg(right);
 278             rpv = SvPV_const(right, rlen);
 279         }
 280     }
 281     sv_catpvn_nomg(TARG, rpv, rlen);
 282
 283     SETTARG;
 284     RETURN;
 285   }
 286 }
 287
 288 PP(pp_padsv)
 289 {
 290     dVAR; dSP; dTARGET;
 291     XPUSHs(TARG);
 292     if (PL_op->op_flags & OPf_MOD) {
 293         if (PL_op->op_private & OPpLVAL_INTRO)
 294             if (!(PL_op->op_private & OPpPAD_STATE))
 295                 SAVECLEARSV(PAD_SVl(PL_op->op_targ));
 296         if (PL_op->op_private & OPpDEREF) {
 297             PUTBACK;
 298             vivify_ref(PAD_SVl(PL_op->op_targ), PL_op->op_private & OPpDEREF);
 299             SPAGAIN;
 300         }
 301     }
 302     RETURN;
 303 }
 304
 305 PP(pp_readline)
 306 {
 307     dVAR;
 308     tryAMAGICunTARGET(iter, 0);
 309     PL_last_in_gv = (GV*)(*PL_stack_sp--);
 310     if (SvTYPE(PL_last_in_gv) != SVt_PVGV) {
 311         if (SvROK(PL_last_in_gv) && SvTYPE(SvRV(PL_last_in_gv)) == SVt_PVGV)
 312             PL_last_in_gv = (GV*)SvRV(PL_last_in_gv);
 313         else {
 314             dSP;
 315             XPUSHs((SV*)PL_last_in_gv);
 316             PUTBACK;
 317             pp_rv2gv();
 318             PL_last_in_gv = (GV*)(*PL_stack_sp--);
 319         }
 320     }
 321     return do_readline();
 322 }
 323
 324 PP(pp_eq)
 325 {
 326     dVAR; dSP; tryAMAGICbinSET(eq,0);
 327 #ifndef NV_PRESERVES_UV
 328     if (SvROK(TOPs) && !SvAMAGIC(TOPs) && SvROK(TOPm1s) && !SvAMAGIC(TOPm1s)) {
 329         SP--;
 330         SETs(boolSV(SvRV(TOPs) == SvRV(TOPp1s)));
 331         RETURN;
 332     }
 333 #endif
 334 #ifdef PERL_PRESERVE_IVUV
 335     SvIV_please(TOPs);
 336     if (SvIOK(TOPs)) {
 337         /* Unless the left argument is integer in range we are going
 338            to have to use NV maths. Hence only attempt to coerce the
 339            right argument if we know the left is integer.  */
 340       SvIV_please(TOPm1s);
 341         if (SvIOK(TOPm1s)) {
 342             const bool auvok = SvUOK(TOPm1s);
 343             const bool buvok = SvUOK(TOPs);
 344
 345             if (auvok == buvok) { /* ## IV == IV or UV == UV ## */
 346                 /* Casting IV to UV before comparison isn't going to matter
 347                    on 2s complement. On 1s complement or sign&magnitude
 348                    (if we have any of them) it could to make negative zero
 349                    differ from normal zero. As I understand it. (Need to
 350                    check - is negative zero implementation defined behaviour
 351                    anyway?). NWC  */
 352                 const UV buv = SvUVX(POPs);
 353                 const UV auv = SvUVX(TOPs);
 354
 355                 SETs(boolSV(auv == buv));
 356                 RETURN;
 357             }
 358             {                   /* ## Mixed IV,UV ## */
 359                 SV *ivp, *uvp;
 360                 IV iv;
 361
 362                 /* == is commutative so doesn't matter which is left or right */
 363                 if (auvok) {
 364                     /* top of stack (b) is the iv */
 365                     ivp = *SP;
 366                     uvp = *--SP;
 367                 } else {
 368                     uvp = *SP;
 369                     ivp = *--SP;
 370                 }
 371                 iv = SvIVX(ivp);
 372                 if (iv < 0)
 373                     /* As uv is a UV, it's >0, so it cannot be == */
 374                     SETs(&PL_sv_no);
 375                 else
 376                     /* we know iv is >= 0 */
 377                     SETs(boolSV((UV)iv == SvUVX(uvp)));
 378                 RETURN;
 379             }
 380         }
 381     }
 382 #endif
 383     {
 384 #if defined(NAN_COMPARE_BROKEN) && defined(Perl_isnan)
 385       dPOPTOPnnrl;
 386       if (Perl_isnan(left) || Perl_isnan(right))
 387           RETSETNO;
 388       SETs(boolSV(left == right));
 389 #else
 390       dPOPnv;
 391       SETs(boolSV(TOPn == value));
 392 #endif
 393       RETURN;
 394     }
 395 }
 396
 397 PP(pp_preinc)
 398 {
 399     dVAR; dSP;
 400     if (SvTYPE(TOPs) >= SVt_PVGV && SvTYPE(TOPs) != SVt_PVLV)
 401         DIE(aTHX_ PL_no_modify);
 402     if (!SvREADONLY(TOPs) && SvIOK_notUV(TOPs) && !SvNOK(TOPs) && !SvPOK(TOPs)
 403         && SvIVX(TOPs) != IV_MAX)
 404     {
 405         SvIV_set(TOPs, SvIVX(TOPs) + 1);
 406         SvFLAGS(TOPs) &= ~(SVp_NOK|SVp_POK);
 407     }
 408     else /* Do all the PERL_PRESERVE_IVUV conditionals in sv_inc */
 409         sv_inc(TOPs);
 410     SvSETMAGIC(TOPs);
 411     return NORMAL;
 412 }
 413
 414 PP(pp_or)
 415 {
 416     dVAR; dSP;
 417     if (SvTRUE(TOPs))
 418         RETURN;
 419     else {
 420         if (PL_op->op_type == OP_OR)
 421             --SP;
 422         RETURNOP(cLOGOP->op_other);
 423     }
 424 }
 425
 426 PP(pp_defined)
 427 {
 428     dVAR; dSP;
 429     register SV* sv;
 430     bool defined;
 431     const int op_type = PL_op->op_type;
 432     const bool is_dor = (op_type == OP_DOR || op_type == OP_DORASSIGN);
 433
 434     if (is_dor) {
 435         sv = TOPs;
 436         if (!sv || !SvANY(sv)) {
 437             if (op_type == OP_DOR)
 438                 --SP;
 439             RETURNOP(cLOGOP->op_other);
 440         }
 441     }
 442     else {
 443         /* OP_DEFINED */
 444         sv = POPs;
 445         if (!sv || !SvANY(sv))
 446             RETPUSHNO;
 447     }
 448
 449     defined = FALSE;
 450     switch (SvTYPE(sv)) {
 451     case SVt_PVAV:
 452         if (AvMAX(sv) >= 0 || SvGMAGICAL(sv) || (SvRMAGICAL(sv) && mg_find(sv, PERL_MAGIC_tied)))
 453             defined = TRUE;
 454         break;
 455     case SVt_PVHV:
 456         if (HvARRAY(sv) || SvGMAGICAL(sv) || (SvRMAGICAL(sv) && mg_find(sv, PERL_MAGIC_tied)))
 457             defined = TRUE;
 458         break;
 459     case SVt_PVCV:
 460         if (CvROOT(sv) || CvXSUB(sv))
 461             defined = TRUE;
 462         break;
 463     default:
 464         SvGETMAGIC(sv);
 465         if (SvOK(sv))
 466             defined = TRUE;
 467         break;
 468     }
 469
 470     if (is_dor) {
 471         if(defined)
 472             RETURN;
 473         if(op_type == OP_DOR)
 474             --SP;
 475         RETURNOP(cLOGOP->op_other);
 476     }
 477     /* assuming OP_DEFINED */
 478     if(defined)
 479         RETPUSHYES;
 480     RETPUSHNO;
 481 }
 482
 483 PP(pp_add)
 484 {
 485     dVAR; dSP; dATARGET; bool useleft; SV *svl, *svr;
 486     tryAMAGICbin(add,opASSIGN);
 487     svl = sv_2num(TOPm1s);
 488     svr = sv_2num(TOPs);
 489     useleft = USE_LEFT(svl);
 490 #ifdef PERL_PRESERVE_IVUV
 491     /* We must see if we can perform the addition with integers if possible,
 492        as the integer code detects overflow while the NV code doesn't.
 493        If either argument hasn't had a numeric conversion yet attempt to get
 494        the IV. It's important to do this now, rather than just assuming that
 495        it's not IOK as a PV of "9223372036854775806" may not take well to NV
 496        addition, and an SV which is NOK, NV=6.0 ought to be coerced to
 497        integer in case the second argument is IV=9223372036854775806
 498        We can (now) rely on sv_2iv to do the right thing, only setting the
 499        public IOK flag if the value in the NV (or PV) slot is truly integer.
 500
 501        A side effect is that this also aggressively prefers integer maths over
 502        fp maths for integer values.
 503
 504        How to detect overflow?
 505
 506        C 99 section 6.2.6.1 says
 507
 508        The range of nonnegative values of a signed integer type is a subrange
 509        of the corresponding unsigned integer type, and the representation of
 510        the same value in each type is the same. A computation involving
 511        unsigned operands can never overflow, because a result that cannot be
 512        represented by the resulting unsigned integer type is reduced modulo
 513        the number that is one greater than the largest value that can be
 514        represented by the resulting type.
 515
 516        (the 9th paragraph)
 517
 518        which I read as "unsigned ints wrap."
 519
 520        signed integer overflow seems to be classed as "exception condition"
 521
 522        If an exceptional condition occurs during the evaluation of an
 523        expression (that is, if the result is not mathematically defined or not
 524        in the range of representable values for its type), the behavior is
 525        undefined.
 526
 527        (6.5, the 5th paragraph)
 528
 529        I had assumed that on 2s complement machines signed arithmetic would
 530        wrap, hence coded pp_add and pp_subtract on the assumption that
 531        everything perl builds on would be happy.  After much wailing and
 532        gnashing of teeth it would seem that irix64 knows its ANSI spec well,
 533        knows that it doesn't need to, and doesn't.  Bah.  Anyway, the all-
 534        unsigned code below is actually shorter than the old code. :-)
 535     */
 536
 537     SvIV_please(svr);
 538     if (SvIOK(svr)) {
 539         /* Unless the left argument is integer in range we are going to have to
 540            use NV maths. Hence only attempt to coerce the right argument if
 541            we know the left is integer.  */
 542         register UV auv = 0;
 543         bool auvok = FALSE;
 544         bool a_valid = 0;
 545
 546         if (!useleft) {
 547             auv = 0;
 548             a_valid = auvok = 1;
 549             /* left operand is undef, treat as zero. + 0 is identity,
 550                Could SETi or SETu right now, but space optimise by not adding
 551                lots of code to speed up what is probably a rarish case.  */
 552         } else {
 553             /* Left operand is defined, so is it IV? */
 554             SvIV_please(svl);
 555             if (SvIOK(svl)) {
 556                 if ((auvok = SvUOK(svl)))
 557                     auv = SvUVX(svl);
 558                 else {
 559                     register const IV aiv = SvIVX(svl);
 560                     if (aiv >= 0) {
 561                         auv = aiv;
 562                         auvok = 1;      /* Now acting as a sign flag.  */
 563                     } else { /* 2s complement assumption for IV_MIN */
 564                         auv = (UV)-aiv;
 565                     }
 566                 }
 567                 a_valid = 1;
 568             }
 569         }
 570         if (a_valid) {
 571             bool result_good = 0;
 572             UV result;
 573             register UV buv;
 574             bool buvok = SvUOK(svr);
 575
 576             if (buvok)
 577                 buv = SvUVX(svr);
 578             else {
 579                 register const IV biv = SvIVX(svr);
 580                 if (biv >= 0) {
 581                     buv = biv;
 582                     buvok = 1;
 583                 } else
 584                     buv = (UV)-biv;
 585             }
 586             /* ?uvok if value is >= 0. basically, flagged as UV if it's +ve,
 587                else "IV" now, independent of how it came in.
 588                if a, b represents positive, A, B negative, a maps to -A etc
 589                a + b =>  (a + b)
 590                A + b => -(a - b)
 591                a + B =>  (a - b)
 592                A + B => -(a + b)
 593                all UV maths. negate result if A negative.
 594                add if signs same, subtract if signs differ. */
 595
 596             if (auvok ^ buvok) {
 597                 /* Signs differ.  */
 598                 if (auv >= buv) {
 599                     result = auv - buv;
 600                     /* Must get smaller */
 601                     if (result <= auv)
 602                         result_good = 1;
 603                 } else {
 604                     result = buv - auv;
 605                     if (result <= buv) {
 606                         /* result really should be -(auv-buv). as its negation
 607                            of true value, need to swap our result flag  */
 608                         auvok = !auvok;
 609                         result_good = 1;
 610                     }
 611                 }
 612             } else {
 613                 /* Signs same */
 614                 result = auv + buv;
 615                 if (result >= auv)
 616                     result_good = 1;
 617             }
 618             if (result_good) {
 619                 SP--;
 620                 if (auvok)
 621                     SETu( result );
 622                 else {
 623                     /* Negate result */
 624                     if (result <= (UV)IV_MIN)
 625                         SETi( -(IV)result );
 626                     else {
 627                         /* result valid, but out of range for IV.  */
 628                         SETn( -(NV)result );
 629                     }
 630                 }
 631                 RETURN;
 632             } /* Overflow, drop through to NVs.  */
 633         }
 634     }
 635 #endif
 636     {
 637         NV value = SvNV(svr);
 638         (void)POPs;
 639         if (!useleft) {
 640             /* left operand is undef, treat as zero. + 0.0 is identity. */
 641             SETn(value);
 642             RETURN;
 643         }
 644         SETn( value + SvNV(svl) );
 645         RETURN;
 646     }
 647 }
 648
 649 PP(pp_aelemfast)
 650 {
 651     dVAR; dSP;
 652     AV * const av = PL_op->op_flags & OPf_SPECIAL ?
 653                 (AV*)PAD_SV(PL_op->op_targ) : GvAV(cGVOP_gv);
 654     const U32 lval = PL_op->op_flags & OPf_MOD;
 655     SV** const svp = av_fetch(av, PL_op->op_private, lval);
 656     SV *sv = (svp ? *svp : &PL_sv_undef);
 657     EXTEND(SP, 1);
 658     if (!lval && SvGMAGICAL(sv))        /* see note in pp_helem() */
 659         sv = sv_mortalcopy(sv);
 660     PUSHs(sv);
 661     RETURN;
 662 }
 663
 664 PP(pp_join)
 665 {
 666     dVAR; dSP; dMARK; dTARGET;
 667     MARK++;
 668     do_join(TARG, *MARK, MARK, SP);
 669     SP = MARK;
 670     SETs(TARG);
 671     RETURN;
 672 }
 673
 674 PP(pp_pushre)
 675 {
 676     dVAR; dSP;
 677 #ifdef DEBUGGING
 678     /*
 679      * We ass_u_me that LvTARGOFF() comes first, and that two STRLENs
 680      * will be enough to hold an OP*.
 681      */
 682     SV* const sv = sv_newmortal();
 683     sv_upgrade(sv, SVt_PVLV);
 684     LvTYPE(sv) = '/';
 685     Copy(&PL_op, &LvTARGOFF(sv), 1, OP*);
 686     XPUSHs(sv);
 687 #else
 688     XPUSHs((SV*)PL_op);
 689 #endif
 690     RETURN;
 691 }
 692
 693 /* Oversized hot code. */
 694
 695 PP(pp_print)
 696 {
 697     dVAR; dSP; dMARK; dORIGMARK;
 698     IO *io;
 699     register PerlIO *fp;
 700     MAGIC *mg;
 701     GV * const gv = (PL_op->op_flags & OPf_STACKED) ? (GV*)*++MARK : PL_defoutgv;
 702
 703     if (gv && (io = GvIO(gv))
 704         && (mg = SvTIED_mg((SV*)io, PERL_MAGIC_tiedscalar)))
 705     {
 706       had_magic:
 707         if (MARK == ORIGMARK) {
 708             /* If using default handle then we need to make space to
 709              * pass object as 1st arg, so move other args up ...
 710              */
 711             MEXTEND(SP, 1);
 712             ++MARK;
 713             Move(MARK, MARK + 1, (SP - MARK) + 1, SV*);
 714             ++SP;
 715         }
 716         PUSHMARK(MARK - 1);
 717         *MARK = SvTIED_obj((SV*)io, mg);
 718         PUTBACK;
 719         ENTER;
 720         if( PL_op->op_type == OP_SAY ) {
 721                 /* local $\ = "\n" */
 722                 SAVEGENERICSV(PL_ors_sv);
 723                 PL_ors_sv = newSVpvs("\n");
 724         }
 725         call_method("PRINT", G_SCALAR);
 726         LEAVE;
 727         SPAGAIN;
 728         MARK = ORIGMARK + 1;
 729         *MARK = *SP;
 730         SP = MARK;
 731         RETURN;
 732     }
 733     if (!(io = GvIO(gv))) {
 734         if ((GvEGV(gv)) && (io = GvIO(GvEGV(gv)))
 735             && (mg = SvTIED_mg((SV*)io, PERL_MAGIC_tiedscalar)))
 736             goto had_magic;
 737         if (ckWARN2(WARN_UNOPENED,WARN_CLOSED))
 738             report_evil_fh(gv, io, PL_op->op_type);
 739         SETERRNO(EBADF,RMS_IFI);
 740         goto just_say_no;
 741     }
 742     else if (!(fp = IoOFP(io))) {
 743         if (ckWARN2(WARN_CLOSED, WARN_IO))  {
 744             if (IoIFP(io))
 745                 report_evil_fh(gv, io, OP_phoney_INPUT_ONLY);
 746             else if (ckWARN2(WARN_UNOPENED,WARN_CLOSED))
 747                 report_evil_fh(gv, io, PL_op->op_type);
 748         }
 749         SETERRNO(EBADF,IoIFP(io)?RMS_FAC:RMS_IFI);
 750         goto just_say_no;
 751     }
 752     else {
 753         MARK++;
 754         if (PL_ofs_sv && SvOK(PL_ofs_sv)) {
 755             while (MARK <= SP) {
 756                 if (!do_print(*MARK, fp))
 757                     break;
 758                 MARK++;
 759                 if (MARK <= SP) {
 760                     if (!do_print(PL_ofs_sv, fp)) { /* $, */
 761                         MARK--;
 762                         break;
 763                     }
 764                 }
 765             }
 766         }
 767         else {
 768             while (MARK <= SP) {
 769                 if (!do_print(*MARK, fp))
 770                     break;
 771                 MARK++;
 772             }
 773         }
 774         if (MARK <= SP)
 775             goto just_say_no;
 776         else {
 777             if (PL_op->op_type == OP_SAY) {
 778                 if (PerlIO_write(fp, "\n", 1) == 0 || PerlIO_error(fp))
 779                     goto just_say_no;
 780             }
 781             else if (PL_ors_sv && SvOK(PL_ors_sv))
 782                 if (!do_print(PL_ors_sv, fp)) /* $\ */
 783                     goto just_say_no;
 784
 785             if (IoFLAGS(io) & IOf_FLUSH)
 786                 if (PerlIO_flush(fp) == EOF)
 787                     goto just_say_no;
 788         }
 789     }
 790     SP = ORIGMARK;
 791     XPUSHs(&PL_sv_yes);
 792     RETURN;
 793
 794   just_say_no:
 795     SP = ORIGMARK;
 796     XPUSHs(&PL_sv_undef);
 797     RETURN;
 798 }
 799
 800 PP(pp_rv2av)
 801 {
 802     dVAR; dSP; dTOPss;
 803     const I32 gimme = GIMME_V;
 804     static const char an_array[] = "an ARRAY";
 805     static const char a_hash[] = "a HASH";
 806     const bool is_pp_rv2av = PL_op->op_type == OP_RV2AV;
 807     const svtype type = is_pp_rv2av ? SVt_PVAV : SVt_PVHV;
 808
 809     if (SvROK(sv)) {
 810       wasref:
 811         tryAMAGICunDEREF_var(is_pp_rv2av ? to_av_amg : to_hv_amg);
 812
 813         sv = SvRV(sv);
 814         if (SvTYPE(sv) != type)
 815             DIE(aTHX_ "Not %s reference", is_pp_rv2av ? an_array : a_hash);
 816         if (PL_op->op_flags & OPf_REF) {
 817             SETs(sv);
 818             RETURN;
 819         }
 820         else if (LVRET) {
 821             if (gimme != G_ARRAY)
 822                 goto croak_cant_return;
 823             SETs(sv);
 824             RETURN;
 825         }
 826         else if (PL_op->op_flags & OPf_MOD
 827                 && PL_op->op_private & OPpLVAL_INTRO)
 828             Perl_croak(aTHX_ PL_no_localize_ref);
 829     }
 830     else {
 831         if (SvTYPE(sv) == type) {
 832             if (PL_op->op_flags & OPf_REF) {
 833                 SETs(sv);
 834                 RETURN;
 835             }
 836             else if (LVRET) {
 837                 if (gimme != G_ARRAY)
 838                     goto croak_cant_return;
 839                 SETs(sv);
 840                 RETURN;
 841             }
 842         }
 843         else {
 844             GV *gv;
 845
 846             if (SvTYPE(sv) != SVt_PVGV) {
 847                 if (SvGMAGICAL(sv)) {
 848                     mg_get(sv);
 849                     if (SvROK(sv))
 850                         goto wasref;
 851                 }
 852                 gv = Perl_softref2xv(aTHX_ sv, is_pp_rv2av ? an_array : a_hash,
 853                                      type, &sp);
 854                 if (!gv)
 855                     RETURN;
 856             }
 857             else {
 858                 gv = (GV*)sv;
 859             }
 860             sv = is_pp_rv2av ? (SV*)GvAVn(gv) : (SV*)GvHVn(gv);
 861             if (PL_op->op_private & OPpLVAL_INTRO)
 862                 sv = is_pp_rv2av ? (SV*)save_ary(gv) : (SV*)save_hash(gv);
 863             if (PL_op->op_flags & OPf_REF) {
 864                 SETs(sv);
 865                 RETURN;
 866             }
 867             else if (LVRET) {
 868                 if (gimme != G_ARRAY)
 869                     goto croak_cant_return;
 870                 SETs(sv);
 871                 RETURN;
 872             }
 873         }
 874     }
 875
 876     if (is_pp_rv2av) {
 877         AV *const av = (AV*)sv;
 878         /* The guts of pp_rv2av, with no intenting change to preserve history
 879            (until such time as we get tools that can do blame annotation across
 880            whitespace changes.  */
 881     if (gimme == G_ARRAY) {
 882         const I32 maxarg = AvFILL(av) + 1;
 883         (void)POPs;                     /* XXXX May be optimized away? */
 884         EXTEND(SP, maxarg);
 885         if (SvRMAGICAL(av)) {
 886             U32 i;
 887             for (i=0; i < (U32)maxarg; i++) {
 888                 SV ** const svp = av_fetch(av, i, FALSE);
 889                 /* See note in pp_helem, and bug id #27839 */
 890                 SP[i+1] = svp
 891                     ? SvGMAGICAL(*svp) ? sv_mortalcopy(*svp) : *svp
 892                     : &PL_sv_undef;
 893             }
 894         }
 895         else {
 896             Copy(AvARRAY(av), SP+1, maxarg, SV*);
 897         }
 898         SP += maxarg;
 899     }
 900     else if (gimme == G_SCALAR) {
 901         dTARGET;
 902         const I32 maxarg = AvFILL(av) + 1;
 903         SETi(maxarg);
 904     }
 905     } else {
 906         /* The guts of pp_rv2hv  */
 907     if (gimme == G_ARRAY) { /* array wanted */
 908         *PL_stack_sp = sv;
 909         return do_kv();
 910     }
 911     else if (gimme == G_SCALAR) {
 912         dTARGET;
 913     TARG = Perl_hv_scalar(aTHX_ (HV*)sv);
 914         SPAGAIN;
 915         SETTARG;
 916     }
 917     }
 918     RETURN;
 919
 920  croak_cant_return:
 921     Perl_croak(aTHX_ "Can't return %s to lvalue scalar context",
 922                is_pp_rv2av ? "array" : "hash");
 923     RETURN;
 924 }
 925
 926 STATIC void
 927 S_do_oddball(pTHX_ HV *hash, SV **relem, SV **firstrelem)
 928 {
 929     dVAR;
 930
 931     PERL_ARGS_ASSERT_DO_ODDBALL;
 932
 933     if (*relem) {
 934         SV *tmpstr;
 935         const HE *didstore;
 936
 937         if (ckWARN(WARN_MISC)) {
 938             const char *err;
 939             if (relem == firstrelem &&
 940                 SvROK(*relem) &&
 941                 (SvTYPE(SvRV(*relem)) == SVt_PVAV ||
 942                  SvTYPE(SvRV(*relem)) == SVt_PVHV))
 943             {
 944                 err = "Reference found where even-sized list expected";
 945             }
 946             else
 947                 err = "Odd number of elements in hash assignment";
 948             Perl_warner(aTHX_ packWARN(WARN_MISC), err);
 949         }
 950
 951         tmpstr = newSV(0);
 952         didstore = hv_store_ent(hash,*relem,tmpstr,0);
 953         if (SvMAGICAL(hash)) {
 954             if (SvSMAGICAL(tmpstr))
 955                 mg_set(tmpstr);
 956             if (!didstore)
 957                 sv_2mortal(tmpstr);
 958         }
 959         TAINT_NOT;
 960     }
 961 }
 962
 963 PP(pp_aassign)
 964 {
 965     dVAR; dSP;
 966     SV **lastlelem = PL_stack_sp;
 967     SV **lastrelem = PL_stack_base + POPMARK;
 968     SV **firstrelem = PL_stack_base + POPMARK + 1;
 969     SV **firstlelem = lastrelem + 1;
 970
 971     register SV **relem;
 972     register SV **lelem;
 973
 974     register SV *sv;
 975     register AV *ary;
 976
 977     I32 gimme;
 978     HV *hash;
 979     I32 i;
 980     int magic;
 981     int duplicates = 0;
 982     SV **firsthashrelem = NULL; /* "= 0" keeps gcc 2.95 quiet  */
 983
 984     PL_delaymagic = DM_DELAY;           /* catch simultaneous items */
 985     gimme = GIMME_V;
 986
 987     /* If there's a common identifier on both sides we have to take
 988      * special care that assigning the identifier on the left doesn't
 989      * clobber a value on the right that's used later in the list.
 990      */
 991     if (PL_op->op_private & (OPpASSIGN_COMMON)) {
 992         EXTEND_MORTAL(lastrelem - firstrelem + 1);
 993         for (relem = firstrelem; relem <= lastrelem; relem++) {
 994             if ((sv = *relem)) {
 995                 TAINT_NOT;      /* Each item is independent */
 996                 *relem = sv_mortalcopy(sv);
 997             }
 998         }
 999     }
1000
1001     relem = firstrelem;
1002     lelem = firstlelem;
1003     ary = NULL;
1004     hash = NULL;
1005
1006     while (lelem <= lastlelem) {
1007         TAINT_NOT;              /* Each item stands on its own, taintwise. */
1008         sv = *lelem++;
1009         switch (SvTYPE(sv)) {
1010         case SVt_PVAV:
1011             ary = (AV*)sv;
1012             magic = SvMAGICAL(ary) != 0;
1013             av_clear(ary);
1014             av_extend(ary, lastrelem - relem);
1015             i = 0;
1016             while (relem <= lastrelem) {        /* gobble up all the rest */
1017                 SV **didstore;
1018                 assert(*relem);
1019                 sv = newSVsv(*relem);
1020                 *(relem++) = sv;
1021                 didstore = av_store(ary,i++,sv);
1022                 if (magic) {
1023                     if (SvSMAGICAL(sv))
1024                         mg_set(sv);
1025                     if (!didstore)
1026                         sv_2mortal(sv);
1027                 }
1028                 TAINT_NOT;
1029             }
1030             if (PL_delaymagic & DM_ARRAY)
1031                 SvSETMAGIC((SV*)ary);
1032             break;
1033         case SVt_PVHV: {                                /* normal hash */
1034                 SV *tmpstr;
1035
1036                 hash = (HV*)sv;
1037                 magic = SvMAGICAL(hash) != 0;
1038                 hv_clear(hash);
1039                 firsthashrelem = relem;
1040
1041                 while (relem < lastrelem) {     /* gobble up all the rest */
1042                     HE *didstore;
1043                     sv = *relem ? *relem : &PL_sv_no;
1044                     relem++;
1045                     tmpstr = newSV(0);
1046                     if (*relem)
1047                         sv_setsv(tmpstr,*relem);        /* value */
1048                     *(relem++) = tmpstr;
1049                     if (gimme != G_VOID && hv_exists_ent(hash, sv, 0))
1050                         /* key overwrites an existing entry */
1051                         duplicates += 2;
1052                     didstore = hv_store_ent(hash,sv,tmpstr,0);
1053                     if (magic) {
1054                         if (SvSMAGICAL(tmpstr))
1055                             mg_set(tmpstr);
1056                         if (!didstore)
1057                             sv_2mortal(tmpstr);
1058                     }
1059                     TAINT_NOT;
1060                 }
1061                 if (relem == lastrelem) {
1062                     do_oddball(hash, relem, firstrelem);
1063                     relem++;
1064                 }
1065             }
1066             break;
1067         default:
1068             if (SvIMMORTAL(sv)) {
1069                 if (relem <= lastrelem)
1070                     relem++;
1071                 break;
1072             }
1073             if (relem <= lastrelem) {
1074                 sv_setsv(sv, *relem);
1075                 *(relem++) = sv;
1076             }
1077             else
1078                 sv_setsv(sv, &PL_sv_undef);
1079             SvSETMAGIC(sv);
1080             break;
1081         }
1082     }
1083     if (PL_delaymagic & ~DM_DELAY) {
1084         if (PL_delaymagic & DM_UID) {
1085 #ifdef HAS_SETRESUID
1086             (void)setresuid((PL_delaymagic & DM_RUID) ? PL_uid  : (Uid_t)-1,
1087                             (PL_delaymagic & DM_EUID) ? PL_euid : (Uid_t)-1,
1088                             (Uid_t)-1);
1089 #else
1090 #  ifdef HAS_SETREUID
1091             (void)setreuid((PL_delaymagic & DM_RUID) ? PL_uid  : (Uid_t)-1,
1092                            (PL_delaymagic & DM_EUID) ? PL_euid : (Uid_t)-1);
1093 #  else
1094 #    ifdef HAS_SETRUID
1095             if ((PL_delaymagic & DM_UID) == DM_RUID) {
1096                 (void)setruid(PL_uid);
1097                 PL_delaymagic &= ~DM_RUID;
1098             }
1099 #    endif /* HAS_SETRUID */
1100 #    ifdef HAS_SETEUID
1101             if ((PL_delaymagic & DM_UID) == DM_EUID) {
1102                 (void)seteuid(PL_euid);
1103                 PL_delaymagic &= ~DM_EUID;
1104             }
1105 #    endif /* HAS_SETEUID */
1106             if (PL_delaymagic & DM_UID) {
1107                 if (PL_uid != PL_euid)
1108                     DIE(aTHX_ "No setreuid available");
1109                 (void)PerlProc_setuid(PL_uid);
1110             }
1111 #  endif /* HAS_SETREUID */
1112 #endif /* HAS_SETRESUID */
1113             PL_uid = PerlProc_getuid();
1114             PL_euid = PerlProc_geteuid();
1115         }
1116         if (PL_delaymagic & DM_GID) {
1117 #ifdef HAS_SETRESGID
1118             (void)setresgid((PL_delaymagic & DM_RGID) ? PL_gid  : (Gid_t)-1,
1119                             (PL_delaymagic & DM_EGID) ? PL_egid : (Gid_t)-1,
1120                             (Gid_t)-1);
1121 #else
1122 #  ifdef HAS_SETREGID
1123             (void)setregid((PL_delaymagic & DM_RGID) ? PL_gid  : (Gid_t)-1,
1124                            (PL_delaymagic & DM_EGID) ? PL_egid : (Gid_t)-1);
1125 #  else
1126 #    ifdef HAS_SETRGID
1127             if ((PL_delaymagic & DM_GID) == DM_RGID) {
1128                 (void)setrgid(PL_gid);
1129                 PL_delaymagic &= ~DM_RGID;
1130             }
1131 #    endif /* HAS_SETRGID */
1132 #    ifdef HAS_SETEGID
1133             if ((PL_delaymagic & DM_GID) == DM_EGID) {
1134                 (void)setegid(PL_egid);
1135                 PL_delaymagic &= ~DM_EGID;
1136             }
1137 #    endif /* HAS_SETEGID */
1138             if (PL_delaymagic & DM_GID) {
1139                 if (PL_gid != PL_egid)
1140                     DIE(aTHX_ "No setregid available");
1141                 (void)PerlProc_setgid(PL_gid);
1142             }
1143 #  endif /* HAS_SETREGID */
1144 #endif /* HAS_SETRESGID */
1145             PL_gid = PerlProc_getgid();
1146             PL_egid = PerlProc_getegid();
1147         }
1148         PL_tainting |= (PL_uid && (PL_euid != PL_uid || PL_egid != PL_gid));
1149     }
1150     PL_delaymagic = 0;
1151
1152     if (gimme == G_VOID)
1153         SP = firstrelem - 1;
1154     else if (gimme == G_SCALAR) {
1155         dTARGET;
1156         SP = firstrelem;
1157         SETi(lastrelem - firstrelem + 1 - duplicates);
1158     }
1159     else {
1160         if (ary)
1161             SP = lastrelem;
1162         else if (hash) {
1163             if (duplicates) {
1164                 /* Removes from the stack the entries which ended up as
1165                  * duplicated keys in the hash (fix for [perl #24380]) */
1166                 Move(firsthashrelem + duplicates,
1167                         firsthashrelem, duplicates, SV**);
1168                 lastrelem -= duplicates;
1169             }
1170             SP = lastrelem;
1171         }
1172         else
1173             SP = firstrelem + (lastlelem - firstlelem);
1174         lelem = firstlelem + (relem - firstrelem);
1175         while (relem <= SP)
1176             *relem++ = (lelem <= lastlelem) ? *lelem++ : &PL_sv_undef;
1177     }
1178
1179     RETURN;
1180 }
1181
1182 PP(pp_qr)
1183 {
1184     dVAR; dSP;
1185     register PMOP * const pm = cPMOP;
1186     REGEXP * rx = PM_GETRE(pm);
1187     SV * const pkg = rx ? CALLREG_PACKAGE(rx) : NULL;
1188     SV * const rv = sv_newmortal();
1189
1190     SvUPGRADE(rv, SVt_IV);
1191     /* This RV is about to own a reference to the regexp. (In addition to the
1192        reference already owned by the PMOP.  */
1193     ReREFCNT_inc(rx);
1194     SvRV_set(rv, (SV*) rx);
1195     SvROK_on(rv);
1196
1197     if (pkg) {
1198         HV* const stash = gv_stashpv(SvPV_nolen(pkg), GV_ADD);
1199         (void)sv_bless(rv, stash);
1200     }
1201
1202     if (RX_EXTFLAGS(rx) & RXf_TAINTED)
1203         SvTAINTED_on(rv);
1204     XPUSHs(rv);
1205     RETURN;
1206 }
1207
1208 PP(pp_match)
1209 {
1210     dVAR; dSP; dTARG;
1211     register PMOP *pm = cPMOP;
1212     PMOP *dynpm = pm;
1213     register const char *t;
1214     register const char *s;
1215     const char *strend;
1216     I32 global;
1217     U8 r_flags = REXEC_CHECKED;
1218     const char *truebase;                       /* Start of string  */
1219     register REGEXP *rx = PM_GETRE(pm);
1220     bool rxtainted;
1221     const I32 gimme = GIMME;
1222     STRLEN len;
1223     I32 minmatch = 0;
1224     const I32 oldsave = PL_savestack_ix;
1225     I32 update_minmatch = 1;
1226     I32 had_zerolen = 0;
1227     U32 gpos = 0;
1228
1229     if (PL_op->op_flags & OPf_STACKED)
1230         TARG = POPs;
1231     else if (PL_op->op_private & OPpTARGET_MY)
1232         GETTARGET;
1233     else {
1234         TARG = DEFSV;
1235         EXTEND(SP,1);
1236     }
1237
1238     PUTBACK;                            /* EVAL blocks need stack_sp. */
1239     s = SvPV_const(TARG, len);
1240     if (!s)
1241         DIE(aTHX_ "panic: pp_match");
1242     strend = s + len;
1243     rxtainted = ((RX_EXTFLAGS(rx) & RXf_TAINTED) ||
1244                  (PL_tainted && (pm->op_pmflags & PMf_RETAINT)));
1245     TAINT_NOT;
1246
1247     RX_MATCH_UTF8_set(rx, DO_UTF8(TARG));
1248
1249     /* PMdf_USED is set after a ?? matches once */
1250     if (
1251 #ifdef USE_ITHREADS
1252         SvREADONLY(PL_regex_pad[pm->op_pmoffset])
1253 #else
1254         pm->op_pmflags & PMf_USED
1255 #endif
1256     ) {
1257       failure:
1258         if (gimme == G_ARRAY)
1259             RETURN;
1260         RETPUSHNO;
1261     }
1262
1263
1264
1265     /* empty pattern special-cased to use last successful pattern if possible */
1266     if (!RX_PRELEN(rx) && PL_curpm) {
1267         pm = PL_curpm;
1268         rx = PM_GETRE(pm);
1269     }
1270
1271     if (RX_MINLEN(rx) > (I32)len)
1272         goto failure;
1273
1274     truebase = t = s;
1275
1276     /* XXXX What part of this is needed with true \G-support? */
1277     if ((global = dynpm->op_pmflags & PMf_GLOBAL)) {
1278         RX_OFFS(rx)[0].start = -1;
1279         if (SvTYPE(TARG) >= SVt_PVMG && SvMAGIC(TARG)) {
1280             MAGIC* const mg = mg_find(TARG, PERL_MAGIC_regex_global);
1281             if (mg && mg->mg_len >= 0) {
1282                 if (!(RX_EXTFLAGS(rx) & RXf_GPOS_SEEN))
1283                     RX_OFFS(rx)[0].end = RX_OFFS(rx)[0].start = mg->mg_len;
1284                 else if (RX_EXTFLAGS(rx) & RXf_ANCH_GPOS) {
1285                     r_flags |= REXEC_IGNOREPOS;
1286                     RX_OFFS(rx)[0].end = RX_OFFS(rx)[0].start = mg->mg_len;
1287                 } else if (RX_EXTFLAGS(rx) & RXf_GPOS_FLOAT)
1288                     gpos = mg->mg_len;
1289                 else
1290                     RX_OFFS(rx)[0].end = RX_OFFS(rx)[0].start = mg->mg_len;
1291                 minmatch = (mg->mg_flags & MGf_MINMATCH) ? RX_GOFS(rx) + 1 : 0;
1292                 update_minmatch = 0;
1293             }
1294         }
1295     }
1296     /* XXX: comment out !global get safe $1 vars after a
1297        match, BUT be aware that this leads to dramatic slowdowns on
1298        /g matches against large strings.  So far a solution to this problem
1299        appears to be quite tricky.
1300        Test for the unsafe vars are TODO for now. */
1301     if ((  !global && RX_NPARENS(rx))
1302             || SvTEMP(TARG) || PL_sawampersand ||
1303             (RX_EXTFLAGS(rx) & (RXf_EVAL_SEEN|RXf_PMf_KEEPCOPY)))
1304         r_flags |= REXEC_COPY_STR;
1305     if (SvSCREAM(TARG))
1306         r_flags |= REXEC_SCREAM;
1307
1308 play_it_again:
1309     if (global && RX_OFFS(rx)[0].start != -1) {
1310         t = s = RX_OFFS(rx)[0].end + truebase - RX_GOFS(rx);
1311         if ((s + RX_MINLEN(rx)) > strend || s < truebase)
1312             goto nope;
1313         if (update_minmatch++)
1314             minmatch = had_zerolen;
1315     }
1316     if (RX_EXTFLAGS(rx) & RXf_USE_INTUIT &&
1317         DO_UTF8(TARG) == (RX_UTF8(rx) != 0)) {
1318         /* FIXME - can PL_bostr be made const char *?  */
1319         PL_bostr = (char *)truebase;
1320         s = CALLREG_INTUIT_START(rx, TARG, (char *)s, (char *)strend, r_flags, NULL);
1321
1322         if (!s)
1323             goto nope;
1324         if ( (RX_EXTFLAGS(rx) & RXf_CHECK_ALL)
1325              && !PL_sawampersand
1326              && !(RX_EXTFLAGS(rx) & RXf_PMf_KEEPCOPY)
1327              && ((RX_EXTFLAGS(rx) & RXf_NOSCAN)
1328                  || !((RX_EXTFLAGS(rx) & RXf_INTUIT_TAIL)
1329                       && (r_flags & REXEC_SCREAM)))
1330              && !SvROK(TARG))   /* Cannot trust since INTUIT cannot guess ^ */
1331             goto yup;
1332     }
1333     if (CALLREGEXEC(rx, (char*)s, (char *)strend, (char*)truebase,
1334                     minmatch, TARG, NUM2PTR(void*, gpos), r_flags))
1335     {
1336         PL_curpm = pm;
1337         if (dynpm->op_pmflags & PMf_ONCE) {
1338 #ifdef USE_ITHREADS
1339             SvREADONLY_on(PL_regex_pad[dynpm->op_pmoffset]);
1340 #else
1341             dynpm->op_pmflags |= PMf_USED;
1342 #endif
1343         }
1344         goto gotcha;
1345     }
1346     else
1347         goto ret_no;
1348     /*NOTREACHED*/
1349
1350   gotcha:
1351     if (rxtainted)
1352         RX_MATCH_TAINTED_on(rx);
1353     TAINT_IF(RX_MATCH_TAINTED(rx));
1354     if (gimme == G_ARRAY) {
1355         const I32 nparens = RX_NPARENS(rx);
1356         I32 i = (global && !nparens) ? 1 : 0;
1357
1358         SPAGAIN;                        /* EVAL blocks could move the stack. */
1359         EXTEND(SP, nparens + i);
1360         EXTEND_MORTAL(nparens + i);
1361         for (i = !i; i <= nparens; i++) {
1362             PUSHs(sv_newmortal());
1363             if ((RX_OFFS(rx)[i].start != -1) && RX_OFFS(rx)[i].end != -1 ) {
1364                 const I32 len = RX_OFFS(rx)[i].end - RX_OFFS(rx)[i].start;
1365                 s = RX_OFFS(rx)[i].start + truebase;
1366                 if (RX_OFFS(rx)[i].end < 0 || RX_OFFS(rx)[i].start < 0 ||
1367                     len < 0 || len > strend - s)
1368                     DIE(aTHX_ "panic: pp_match start/end pointers");
1369                 sv_setpvn(*SP, s, len);
1370                 if (DO_UTF8(TARG) && is_utf8_string((U8*)s, len))
1371                     SvUTF8_on(*SP);
1372             }
1373         }
1374         if (global) {
1375             if (dynpm->op_pmflags & PMf_CONTINUE) {
1376                 MAGIC* mg = NULL;
1377                 if (SvTYPE(TARG) >= SVt_PVMG && SvMAGIC(TARG))
1378                     mg = mg_find(TARG, PERL_MAGIC_regex_global);
1379                 if (!mg) {
1380 #ifdef PERL_OLD_COPY_ON_WRITE
1381                     if (SvIsCOW(TARG))
1382                         sv_force_normal_flags(TARG, 0);
1383 #endif
1384                     mg = sv_magicext(TARG, NULL, PERL_MAGIC_regex_global,
1385                                      &PL_vtbl_mglob, NULL, 0);
1386                 }
1387                 if (RX_OFFS(rx)[0].start != -1) {
1388                     mg->mg_len = RX_OFFS(rx)[0].end;
1389                     if (RX_OFFS(rx)[0].start + RX_GOFS(rx) == (UV)RX_OFFS(rx)[0].end)
1390                         mg->mg_flags |= MGf_MINMATCH;
1391                     else
1392                         mg->mg_flags &= ~MGf_MINMATCH;
1393                 }
1394             }
1395             had_zerolen = (RX_OFFS(rx)[0].start != -1
1396                            && (RX_OFFS(rx)[0].start + RX_GOFS(rx)
1397                                == (UV)RX_OFFS(rx)[0].end));
1398             PUTBACK;                    /* EVAL blocks may use stack */
1399             r_flags |= REXEC_IGNOREPOS | REXEC_NOT_FIRST;
1400             goto play_it_again;
1401         }
1402         else if (!nparens)
1403             XPUSHs(&PL_sv_yes);
1404         LEAVE_SCOPE(oldsave);
1405         RETURN;
1406     }
1407     else {
1408         if (global) {
1409             MAGIC* mg;
1410             if (SvTYPE(TARG) >= SVt_PVMG && SvMAGIC(TARG))
1411                 mg = mg_find(TARG, PERL_MAGIC_regex_global);
1412             else
1413                 mg = NULL;
1414             if (!mg) {
1415 #ifdef PERL_OLD_COPY_ON_WRITE
1416                 if (SvIsCOW(TARG))
1417                     sv_force_normal_flags(TARG, 0);
1418 #endif
1419                 mg = sv_magicext(TARG, NULL, PERL_MAGIC_regex_global,
1420                                  &PL_vtbl_mglob, NULL, 0);
1421             }
1422             if (RX_OFFS(rx)[0].start != -1) {
1423                 mg->mg_len = RX_OFFS(rx)[0].end;
1424                 if (RX_OFFS(rx)[0].start + RX_GOFS(rx) == (UV)RX_OFFS(rx)[0].end)
1425                     mg->mg_flags |= MGf_MINMATCH;
1426                 else
1427                     mg->mg_flags &= ~MGf_MINMATCH;
1428             }
1429         }
1430         LEAVE_SCOPE(oldsave);
1431         RETPUSHYES;
1432     }
1433
1434 yup:                                    /* Confirmed by INTUIT */
1435     if (rxtainted)
1436         RX_MATCH_TAINTED_on(rx);
1437     TAINT_IF(RX_MATCH_TAINTED(rx));
1438     PL_curpm = pm;
1439     if (dynpm->op_pmflags & PMf_ONCE) {
1440 #ifdef USE_ITHREADS
1441         SvREADONLY_on(PL_regex_pad[dynpm->op_pmoffset]);
1442 #else
1443         dynpm->op_pmflags |= PMf_USED;
1444 #endif
1445     }
1446     if (RX_MATCH_COPIED(rx))
1447         Safefree(RX_SUBBEG(rx));
1448     RX_MATCH_COPIED_off(rx);
1449     RX_SUBBEG(rx) = NULL;
1450     if (global) {
1451         /* FIXME - should rx->subbeg be const char *?  */
1452         RX_SUBBEG(rx) = (char *) truebase;
1453         RX_OFFS(rx)[0].start = s - truebase;
1454         if (RX_MATCH_UTF8(rx)) {
1455             char * const t = (char*)utf8_hop((U8*)s, RX_MINLENRET(rx));
1456             RX_OFFS(rx)[0].end = t - truebase;
1457         }
1458         else {
1459             RX_OFFS(rx)[0].end = s - truebase + RX_MINLENRET(rx);
1460         }
1461         RX_SUBLEN(rx) = strend - truebase;
1462         goto gotcha;
1463     }
1464     if (PL_sawampersand || RX_EXTFLAGS(rx) & RXf_PMf_KEEPCOPY) {
1465         I32 off;
1466 #ifdef PERL_OLD_COPY_ON_WRITE
1467         if (SvIsCOW(TARG) || (SvFLAGS(TARG) & CAN_COW_MASK) == CAN_COW_FLAGS) {
1468             if (DEBUG_C_TEST) {
1469                 PerlIO_printf(Perl_debug_log,
1470                               "Copy on write: pp_match $& capture, type %d, truebase=%p, t=%p, difference %d\n",
1471                               (int) SvTYPE(TARG), (void*)truebase, (void*)t,
1472                               (int)(t-truebase));
1473             }
1474             RX_SAVED_COPY(rx) = sv_setsv_cow(RX_SAVED_COPY(rx), TARG);
1475             RX_SUBBEG(rx)
1476                 = (char *) SvPVX_const(RX_SAVED_COPY(rx)) + (t - truebase);
1477             assert (SvPOKp(RX_SAVED_COPY(rx)));
1478         } else
1479 #endif
1480         {
1481
1482             RX_SUBBEG(rx) = savepvn(t, strend - t);
1483 #ifdef PERL_OLD_COPY_ON_WRITE
1484             RX_SAVED_COPY(rx) = NULL;
1485 #endif
1486         }
1487         RX_SUBLEN(rx) = strend - t;
1488         RX_MATCH_COPIED_on(rx);
1489         off = RX_OFFS(rx)[0].start = s - t;
1490         RX_OFFS(rx)[0].end = off + RX_MINLENRET(rx);
1491     }
1492     else {                      /* startp/endp are used by @- @+. */
1493         RX_OFFS(rx)[0].start = s - truebase;
1494         RX_OFFS(rx)[0].end = s - truebase + RX_MINLENRET(rx);
1495     }
1496     /* including RX_NPARENS(rx) in the below code seems highly suspicious.
1497        -dmq */
1498     RX_NPARENS(rx) = RX_LASTPAREN(rx) = RX_LASTCLOSEPAREN(rx) = 0;      /* used by @-, @+, and $^N */
1499     LEAVE_SCOPE(oldsave);
1500     RETPUSHYES;
1501
1502 nope:
1503 ret_no:
1504     if (global && !(dynpm->op_pmflags & PMf_CONTINUE)) {
1505         if (SvTYPE(TARG) >= SVt_PVMG && SvMAGIC(TARG)) {
1506             MAGIC* const mg = mg_find(TARG, PERL_MAGIC_regex_global);
1507             if (mg)
1508                 mg->mg_len = -1;
1509         }
1510     }
1511     LEAVE_SCOPE(oldsave);
1512     if (gimme == G_ARRAY)
1513         RETURN;
1514     RETPUSHNO;
1515 }
1516
1517 OP *
1518 Perl_do_readline(pTHX)
1519 {
1520     dVAR; dSP; dTARGETSTACKED;
1521     register SV *sv;
1522     STRLEN tmplen = 0;
1523     STRLEN offset;
1524     PerlIO *fp;
1525     register IO * const io = GvIO(PL_last_in_gv);
1526     register const I32 type = PL_op->op_type;
1527     const I32 gimme = GIMME_V;
1528
1529     if (io) {
1530         MAGIC * const mg = SvTIED_mg((SV*)io, PERL_MAGIC_tiedscalar);
1531         if (mg) {
1532             PUSHMARK(SP);
1533             XPUSHs(SvTIED_obj((SV*)io, mg));
1534             PUTBACK;
1535             ENTER;
1536             call_method("READLINE", gimme);
1537             LEAVE;
1538             SPAGAIN;
1539             if (gimme == G_SCALAR) {
1540                 SV* const result = POPs;
1541                 SvSetSV_nosteal(TARG, result);
1542                 PUSHTARG;
1543             }
1544             RETURN;
1545         }
1546     }
1547     fp = NULL;
1548     if (io) {
1549         fp = IoIFP(io);
1550         if (!fp) {
1551             if (IoFLAGS(io) & IOf_ARGV) {
1552                 if (IoFLAGS(io) & IOf_START) {
1553                     IoLINES(io) = 0;
1554                     if (av_len(GvAVn(PL_last_in_gv)) < 0) {
1555                         IoFLAGS(io) &= ~IOf_START;
1556                         do_open(PL_last_in_gv,"-",1,FALSE,O_RDONLY,0,NULL);
1557                         sv_setpvn(GvSVn(PL_last_in_gv), "-", 1);
1558                         SvSETMAGIC(GvSV(PL_last_in_gv));
1559                         fp = IoIFP(io);
1560                         goto have_fp;
1561                     }
1562                 }
1563                 fp = nextargv(PL_last_in_gv);
1564                 if (!fp) { /* Note: fp != IoIFP(io) */
1565                     (void)do_close(PL_last_in_gv, FALSE); /* now it does*/
1566                 }
1567             }
1568             else if (type == OP_GLOB)
1569                 fp = Perl_start_glob(aTHX_ POPs, io);
1570         }
1571         else if (type == OP_GLOB)
1572             SP--;
1573         else if (ckWARN(WARN_IO) && IoTYPE(io) == IoTYPE_WRONLY) {
1574             report_evil_fh(PL_last_in_gv, io, OP_phoney_OUTPUT_ONLY);
1575         }
1576     }
1577     if (!fp) {
1578         if ((!io || !(IoFLAGS(io) & IOf_START))
1579             && ckWARN2(WARN_GLOB, WARN_CLOSED))
1580         {
1581             if (type == OP_GLOB)
1582                 Perl_warner(aTHX_ packWARN(WARN_GLOB),
1583                             "glob failed (can't start child: %s)",
1584                             Strerror(errno));
1585             else
1586                 report_evil_fh(PL_last_in_gv, io, PL_op->op_type);
1587         }
1588         if (gimme == G_SCALAR) {
1589             /* undef TARG, and push that undefined value */
1590             if (type != OP_RCATLINE) {
1591                 SV_CHECK_THINKFIRST_COW_DROP(TARG);
1592                 SvOK_off(TARG);
1593             }
1594             PUSHTARG;
1595         }
1596         RETURN;
1597     }
1598   have_fp:
1599     if (gimme == G_SCALAR) {
1600         sv = TARG;
1601         if (type == OP_RCATLINE && SvGMAGICAL(sv))
1602             mg_get(sv);
1603         if (SvROK(sv)) {
1604             if (type == OP_RCATLINE)
1605                 SvPV_force_nolen(sv);
1606             else
1607                 sv_unref(sv);
1608         }
1609         else if (isGV_with_GP(sv)) {
1610             SvPV_force_nolen(sv);
1611         }
1612         SvUPGRADE(sv, SVt_PV);
1613         tmplen = SvLEN(sv);     /* remember if already alloced */
1614         if (!tmplen && !SvREADONLY(sv))
1615             Sv_Grow(sv, 80);    /* try short-buffering it */
1616         offset = 0;
1617         if (type == OP_RCATLINE && SvOK(sv)) {
1618             if (!SvPOK(sv)) {
1619                 SvPV_force_nolen(sv);
1620             }
1621             offset = SvCUR(sv);
1622         }
1623     }
1624     else {
1625         sv = sv_2mortal(newSV(80));
1626         offset = 0;
1627     }
1628
1629     /* This should not be marked tainted if the fp is marked clean */
1630 #define MAYBE_TAINT_LINE(io, sv) \
1631     if (!(IoFLAGS(io) & IOf_UNTAINT)) { \
1632         TAINT;                          \
1633         SvTAINTED_on(sv);               \
1634     }
1635
1636 /* delay EOF state for a snarfed empty file */
1637 #define SNARF_EOF(gimme,rs,io,sv) \
1638     (gimme != G_SCALAR || SvCUR(sv)                                     \
1639      || (IoFLAGS(io) & IOf_NOLINE) || !RsSNARF(rs))
1640
1641     for (;;) {
1642         PUTBACK;
1643         if (!sv_gets(sv, fp, offset)
1644             && (type == OP_GLOB
1645                 || SNARF_EOF(gimme, PL_rs, io, sv)
1646                 || PerlIO_error(fp)))
1647         {
1648             PerlIO_clearerr(fp);
1649             if (IoFLAGS(io) & IOf_ARGV) {
1650                 fp = nextargv(PL_last_in_gv);
1651                 if (fp)
1652                     continue;
1653                 (void)do_close(PL_last_in_gv, FALSE);
1654             }
1655             else if (type == OP_GLOB) {
1656                 if (!do_close(PL_last_in_gv, FALSE) && ckWARN(WARN_GLOB)) {
1657                     Perl_warner(aTHX_ packWARN(WARN_GLOB),
1658                            "glob failed (child exited with status %d%s)",
1659                            (int)(STATUS_CURRENT >> 8),
1660                            (STATUS_CURRENT & 0x80) ? ", core dumped" : "");
1661                 }
1662             }
1663             if (gimme == G_SCALAR) {
1664                 if (type != OP_RCATLINE) {
1665                     SV_CHECK_THINKFIRST_COW_DROP(TARG);
1666                     SvOK_off(TARG);
1667                 }
1668                 SPAGAIN;
1669                 PUSHTARG;
1670             }
1671             MAYBE_TAINT_LINE(io, sv);
1672             RETURN;
1673         }
1674         MAYBE_TAINT_LINE(io, sv);
1675         IoLINES(io)++;
1676         IoFLAGS(io) |= IOf_NOLINE;
1677         SvSETMAGIC(sv);
1678         SPAGAIN;
1679         XPUSHs(sv);
1680         if (type == OP_GLOB) {
1681             const char *t1;
1682
1683             if (SvCUR(sv) > 0 && SvCUR(PL_rs) > 0) {
1684                 char * const tmps = SvEND(sv) - 1;
1685                 if (*tmps == *SvPVX_const(PL_rs)) {
1686                     *tmps = '\0';
1687                     SvCUR_set(sv, SvCUR(sv) - 1);
1688                 }
1689             }
1690             for (t1 = SvPVX_const(sv); *t1; t1++)
1691                 if (!isALPHA(*t1) && !isDIGIT(*t1) &&
1692                     strchr("$&*(){}[]'\";\\|?<>~`", *t1))
1693                         break;
1694             if (*t1 && PerlLIO_lstat(SvPVX_const(sv), &PL_statbuf) < 0) {
1695                 (void)POPs;             /* Unmatched wildcard?  Chuck it... */
1696                 continue;
1697             }
1698         } else if (SvUTF8(sv)) { /* OP_READLINE, OP_RCATLINE */
1699              if (ckWARN(WARN_UTF8)) {
1700                 const U8 * const s = (const U8*)SvPVX_const(sv) + offset;
1701                 const STRLEN len = SvCUR(sv) - offset;
1702                 const U8 *f;
1703
1704                 if (!is_utf8_string_loc(s, len, &f))
1705                     /* Emulate :encoding(utf8) warning in the same case. */
1706                     Perl_warner(aTHX_ packWARN(WARN_UTF8),
1707                                 "utf8 \"\\x%02X\" does not map to Unicode",
1708                                 f < (U8*)SvEND(sv) ? *f : 0);
1709              }
1710         }
1711         if (gimme == G_ARRAY) {
1712             if (SvLEN(sv) - SvCUR(sv) > 20) {
1713                 SvPV_shrink_to_cur(sv);
1714             }
1715             sv = sv_2mortal(newSV(80));
1716             continue;
1717         }
1718         else if (gimme == G_SCALAR && !tmplen && SvLEN(sv) - SvCUR(sv) > 80) {
1719             /* try to reclaim a bit of scalar space (only on 1st alloc) */
1720             const STRLEN new_len
1721                 = SvCUR(sv) < 60 ? 80 : SvCUR(sv)+40; /* allow some slop */
1722             SvPV_renew(sv, new_len);
1723         }
1724         RETURN;
1725     }
1726 }
1727
1728 PP(pp_enter)
1729 {
1730     dVAR; dSP;
1731     register PERL_CONTEXT *cx;
1732     I32 gimme = OP_GIMME(PL_op, -1);
1733
1734     if (gimme == -1) {
1735         if (cxstack_ix >= 0)
1736             gimme = cxstack[cxstack_ix].blk_gimme;
1737         else
1738             gimme = G_SCALAR;
1739     }
1740
1741     ENTER;
1742
1743     SAVETMPS;
1744     PUSHBLOCK(cx, CXt_BLOCK, SP);
1745
1746     RETURN;
1747 }
1748
1749 PP(pp_helem)
1750 {
1751     dVAR; dSP;
1752     HE* he;
1753     SV **svp;
1754     SV * const keysv = POPs;
1755     HV * const hv = (HV*)POPs;
1756     const U32 lval = PL_op->op_flags & OPf_MOD || LVRET;
1757     const U32 defer = PL_op->op_private & OPpLVAL_DEFER;
1758     SV *sv;
1759     const U32 hash = (SvIsCOW_shared_hash(keysv)) ? SvSHARED_HASH(keysv) : 0;
1760     I32 preeminent = 0;
1761
1762     if (SvTYPE(hv) != SVt_PVHV)
1763         RETPUSHUNDEF;
1764
1765     if (PL_op->op_private & OPpLVAL_INTRO) {
1766         MAGIC *mg;
1767         HV *stash;
1768         /* does the element we're localizing already exist? */
1769         preeminent = /* can we determine whether it exists? */
1770             (    !SvRMAGICAL(hv)
1771                 || mg_find((SV*)hv, PERL_MAGIC_env)
1772                 || (     (mg = mg_find((SV*)hv, PERL_MAGIC_tied))
1773                         /* Try to preserve the existenceness of a tied hash
1774                         * element by using EXISTS and DELETE if possible.
1775                         * Fallback to FETCH and STORE otherwise */
1776                     && (stash = SvSTASH(SvRV(SvTIED_obj((SV*)hv, mg))))
1777                     && gv_fetchmethod_autoload(stash, "EXISTS", TRUE)
1778                     && gv_fetchmethod_autoload(stash, "DELETE", TRUE)
1779                 )
1780             ) ? hv_exists_ent(hv, keysv, 0) : 1;
1781     }
1782     he = hv_fetch_ent(hv, keysv, lval && !defer, hash);
1783     svp = he ? &HeVAL(he) : NULL;
1784     if (lval) {
1785         if (!svp || *svp == &PL_sv_undef) {
1786             SV* lv;
1787             SV* key2;
1788             if (!defer) {
1789                 DIE(aTHX_ PL_no_helem_sv, SVfARG(keysv));
1790             }
1791             lv = sv_newmortal();
1792             sv_upgrade(lv, SVt_PVLV);
1793             LvTYPE(lv) = 'y';
1794             sv_magic(lv, key2 = newSVsv(keysv), PERL_MAGIC_defelem, NULL, 0);
1795             SvREFCNT_dec(key2); /* sv_magic() increments refcount */
1796             LvTARG(lv) = SvREFCNT_inc_simple(hv);
1797             LvTARGLEN(lv) = 1;
1798             PUSHs(lv);
1799             RETURN;
1800         }
1801         if (PL_op->op_private & OPpLVAL_INTRO) {
1802             if (HvNAME_get(hv) && isGV(*svp))
1803                 save_gp((GV*)*svp, !(PL_op->op_flags & OPf_SPECIAL));
1804             else {
1805                 if (!preeminent) {
1806                     STRLEN keylen;
1807                     const char * const key = SvPV_const(keysv, keylen);
1808                     SAVEDELETE(hv, savepvn(key,keylen),
1809                                SvUTF8(keysv) ? -(I32)keylen : (I32)keylen);
1810                 } else
1811                     save_helem(hv, keysv, svp);
1812             }
1813         }
1814         else if (PL_op->op_private & OPpDEREF)
1815             vivify_ref(*svp, PL_op->op_private & OPpDEREF);
1816     }
1817     sv = (svp ? *svp : &PL_sv_undef);
1818     /* This makes C<local $tied{foo} = $tied{foo}> possible.
1819      * Pushing the magical RHS on to the stack is useless, since
1820      * that magic is soon destined to be misled by the local(),
1821      * and thus the later pp_sassign() will fail to mg_get() the
1822      * old value.  This should also cure problems with delayed
1823      * mg_get()s.  GSAR 98-07-03 */
1824     if (!lval && SvGMAGICAL(sv))
1825         sv = sv_mortalcopy(sv);
1826     PUSHs(sv);
1827     RETURN;
1828 }
1829
1830 PP(pp_leave)
1831 {
1832     dVAR; dSP;
1833     register PERL_CONTEXT *cx;
1834     SV **newsp;
1835     PMOP *newpm;
1836     I32 gimme;
1837
1838     if (PL_op->op_flags & OPf_SPECIAL) {
1839         cx = &cxstack[cxstack_ix];
1840         cx->blk_oldpm = PL_curpm;       /* fake block should preserve $1 et al */
1841     }
1842
1843     POPBLOCK(cx,newpm);
1844
1845     gimme = OP_GIMME(PL_op, -1);
1846     if (gimme == -1) {
1847         if (cxstack_ix >= 0)
1848             gimme = cxstack[cxstack_ix].blk_gimme;
1849         else
1850             gimme = G_SCALAR;
1851     }
1852
1853     TAINT_NOT;
1854     if (gimme == G_VOID)
1855         SP = newsp;
1856     else if (gimme == G_SCALAR) {
1857         register SV **mark;
1858         MARK = newsp + 1;
1859         if (MARK <= SP) {
1860             if (SvFLAGS(TOPs) & (SVs_PADTMP|SVs_TEMP))
1861                 *MARK = TOPs;
1862             else
1863                 *MARK = sv_mortalcopy(TOPs);
1864         } else {
1865             MEXTEND(mark,0);
1866             *MARK = &PL_sv_undef;
1867         }
1868         SP = MARK;
1869     }
1870     else if (gimme == G_ARRAY) {
1871         /* in case LEAVE wipes old return values */
1872         register SV **mark;
1873         for (mark = newsp + 1; mark <= SP; mark++) {
1874             if (!(SvFLAGS(*mark) & (SVs_PADTMP|SVs_TEMP))) {
1875                 *mark = sv_mortalcopy(*mark);
1876                 TAINT_NOT;      /* Each item is independent */
1877             }
1878         }
1879     }
1880     PL_curpm = newpm;   /* Don't pop $1 et al till now */
1881
1882     LEAVE;
1883
1884     RETURN;
1885 }
1886
1887 PP(pp_iter)
1888 {
1889     dVAR; dSP;
1890     register PERL_CONTEXT *cx;
1891     SV *sv, *oldsv;
1892     SV **itersvp;
1893     AV *av = NULL; /* used for LOOP_FOR on arrays and the stack */
1894     bool av_is_stack = FALSE;
1895
1896     EXTEND(SP, 1);
1897     cx = &cxstack[cxstack_ix];
1898     if (!CxTYPE_is_LOOP(cx))
1899         DIE(aTHX_ "panic: pp_iter");
1900
1901     itersvp = CxITERVAR(cx);
1902     if (CxTYPE(cx) == CXt_LOOP_LAZYSV) {
1903             /* string increment */
1904             SV* cur = cx->blk_loop.state_u.lazysv.cur;
1905             SV *end = cx->blk_loop.state_u.lazysv.end;
1906             /* If the maximum is !SvOK(), pp_enteriter substitutes PL_sv_no.
1907                It has SvPVX of "" and SvCUR of 0, which is what we want.  */
1908             STRLEN maxlen = 0;
1909             const char *max = SvPV_const(end, maxlen);
1910             if (!SvNIOK(cur) && SvCUR(cur) <= maxlen) {
1911                 if (SvREFCNT(*itersvp) == 1 && !SvMAGICAL(*itersvp)) {
1912                     /* safe to reuse old SV */
1913                     sv_setsv(*itersvp, cur);
1914                 }
1915                 else
1916                 {
1917                     /* we need a fresh SV every time so that loop body sees a
1918                      * completely new SV for closures/references to work as
1919                      * they used to */
1920                     oldsv = *itersvp;
1921                     *itersvp = newSVsv(cur);
1922                     SvREFCNT_dec(oldsv);
1923                 }
1924                 if (strEQ(SvPVX_const(cur), max))
1925                     sv_setiv(cur, 0); /* terminate next time */
1926                 else
1927                     sv_inc(cur);
1928                 RETPUSHYES;
1929             }
1930             RETPUSHNO;
1931     }
1932     else if (CxTYPE(cx) == CXt_LOOP_LAZYIV) {
1933         /* integer increment */
1934         if (cx->blk_loop.state_u.lazyiv.cur > cx->blk_loop.state_u.lazyiv.end)
1935             RETPUSHNO;
1936
1937         /* don't risk potential race */
1938         if (SvREFCNT(*itersvp) == 1 && !SvMAGICAL(*itersvp)) {
1939             /* safe to reuse old SV */
1940             sv_setiv(*itersvp, cx->blk_loop.state_u.lazyiv.cur++);
1941         }
1942         else
1943         {
1944             /* we need a fresh SV every time so that loop body sees a
1945              * completely new SV for closures/references to work as they
1946              * used to */
1947             oldsv = *itersvp;
1948             *itersvp = newSViv(cx->blk_loop.state_u.lazyiv.cur++);
1949             SvREFCNT_dec(oldsv);
1950         }
1951
1952         /* Handle end of range at IV_MAX */
1953         if ((cx->blk_loop.state_u.lazyiv.cur == IV_MIN) &&
1954             (cx->blk_loop.state_u.lazyiv.end == IV_MAX))
1955         {
1956             cx->blk_loop.state_u.lazyiv.cur++;
1957             cx->blk_loop.state_u.lazyiv.end++;
1958         }
1959
1960         RETPUSHYES;
1961     }
1962
1963     /* iterate array */
1964     assert(CxTYPE(cx) == CXt_LOOP_FOR);
1965     av = cx->blk_loop.state_u.ary.ary;
1966     if (!av) {
1967         av_is_stack = TRUE;
1968         av = PL_curstack;
1969     }
1970     if (PL_op->op_private & OPpITER_REVERSED) {
1971         if (cx->blk_loop.state_u.ary.ix <= (av_is_stack
1972                                     ? cx->blk_loop.resetsp + 1 : 0))
1973             RETPUSHNO;
1974
1975         if (SvMAGICAL(av) || AvREIFY(av)) {
1976             SV * const * const svp = av_fetch(av, --cx->blk_loop.state_u.ary.ix, FALSE);
1977             sv = svp ? *svp : NULL;
1978         }
1979         else {
1980             sv = AvARRAY(av)[--cx->blk_loop.state_u.ary.ix];
1981         }
1982     }
1983     else {
1984         if (cx->blk_loop.state_u.ary.ix >= (av_is_stack ? cx->blk_oldsp :
1985                                     AvFILL(av)))
1986             RETPUSHNO;
1987
1988         if (SvMAGICAL(av) || AvREIFY(av)) {
1989             SV * const * const svp = av_fetch(av, ++cx->blk_loop.state_u.ary.ix, FALSE);
1990             sv = svp ? *svp : NULL;
1991         }
1992         else {
1993             sv = AvARRAY(av)[++cx->blk_loop.state_u.ary.ix];
1994         }
1995     }
1996
1997     if (sv && SvIS_FREED(sv)) {
1998         *itersvp = NULL;
1999         Perl_croak(aTHX_ "Use of freed value in iteration");
2000     }
2001
2002     if (sv) {
2003         SvTEMP_off(sv);
2004         SvREFCNT_inc_simple_void_NN(sv);
2005     }
2006     else
2007         sv = &PL_sv_undef;
2008     if (!av_is_stack && sv == &PL_sv_undef) {
2009         SV *lv = newSV_type(SVt_PVLV);
2010         LvTYPE(lv) = 'y';
2011         sv_magic(lv, NULL, PERL_MAGIC_defelem, NULL, 0);
2012         LvTARG(lv) = SvREFCNT_inc_simple(av);
2013         LvTARGOFF(lv) = cx->blk_loop.state_u.ary.ix;
2014         LvTARGLEN(lv) = (STRLEN)UV_MAX;
2015         sv = lv;
2016     }
2017
2018     oldsv = *itersvp;
2019     *itersvp = sv;
2020     SvREFCNT_dec(oldsv);
2021
2022     RETPUSHYES;
2023 }
2024
2025 PP(pp_subst)
2026 {
2027     dVAR; dSP; dTARG;
2028     register PMOP *pm = cPMOP;
2029     PMOP *rpm = pm;
2030     register char *s;
2031     char *strend;
2032     register char *m;
2033     const char *c;
2034     register char *d;
2035     STRLEN clen;
2036     I32 iters = 0;
2037     I32 maxiters;
2038     register I32 i;
2039     bool once;
2040     U8 rxtainted;
2041     char *orig;
2042     U8 r_flags;
2043     register REGEXP *rx = PM_GETRE(pm);
2044     STRLEN len;
2045     int force_on_match = 0;
2046     const I32 oldsave = PL_savestack_ix;
2047     STRLEN slen;
2048     bool doutf8 = FALSE;
2049     I32 matched;
2050 #ifdef PERL_OLD_COPY_ON_WRITE
2051     bool is_cow;
2052 #endif
2053     SV *nsv = NULL;
2054
2055     /* known replacement string? */
2056     register SV *dstr = (pm->op_pmflags & PMf_CONST) ? POPs : NULL;
2057     if (PL_op->op_flags & OPf_STACKED)
2058         TARG = POPs;
2059     else if (PL_op->op_private & OPpTARGET_MY)
2060         GETTARGET;
2061     else {
2062         TARG = DEFSV;
2063         EXTEND(SP,1);
2064     }
2065
2066 #ifdef PERL_OLD_COPY_ON_WRITE
2067     /* Awooga. Awooga. "bool" types that are actually char are dangerous,
2068        because they make integers such as 256 "false".  */
2069     is_cow = SvIsCOW(TARG) ? TRUE : FALSE;
2070 #else
2071     if (SvIsCOW(TARG))
2072         sv_force_normal_flags(TARG,0);
2073 #endif
2074     if (
2075 #ifdef PERL_OLD_COPY_ON_WRITE
2076         !is_cow &&
2077 #endif
2078         (SvREADONLY(TARG)
2079          || ( ((SvTYPE(TARG) == SVt_PVGV && isGV_with_GP(TARG))
2080                || SvTYPE(TARG) > SVt_PVLV)
2081              && !(SvTYPE(TARG) == SVt_PVGV && SvFAKE(TARG)))))
2082         DIE(aTHX_ PL_no_modify);
2083     PUTBACK;
2084
2085     s = SvPV_mutable(TARG, len);
2086     if (!SvPOKp(TARG) || SvTYPE(TARG) == SVt_PVGV)
2087         force_on_match = 1;
2088     rxtainted = ((RX_EXTFLAGS(rx) & RXf_TAINTED) ||
2089                  (PL_tainted && (pm->op_pmflags & PMf_RETAINT)));
2090     if (PL_tainted)
2091         rxtainted |= 2;
2092     TAINT_NOT;
2093
2094     RX_MATCH_UTF8_set(rx, DO_UTF8(TARG));
2095
2096   force_it:
2097     if (!pm || !s)
2098         DIE(aTHX_ "panic: pp_subst");
2099
2100     strend = s + len;
2101     slen = RX_MATCH_UTF8(rx) ? utf8_length((U8*)s, (U8*)strend) : len;
2102     maxiters = 2 * slen + 10;   /* We can match twice at each
2103                                    position, once with zero-length,
2104                                    second time with non-zero. */
2105
2106     if (!RX_PRELEN(rx) && PL_curpm) {
2107         pm = PL_curpm;
2108         rx = PM_GETRE(pm);
2109     }
2110     r_flags = (RX_NPARENS(rx) || SvTEMP(TARG) || PL_sawampersand
2111             || (RX_EXTFLAGS(rx) & (RXf_EVAL_SEEN|RXf_PMf_KEEPCOPY)) )
2112                ? REXEC_COPY_STR : 0;
2113     if (SvSCREAM(TARG))
2114         r_flags |= REXEC_SCREAM;
2115
2116     orig = m = s;
2117     if (RX_EXTFLAGS(rx) & RXf_USE_INTUIT) {
2118         PL_bostr = orig;
2119         s = CALLREG_INTUIT_START(rx, TARG, s, strend, r_flags, NULL);
2120
2121         if (!s)
2122             goto nope;
2123         /* How to do it in subst? */
2124 /*      if ( (RX_EXTFLAGS(rx) & RXf_CHECK_ALL)
2125              && !PL_sawampersand
2126              && !(RX_EXTFLAGS(rx) & RXf_KEEPCOPY)
2127              && ((RX_EXTFLAGS(rx) & RXf_NOSCAN)
2128                  || !((RX_EXTFLAGS(rx) & RXf_INTUIT_TAIL)
2129                       && (r_flags & REXEC_SCREAM))))
2130             goto yup;
2131 */
2132     }
2133
2134     /* only replace once? */
2135     once = !(rpm->op_pmflags & PMf_GLOBAL);
2136     matched = CALLREGEXEC(rx, s, strend, orig, 0, TARG, NULL,
2137                          r_flags | REXEC_CHECKED);
2138     /* known replacement string? */
2139     if (dstr) {
2140         /* replacement needing upgrading? */
2141         if (DO_UTF8(TARG) && !doutf8) {
2142              nsv = sv_newmortal();
2143              SvSetSV(nsv, dstr);
2144              if (PL_encoding)
2145                   sv_recode_to_utf8(nsv, PL_encoding);
2146              else
2147                   sv_utf8_upgrade(nsv);
2148              c = SvPV_const(nsv, clen);
2149              doutf8 = TRUE;
2150         }
2151         else {
2152             c = SvPV_const(dstr, clen);
2153             doutf8 = DO_UTF8(dstr);
2154         }
2155     }
2156     else {
2157         c = NULL;
2158         doutf8 = FALSE;
2159     }
2160
2161     /* can do inplace substitution? */
2162     if (c
2163 #ifdef PERL_OLD_COPY_ON_WRITE
2164         && !is_cow
2165 #endif
2166         && (I32)clen <= RX_MINLENRET(rx) && (once || !(r_flags & REXEC_COPY_STR))
2167         && !(RX_EXTFLAGS(rx) & RXf_LOOKBEHIND_SEEN)
2168         && (!doutf8 || SvUTF8(TARG))) {
2169         if (!matched)
2170         {
2171             SPAGAIN;
2172             PUSHs(&PL_sv_no);
2173             LEAVE_SCOPE(oldsave);
2174             RETURN;
2175         }
2176 #ifdef PERL_OLD_COPY_ON_WRITE
2177         if (SvIsCOW(TARG)) {
2178             assert (!force_on_match);
2179             goto have_a_cow;
2180         }
2181 #endif
2182         if (force_on_match) {
2183             force_on_match = 0;
2184             s = SvPV_force(TARG, len);
2185             goto force_it;
2186         }
2187         d = s;
2188         PL_curpm = pm;
2189         SvSCREAM_off(TARG);     /* disable possible screamer */
2190         if (once) {
2191             rxtainted |= RX_MATCH_TAINTED(rx);
2192             m = orig + RX_OFFS(rx)[0].start;
2193             d = orig + RX_OFFS(rx)[0].end;
2194             s = orig;
2195             if (m - s > strend - d) {  /* faster to shorten from end */
2196                 if (clen) {
2197                     Copy(c, m, clen, char);
2198                     m += clen;
2199                 }
2200                 i = strend - d;
2201                 if (i > 0) {
2202                     Move(d, m, i, char);
2203                     m += i;
2204                 }
2205                 *m = '\0';
2206                 SvCUR_set(TARG, m - s);
2207             }
2208             else if ((i = m - s)) {     /* faster from front */
2209                 d -= clen;
2210                 m = d;
2211                 Move(s, d - i, i, char);
2212                 sv_chop(TARG, d-i);
2213                 if (clen)
2214                     Copy(c, m, clen, char);
2215             }
2216             else if (clen) {
2217                 d -= clen;
2218                 sv_chop(TARG, d);
2219                 Copy(c, d, clen, char);
2220             }
2221             else {
2222                 sv_chop(TARG, d);
2223             }
2224             TAINT_IF(rxtainted & 1);
2225             SPAGAIN;
2226             PUSHs(&PL_sv_yes);
2227         }
2228         else {
2229             do {
2230                 if (iters++ > maxiters)
2231                     DIE(aTHX_ "Substitution loop");
2232                 rxtainted |= RX_MATCH_TAINTED(rx);
2233                 m = RX_OFFS(rx)[0].start + orig;
2234                 if ((i = m - s)) {
2235                     if (s != d)
2236                         Move(s, d, i, char);
2237                     d += i;
2238                 }
2239                 if (clen) {
2240                     Copy(c, d, clen, char);
2241                     d += clen;
2242                 }
2243                 s = RX_OFFS(rx)[0].end + orig;
2244             } while (CALLREGEXEC(rx, s, strend, orig, s == m,
2245                                  TARG, NULL,
2246                                  /* don't match same null twice */
2247                                  REXEC_NOT_FIRST|REXEC_IGNOREPOS));
2248             if (s != d) {
2249                 i = strend - s;
2250                 SvCUR_set(TARG, d - SvPVX_const(TARG) + i);
2251                 Move(s, d, i+1, char);          /* include the NUL */
2252             }
2253             TAINT_IF(rxtainted & 1);
2254             SPAGAIN;
2255             mPUSHi((I32)iters);
2256         }
2257         (void)SvPOK_only_UTF8(TARG);
2258         TAINT_IF(rxtainted);
2259         if (SvSMAGICAL(TARG)) {
2260             PUTBACK;
2261             mg_set(TARG);
2262             SPAGAIN;
2263         }
2264         SvTAINT(TARG);
2265         if (doutf8)
2266             SvUTF8_on(TARG);
2267         LEAVE_SCOPE(oldsave);
2268         RETURN;
2269     }
2270
2271     if (matched)
2272     {
2273         if (force_on_match) {
2274             force_on_match = 0;
2275             s = SvPV_force(TARG, len);
2276             goto force_it;
2277         }
2278 #ifdef PERL_OLD_COPY_ON_WRITE
2279       have_a_cow:
2280 #endif
2281         rxtainted |= RX_MATCH_TAINTED(rx);
2282         dstr = newSVpvn_utf8(m, s-m, DO_UTF8(TARG));
2283         SAVEFREESV(dstr);
2284         PL_curpm = pm;
2285         if (!c) {
2286             register PERL_CONTEXT *cx;
2287             SPAGAIN;
2288             PUSHSUBST(cx);
2289             RETURNOP(cPMOP->op_pmreplrootu.op_pmreplroot);
2290         }
2291         r_flags |= REXEC_IGNOREPOS | REXEC_NOT_FIRST;
2292         do {
2293             if (iters++ > maxiters)
2294                 DIE(aTHX_ "Substitution loop");
2295             rxtainted |= RX_MATCH_TAINTED(rx);
2296             if (RX_MATCH_COPIED(rx) && RX_SUBBEG(rx) != orig) {
2297                 m = s;
2298                 s = orig;
2299                 orig = RX_SUBBEG(rx);
2300                 s = orig + (m - s);
2301                 strend = s + (strend - m);
2302             }
2303             m = RX_OFFS(rx)[0].start + orig;
2304             if (doutf8 && !SvUTF8(dstr))
2305                 sv_catpvn_utf8_upgrade(dstr, s, m - s, nsv);
2306             else
2307                 sv_catpvn(dstr, s, m-s);
2308             s = RX_OFFS(rx)[0].end + orig;
2309             if (clen)
2310                 sv_catpvn(dstr, c, clen);
2311             if (once)
2312                 break;
2313         } while (CALLREGEXEC(rx, s, strend, orig, s == m,
2314                              TARG, NULL, r_flags));
2315         if (doutf8 && !DO_UTF8(TARG))
2316             sv_catpvn_utf8_upgrade(dstr, s, strend - s, nsv);
2317         else
2318             sv_catpvn(dstr, s, strend - s);
2319
2320 #ifdef PERL_OLD_COPY_ON_WRITE
2321         /* The match may make the string COW. If so, brilliant, because that's
2322            just saved us one malloc, copy and free - the regexp has donated
2323            the old buffer, and we malloc an entirely new one, rather than the
2324            regexp malloc()ing a buffer and copying our original, only for
2325            us to throw it away here during the substitution.  */
2326         if (SvIsCOW(TARG)) {
2327             sv_force_normal_flags(TARG, SV_COW_DROP_PV);
2328         } else
2329 #endif
2330         {
2331             SvPV_free(TARG);
2332         }
2333         SvPV_set(TARG, SvPVX(dstr));
2334         SvCUR_set(TARG, SvCUR(dstr));
2335         SvLEN_set(TARG, SvLEN(dstr));
2336         doutf8 |= DO_UTF8(dstr);
2337         SvPV_set(dstr, NULL);
2338
2339         TAINT_IF(rxtainted & 1);
2340         SPAGAIN;
2341         mPUSHi((I32)iters);
2342
2343         (void)SvPOK_only(TARG);
2344         if (doutf8)
2345             SvUTF8_on(TARG);
2346         TAINT_IF(rxtainted);
2347         SvSETMAGIC(TARG);
2348         SvTAINT(TARG);
2349         LEAVE_SCOPE(oldsave);
2350         RETURN;
2351     }
2352     goto ret_no;
2353
2354 nope:
2355 ret_no:
2356     SPAGAIN;
2357     PUSHs(&PL_sv_no);
2358     LEAVE_SCOPE(oldsave);
2359     RETURN;
2360 }
2361
2362 PP(pp_grepwhile)
2363 {
2364     dVAR; dSP;
2365
2366     if (SvTRUEx(POPs))
2367         PL_stack_base[PL_markstack_ptr[-1]++] = PL_stack_base[*PL_markstack_ptr];
2368     ++*PL_markstack_ptr;
2369     LEAVE;                                      /* exit inner scope */
2370
2371     /* All done yet? */
2372     if (PL_stack_base + *PL_markstack_ptr > SP) {
2373         I32 items;
2374         const I32 gimme = GIMME_V;
2375
2376         LEAVE;                                  /* exit outer scope */
2377         (void)POPMARK;                          /* pop src */
2378         items = --*PL_markstack_ptr - PL_markstack_ptr[-1];
2379         (void)POPMARK;                          /* pop dst */
2380         SP = PL_stack_base + POPMARK;           /* pop original mark */
2381         if (gimme == G_SCALAR) {
2382             if (PL_op->op_private & OPpGREP_LEX) {
2383                 SV* const sv = sv_newmortal();
2384                 sv_setiv(sv, items);
2385                 PUSHs(sv);
2386             }
2387             else {
2388                 dTARGET;
2389                 XPUSHi(items);
2390             }
2391         }
2392         else if (gimme == G_ARRAY)
2393             SP += items;
2394         RETURN;
2395     }
2396     else {
2397         SV *src;
2398
2399         ENTER;                                  /* enter inner scope */
2400         SAVEVPTR(PL_curpm);
2401
2402         src = PL_stack_base[*PL_markstack_ptr];
2403         SvTEMP_off(src);
2404         if (PL_op->op_private & OPpGREP_LEX)
2405             PAD_SVl(PL_op->op_targ) = src;
2406         else
2407             DEFSV = src;
2408
2409         RETURNOP(cLOGOP->op_other);
2410     }
2411 }
2412
2413 PP(pp_leavesub)
2414 {
2415     dVAR; dSP;
2416     SV **mark;
2417     SV **newsp;
2418     PMOP *newpm;
2419     I32 gimme;
2420     register PERL_CONTEXT *cx;
2421     SV *sv;
2422
2423     if (CxMULTICALL(&cxstack[cxstack_ix]))
2424         return 0;
2425
2426     POPBLOCK(cx,newpm);
2427     cxstack_ix++; /* temporarily protect top context */
2428
2429     TAINT_NOT;
2430     if (gimme == G_SCALAR) {
2431         MARK = newsp + 1;
2432         if (MARK <= SP) {
2433             if (cx->blk_sub.cv && CvDEPTH(cx->blk_sub.cv) > 1) {
2434                 if (SvTEMP(TOPs)) {
2435                     *MARK = SvREFCNT_inc(TOPs);
2436                     FREETMPS;
2437                     sv_2mortal(*MARK);
2438                 }
2439                 else {
2440                     sv = SvREFCNT_inc(TOPs);    /* FREETMPS could clobber it */
2441                     FREETMPS;
2442                     *MARK = sv_mortalcopy(sv);
2443                     SvREFCNT_dec(sv);
2444                 }
2445             }
2446             else
2447                 *MARK = SvTEMP(TOPs) ? TOPs : sv_mortalcopy(TOPs);
2448         }
2449         else {
2450             MEXTEND(MARK, 0);
2451             *MARK = &PL_sv_undef;
2452         }
2453         SP = MARK;
2454     }
2455     else if (gimme == G_ARRAY) {
2456         for (MARK = newsp + 1; MARK <= SP; MARK++) {
2457             if (!SvTEMP(*MARK)) {
2458                 *MARK = sv_mortalcopy(*MARK);
2459                 TAINT_NOT;      /* Each item is independent */
2460             }
2461         }
2462     }
2463     PUTBACK;
2464
2465     LEAVE;
2466     cxstack_ix--;
2467     POPSUB(cx,sv);      /* Stack values are safe: release CV and @_ ... */
2468     PL_curpm = newpm;   /* ... and pop $1 et al */
2469
2470     LEAVESUB(sv);
2471     return cx->blk_sub.retop;
2472 }
2473
2474 /* This duplicates the above code because the above code must not
2475  * get any slower by more conditions */
2476 PP(pp_leavesublv)
2477 {
2478     dVAR; dSP;
2479     SV **mark;
2480     SV **newsp;
2481     PMOP *newpm;
2482     I32 gimme;
2483     register PERL_CONTEXT *cx;
2484     SV *sv;
2485
2486     if (CxMULTICALL(&cxstack[cxstack_ix]))
2487         return 0;
2488
2489     POPBLOCK(cx,newpm);
2490     cxstack_ix++; /* temporarily protect top context */
2491
2492     TAINT_NOT;
2493
2494     if (CxLVAL(cx) & OPpENTERSUB_INARGS) {
2495         /* We are an argument to a function or grep().
2496          * This kind of lvalueness was legal before lvalue
2497          * subroutines too, so be backward compatible:
2498          * cannot report errors.  */
2499
2500         /* Scalar context *is* possible, on the LHS of -> only,
2501          * as in f()->meth().  But this is not an lvalue. */
2502         if (gimme == G_SCALAR)
2503             goto temporise;
2504         if (gimme == G_ARRAY) {
2505             if (!CvLVALUE(cx->blk_sub.cv))
2506                 goto temporise_array;
2507             EXTEND_MORTAL(SP - newsp);
2508             for (mark = newsp + 1; mark <= SP; mark++) {
2509                 if (SvTEMP(*mark))
2510                     NOOP;
2511                 else if (SvFLAGS(*mark) & (SVs_PADTMP | SVf_READONLY))
2512                     *mark = sv_mortalcopy(*mark);
2513                 else {
2514                     /* Can be a localized value subject to deletion. */
2515                     PL_tmps_stack[++PL_tmps_ix] = *mark;
2516                     SvREFCNT_inc_void(*mark);
2517                 }
2518             }
2519         }
2520     }
2521     else if (CxLVAL(cx)) {     /* Leave it as it is if we can. */
2522         /* Here we go for robustness, not for speed, so we change all
2523          * the refcounts so the caller gets a live guy. Cannot set
2524          * TEMP, so sv_2mortal is out of question. */
2525         if (!CvLVALUE(cx->blk_sub.cv)) {
2526             LEAVE;
2527             cxstack_ix--;
2528             POPSUB(cx,sv);
2529             PL_curpm = newpm;
2530             LEAVESUB(sv);
2531             DIE(aTHX_ "Can't modify non-lvalue subroutine call");
2532         }
2533         if (gimme == G_SCALAR) {
2534             MARK = newsp + 1;
2535             EXTEND_MORTAL(1);
2536             if (MARK == SP) {
2537                 /* Temporaries are bad unless they happen to be elements
2538                  * of a tied hash or array */
2539                 if (SvFLAGS(TOPs) & (SVs_TEMP | SVs_PADTMP | SVf_READONLY) &&
2540                     !(SvRMAGICAL(TOPs) && mg_find(TOPs, PERL_MAGIC_tiedelem))) {
2541                     LEAVE;
2542                     cxstack_ix--;
2543                     POPSUB(cx,sv);
2544                     PL_curpm = newpm;
2545                     LEAVESUB(sv);
2546                     DIE(aTHX_ "Can't return %s from lvalue subroutine",
2547                         SvREADONLY(TOPs) ? (TOPs == &PL_sv_undef) ? "undef"
2548                         : "a readonly value" : "a temporary");
2549                 }
2550                 else {                  /* Can be a localized value
2551                                          * subject to deletion. */
2552                     PL_tmps_stack[++PL_tmps_ix] = *mark;
2553                     SvREFCNT_inc_void(*mark);
2554                 }
2555             }
2556             else {                      /* Should not happen? */
2557                 LEAVE;
2558                 cxstack_ix--;
2559                 POPSUB(cx,sv);
2560                 PL_curpm = newpm;
2561                 LEAVESUB(sv);
2562                 DIE(aTHX_ "%s returned from lvalue subroutine in scalar context",
2563                     (MARK > SP ? "Empty array" : "Array"));
2564             }
2565             SP = MARK;
2566         }
2567         else if (gimme == G_ARRAY) {
2568             EXTEND_MORTAL(SP - newsp);
2569             for (mark = newsp + 1; mark <= SP; mark++) {
2570                 if (*mark != &PL_sv_undef
2571                     && SvFLAGS(*mark) & (SVs_TEMP | SVs_PADTMP | SVf_READONLY)) {
2572                     /* Might be flattened array after $#array =  */
2573                     PUTBACK;
2574                     LEAVE;
2575                     cxstack_ix--;
2576                     POPSUB(cx,sv);
2577                     PL_curpm = newpm;
2578                     LEAVESUB(sv);
2579                     DIE(aTHX_ "Can't return a %s from lvalue subroutine",
2580                         SvREADONLY(TOPs) ? "readonly value" : "temporary");
2581                 }
2582                 else {
2583                     /* Can be a localized value subject to deletion. */
2584                     PL_tmps_stack[++PL_tmps_ix] = *mark;
2585                     SvREFCNT_inc_void(*mark);
2586                 }
2587             }
2588         }
2589     }
2590     else {
2591         if (gimme == G_SCALAR) {
2592           temporise:
2593             MARK = newsp + 1;
2594             if (MARK <= SP) {
2595                 if (cx->blk_sub.cv && CvDEPTH(cx->blk_sub.cv) > 1) {
2596                     if (SvTEMP(TOPs)) {
2597                         *MARK = SvREFCNT_inc(TOPs);
2598                         FREETMPS;
2599                         sv_2mortal(*MARK);
2600                     }
2601                     else {
2602                         sv = SvREFCNT_inc(TOPs); /* FREETMPS could clobber it */
2603                         FREETMPS;
2604                         *MARK = sv_mortalcopy(sv);
2605                         SvREFCNT_dec(sv);
2606                     }
2607                 }
2608                 else
2609                     *MARK = SvTEMP(TOPs) ? TOPs : sv_mortalcopy(TOPs);
2610             }
2611             else {
2612                 MEXTEND(MARK, 0);
2613                 *MARK = &PL_sv_undef;
2614             }
2615             SP = MARK;
2616         }
2617         else if (gimme == G_ARRAY) {
2618           temporise_array:
2619             for (MARK = newsp + 1; MARK <= SP; MARK++) {
2620                 if (!SvTEMP(*MARK)) {
2621                     *MARK = sv_mortalcopy(*MARK);
2622                     TAINT_NOT;  /* Each item is independent */
2623                 }
2624             }
2625         }
2626     }
2627     PUTBACK;
2628
2629     LEAVE;
2630     cxstack_ix--;
2631     POPSUB(cx,sv);      /* Stack values are safe: release CV and @_ ... */
2632     PL_curpm = newpm;   /* ... and pop $1 et al */
2633
2634     LEAVESUB(sv);
2635     return cx->blk_sub.retop;
2636 }
2637
2638 PP(pp_entersub)
2639 {
2640     dVAR; dSP; dPOPss;
2641     GV *gv;
2642     register CV *cv;
2643     register PERL_CONTEXT *cx;
2644     I32 gimme;
2645     const bool hasargs = (PL_op->op_flags & OPf_STACKED) != 0;
2646
2647     if (!sv)
2648         DIE(aTHX_ "Not a CODE reference");
2649     switch (SvTYPE(sv)) {
2650         /* This is overwhelming the most common case:  */
2651     case SVt_PVGV:
2652         if (!(cv = GvCVu((GV*)sv))) {
2653             HV *stash;
2654             cv = sv_2cv(sv, &stash, &gv, 0);
2655         }
2656         if (!cv) {
2657             ENTER;
2658             SAVETMPS;
2659             goto try_autoload;
2660         }
2661         break;
2662     default:
2663         if (!SvROK(sv)) {
2664             const char *sym;
2665             STRLEN len;
2666             if (sv == &PL_sv_yes) {             /* unfound import, ignore */
2667                 if (hasargs)
2668                     SP = PL_stack_base + POPMARK;
2669                 RETURN;
2670             }
2671             if (SvGMAGICAL(sv)) {
2672                 mg_get(sv);
2673                 if (SvROK(sv))
2674                     goto got_rv;
2675                 if (SvPOKp(sv)) {
2676                     sym = SvPVX_const(sv);
2677                     len = SvCUR(sv);
2678                 } else {
2679                     sym = NULL;
2680                     len = 0;
2681                 }
2682             }
2683             else {
2684                 sym = SvPV_const(sv, len);
2685             }
2686             if (!sym)
2687                 DIE(aTHX_ PL_no_usym, "a subroutine");
2688             if (PL_op->op_private & HINT_STRICT_REFS)
2689                 DIE(aTHX_ PL_no_symref, sym, "a subroutine");
2690             cv = get_cvn_flags(sym, len, GV_ADD|SvUTF8(sv));
2691             break;
2692         }
2693   got_rv:
2694         {
2695             SV * const * sp = &sv;              /* Used in tryAMAGICunDEREF macro. */
2696             tryAMAGICunDEREF(to_cv);
2697         }
2698         cv = (CV*)SvRV(sv);
2699         if (SvTYPE(cv) == SVt_PVCV)
2700             break;
2701         /* FALL THROUGH */
2702     case SVt_PVHV:
2703     case SVt_PVAV:
2704         DIE(aTHX_ "Not a CODE reference");
2705         /* This is the second most common case:  */
2706     case SVt_PVCV:
2707         cv = (CV*)sv;
2708         break;
2709     }
2710
2711     ENTER;
2712     SAVETMPS;
2713
2714   retry:
2715     if (!CvROOT(cv) && !CvXSUB(cv)) {
2716         GV* autogv;
2717         SV* sub_name;
2718
2719         /* anonymous or undef'd function leaves us no recourse */
2720         if (CvANON(cv) || !(gv = CvGV(cv)))
2721             DIE(aTHX_ "Undefined subroutine called");
2722
2723         /* autoloaded stub? */
2724         if (cv != GvCV(gv)) {
2725             cv = GvCV(gv);
2726         }
2727         /* should call AUTOLOAD now? */
2728         else {
2729 try_autoload:
2730             if ((autogv = gv_autoload4(GvSTASH(gv), GvNAME(gv), GvNAMELEN(gv),
2731                                    FALSE)))
2732             {
2733                 cv = GvCV(autogv);
2734             }
2735             /* sorry */
2736             else {
2737                 sub_name = sv_newmortal();
2738                 gv_efullname3(sub_name, gv, NULL);
2739                 DIE(aTHX_ "Undefined subroutine &%"SVf" called", SVfARG(sub_name));
2740             }
2741         }
2742         if (!cv)
2743             DIE(aTHX_ "Not a CODE reference");
2744         goto retry;
2745     }
2746
2747     gimme = GIMME_V;
2748     if ((PL_op->op_private & OPpENTERSUB_DB) && GvCV(PL_DBsub) && !CvNODEBUG(cv)) {
2749          Perl_get_db_sub(aTHX_ &sv, cv);
2750          if (CvISXSUB(cv))
2751              PL_curcopdb = PL_curcop;
2752          cv = GvCV(PL_DBsub);
2753
2754         if (!cv || (!CvXSUB(cv) && !CvSTART(cv)))
2755             DIE(aTHX_ "No DB::sub routine defined");
2756     }
2757
2758     if (!(CvISXSUB(cv))) {
2759         /* This path taken at least 75% of the time   */
2760         dMARK;
2761         register I32 items = SP - MARK;
2762         AV* const padlist = CvPADLIST(cv);
2763         PUSHBLOCK(cx, CXt_SUB, MARK);
2764         PUSHSUB(cx);
2765         cx->blk_sub.retop = PL_op->op_next;
2766         CvDEPTH(cv)++;
2767         /* XXX This would be a natural place to set C<PL_compcv = cv> so
2768          * that eval'' ops within this sub know the correct lexical space.
2769          * Owing the speed considerations, we choose instead to search for
2770          * the cv using find_runcv() when calling doeval().
2771          */
2772         if (CvDEPTH(cv) >= 2) {
2773             PERL_STACK_OVERFLOW_CHECK();
2774             pad_push(padlist, CvDEPTH(cv));
2775         }
2776         SAVECOMPPAD();
2777         PAD_SET_CUR_NOSAVE(padlist, CvDEPTH(cv));
2778         if (hasargs) {
2779             AV* const av = (AV*)PAD_SVl(0);
2780             if (AvREAL(av)) {
2781                 /* @_ is normally not REAL--this should only ever
2782                  * happen when DB::sub() calls things that modify @_ */
2783                 av_clear(av);
2784                 AvREAL_off(av);
2785                 AvREIFY_on(av);
2786             }
2787             cx->blk_sub.savearray = GvAV(PL_defgv);
2788             GvAV(PL_defgv) = (AV*)SvREFCNT_inc_simple(av);
2789             CX_CURPAD_SAVE(cx->blk_sub);
2790             cx->blk_sub.argarray = av;
2791             ++MARK;
2792
2793             if (items > AvMAX(av) + 1) {
2794                 SV **ary = AvALLOC(av);
2795                 if (AvARRAY(av) != ary) {
2796                     AvMAX(av) += AvARRAY(av) - AvALLOC(av);
2797                     AvARRAY(av) = ary;
2798                 }
2799                 if (items > AvMAX(av) + 1) {
2800                     AvMAX(av) = items - 1;
2801                     Renew(ary,items,SV*);
2802                     AvALLOC(av) = ary;
2803                     AvARRAY(av) = ary;
2804                 }
2805             }
2806             Copy(MARK,AvARRAY(av),items,SV*);
2807             AvFILLp(av) = items - 1;
2808
2809             while (items--) {
2810                 if (*MARK)
2811                     SvTEMP_off(*MARK);
2812                 MARK++;
2813             }
2814         }
2815         /* warning must come *after* we fully set up the context
2816          * stuff so that __WARN__ handlers can safely dounwind()
2817          * if they want to
2818          */
2819         if (CvDEPTH(cv) == PERL_SUB_DEPTH_WARN && ckWARN(WARN_RECURSION)
2820             && !(PERLDB_SUB && cv == GvCV(PL_DBsub)))
2821             sub_crush_depth(cv);
2822         RETURNOP(CvSTART(cv));
2823     }
2824     else {
2825         I32 markix = TOPMARK;
2826
2827         PUTBACK;
2828
2829         if (!hasargs) {
2830             /* Need to copy @_ to stack. Alternative may be to
2831              * switch stack to @_, and copy return values
2832              * back. This would allow popping @_ in XSUB, e.g.. XXXX */
2833             AV * const av = GvAV(PL_defgv);
2834             const I32 items = AvFILLp(av) + 1;   /* @_ is not tieable */
2835
2836             if (items) {
2837                 /* Mark is at the end of the stack. */
2838                 EXTEND(SP, items);
2839                 Copy(AvARRAY(av), SP + 1, items, SV*);
2840                 SP += items;
2841                 PUTBACK ;
2842             }
2843         }
2844         /* We assume first XSUB in &DB::sub is the called one. */
2845         if (PL_curcopdb) {
2846             SAVEVPTR(PL_curcop);
2847             PL_curcop = PL_curcopdb;
2848             PL_curcopdb = NULL;
2849         }
2850         /* Do we need to open block here? XXXX */
2851         if (CvXSUB(cv)) /* XXX this is supposed to be true */
2852             (void)(*CvXSUB(cv))(aTHX_ cv);
2853
2854         /* Enforce some sanity in scalar context. */
2855         if (gimme == G_SCALAR && ++markix != PL_stack_sp - PL_stack_base ) {
2856             if (markix > PL_stack_sp - PL_stack_base)
2857                 *(PL_stack_base + markix) = &PL_sv_undef;
2858             else
2859                 *(PL_stack_base + markix) = *PL_stack_sp;
2860             PL_stack_sp = PL_stack_base + markix;
2861         }
2862         LEAVE;
2863         return NORMAL;
2864     }
2865 }
2866
2867 void
2868 Perl_sub_crush_depth(pTHX_ CV *cv)
2869 {
2870     PERL_ARGS_ASSERT_SUB_CRUSH_DEPTH;
2871
2872     if (CvANON(cv))
2873         Perl_warner(aTHX_ packWARN(WARN_RECURSION), "Deep recursion on anonymous subroutine");
2874     else {
2875         SV* const tmpstr = sv_newmortal();
2876         gv_efullname3(tmpstr, CvGV(cv), NULL);
2877         Perl_warner(aTHX_ packWARN(WARN_RECURSION), "Deep recursion on subroutine \"%"SVf"\"",
2878                     SVfARG(tmpstr));
2879     }
2880 }
2881
2882 PP(pp_aelem)
2883 {
2884     dVAR; dSP;
2885     SV** svp;
2886     SV* const elemsv = POPs;
2887     IV elem = SvIV(elemsv);
2888     AV* const av = (AV*)POPs;
2889     const U32 lval = PL_op->op_flags & OPf_MOD || LVRET;
2890     const U32 defer = (PL_op->op_private & OPpLVAL_DEFER) && (elem > av_len(av));
2891     SV *sv;
2892
2893     if (SvROK(elemsv) && !SvGAMAGIC(elemsv) && ckWARN(WARN_MISC))
2894         Perl_warner(aTHX_ packWARN(WARN_MISC),
2895                     "Use of reference \"%"SVf"\" as array index",
2896                     SVfARG(elemsv));
2897     if (elem > 0)
2898         elem -= CopARYBASE_get(PL_curcop);
2899     if (SvTYPE(av) != SVt_PVAV)
2900         RETPUSHUNDEF;
2901     svp = av_fetch(av, elem, lval && !defer);
2902     if (lval) {
2903 #ifdef PERL_MALLOC_WRAP
2904          if (SvUOK(elemsv)) {
2905               const UV uv = SvUV(elemsv);
2906               elem = uv > IV_MAX ? IV_MAX : uv;
2907          }
2908          else if (SvNOK(elemsv))
2909               elem = (IV)SvNV(elemsv);
2910          if (elem > 0) {
2911               static const char oom_array_extend[] =
2912                 "Out of memory during array extend"; /* Duplicated in av.c */
2913               MEM_WRAP_CHECK_1(elem,SV*,oom_array_extend);
2914          }
2915 #endif
2916         if (!svp || *svp == &PL_sv_undef) {
2917             SV* lv;
2918             if (!defer)
2919                 DIE(aTHX_ PL_no_aelem, elem);
2920             lv = sv_newmortal();
2921             sv_upgrade(lv, SVt_PVLV);
2922             LvTYPE(lv) = 'y';
2923             sv_magic(lv, NULL, PERL_MAGIC_defelem, NULL, 0);
2924             LvTARG(lv) = SvREFCNT_inc_simple(av);
2925             LvTARGOFF(lv) = elem;
2926             LvTARGLEN(lv) = 1;
2927             PUSHs(lv);
2928             RETURN;
2929         }
2930         if (PL_op->op_private & OPpLVAL_INTRO)
2931             save_aelem(av, elem, svp);
2932         else if (PL_op->op_private & OPpDEREF)
2933             vivify_ref(*svp, PL_op->op_private & OPpDEREF);
2934     }
2935     sv = (svp ? *svp : &PL_sv_undef);
2936     if (!lval && SvGMAGICAL(sv))        /* see note in pp_helem() */
2937         sv = sv_mortalcopy(sv);
2938     PUSHs(sv);
2939     RETURN;
2940 }
2941
2942 void
2943 Perl_vivify_ref(pTHX_ SV *sv, U32 to_what)
2944 {
2945     PERL_ARGS_ASSERT_VIVIFY_REF;
2946
2947     SvGETMAGIC(sv);
2948     if (!SvOK(sv)) {
2949         if (SvREADONLY(sv))
2950             Perl_croak(aTHX_ PL_no_modify);
2951         prepare_SV_for_RV(sv);
2952         switch (to_what) {
2953         case OPpDEREF_SV:
2954             SvRV_set(sv, newSV(0));
2955             break;
2956         case OPpDEREF_AV:
2957             SvRV_set(sv, (SV*)newAV());
2958             break;
2959         case OPpDEREF_HV:
2960             SvRV_set(sv, (SV*)newHV());
2961             break;
2962         }
2963         SvROK_on(sv);
2964         SvSETMAGIC(sv);
2965     }
2966 }
2967
2968 PP(pp_method)
2969 {
2970     dVAR; dSP;
2971     SV* const sv = TOPs;
2972
2973     if (SvROK(sv)) {
2974         SV* const rsv = SvRV(sv);
2975         if (SvTYPE(rsv) == SVt_PVCV) {
2976             SETs(rsv);
2977             RETURN;
2978         }
2979     }
2980
2981     SETs(method_common(sv, NULL));
2982     RETURN;
2983 }
2984
2985 PP(pp_method_named)
2986 {
2987     dVAR; dSP;
2988     SV* const sv = cSVOP_sv;
2989     U32 hash = SvSHARED_HASH(sv);
2990
2991     XPUSHs(method_common(sv, &hash));
2992     RETURN;
2993 }
2994
2995 STATIC SV *
2996 S_method_common(pTHX_ SV* meth, U32* hashp)
2997 {
2998     dVAR;
2999     SV* ob;
3000     GV* gv;
3001     HV* stash;
3002     STRLEN namelen;
3003     const char* packname = NULL;
3004     SV *packsv = NULL;
3005     STRLEN packlen;
3006     const char * const name = SvPV_const(meth, namelen);
3007     SV * const sv = *(PL_stack_base + TOPMARK + 1);
3008
3009     PERL_ARGS_ASSERT_METHOD_COMMON;
3010
3011     if (!sv)
3012         Perl_croak(aTHX_ "Can't call method \"%s\" on an undefined value", name);
3013
3014     SvGETMAGIC(sv);
3015     if (SvROK(sv))
3016         ob = (SV*)SvRV(sv);
3017     else {
3018         GV* iogv;
3019
3020         /* this isn't a reference */
3021         if(SvOK(sv) && (packname = SvPV_const(sv, packlen))) {
3022           const HE* const he = hv_fetch_ent(PL_stashcache, sv, 0, 0);
3023           if (he) {
3024             stash = INT2PTR(HV*,SvIV(HeVAL(he)));
3025             goto fetch;
3026           }
3027         }
3028
3029         if (!SvOK(sv) ||
3030             !(packname) ||
3031             !(iogv = gv_fetchsv(sv, 0, SVt_PVIO)) ||
3032             !(ob=(SV*)GvIO(iogv)))
3033         {
3034             /* this isn't the name of a filehandle either */
3035             if (!packname ||
3036                 ((UTF8_IS_START(*packname) && DO_UTF8(sv))
3037                     ? !isIDFIRST_utf8((U8*)packname)
3038                     : !isIDFIRST(*packname)
3039                 ))
3040             {
3041                 Perl_croak(aTHX_ "Can't call method \"%s\" %s", name,
3042                            SvOK(sv) ? "without a package or object reference"
3043                                     : "on an undefined value");
3044             }
3045             /* assume it's a package name */
3046             stash = gv_stashpvn(packname, packlen, 0);
3047             if (!stash)
3048                 packsv = sv;
3049             else {
3050                 SV* const ref = newSViv(PTR2IV(stash));
3051                 (void)hv_store(PL_stashcache, packname, packlen, ref, 0);
3052             }
3053             goto fetch;
3054         }
3055         /* it _is_ a filehandle name -- replace with a reference */
3056         *(PL_stack_base + TOPMARK + 1) = sv_2mortal(newRV((SV*)iogv));
3057     }
3058
3059     /* if we got here, ob should be a reference or a glob */
3060     if (!ob || !(SvOBJECT(ob)
3061                  || (SvTYPE(ob) == SVt_PVGV && (ob = (SV*)GvIO((GV*)ob))
3062                      && SvOBJECT(ob))))
3063     {
3064         Perl_croak(aTHX_ "Can't call method \"%s\" on unblessed reference",
3065                    (SvSCREAM(meth) && strEQ(name,"isa")) ? "DOES" :
3066                    name);
3067     }
3068
3069     stash = SvSTASH(ob);
3070
3071   fetch:
3072     /* NOTE: stash may be null, hope hv_fetch_ent and
3073        gv_fetchmethod can cope (it seems they can) */
3074
3075     /* shortcut for simple names */
3076     if (hashp) {
3077         const HE* const he = hv_fetch_ent(stash, meth, 0, *hashp);
3078         if (he) {
3079             gv = (GV*)HeVAL(he);
3080             if (isGV(gv) && GvCV(gv) &&
3081                 (!GvCVGEN(gv) || GvCVGEN(gv)
3082                   == (PL_sub_generation + HvMROMETA(stash)->cache_gen)))
3083                 return (SV*)GvCV(gv);
3084         }
3085     }
3086
3087     gv = gv_fetchmethod_flags(stash ? stash : (HV*)packsv, name,
3088                               GV_AUTOLOAD | GV_CROAK);
3089
3090     assert(gv);
3091
3092     return isGV(gv) ? (SV*)GvCV(gv) : (SV*)gv;
3093 }
3094
3095 /*
3096  * Local variables:
3097  * c-indentation-style: bsd
3098  * c-basic-offset: 4
3099  * indent-tabs-mode: t
3100  * End:
3101  *
3102  * ex: set ts=8 sts=4 sw=4 noet:
3103  */