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