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             break;
1009         case SVt_PVHV: {                                /* normal hash */
1010                 SV *tmpstr;
1011
1012                 hash = (HV*)sv;
1013                 magic = SvMAGICAL(hash) != 0;
1014                 hv_clear(hash);
1015                 firsthashrelem = relem;
1016
1017                 while (relem < lastrelem) {     /* gobble up all the rest */
1018                     HE *didstore;
1019                     sv = *relem ? *relem : &PL_sv_no;
1020                     relem++;
1021                     tmpstr = newSV(0);
1022                     if (*relem)
1023                         sv_setsv(tmpstr,*relem);        /* value */
1024                     *(relem++) = tmpstr;
1025                     if (gimme != G_VOID && hv_exists_ent(hash, sv, 0))
1026                         /* key overwrites an existing entry */
1027                         duplicates += 2;
1028                     didstore = hv_store_ent(hash,sv,tmpstr,0);
1029                     if (magic) {
1030                         if (SvSMAGICAL(tmpstr))
1031                             mg_set(tmpstr);
1032                         if (!didstore)
1033                             sv_2mortal(tmpstr);
1034                     }
1035                     TAINT_NOT;
1036                 }
1037                 if (relem == lastrelem) {
1038                     do_oddball(hash, relem, firstrelem);
1039                     relem++;
1040                 }
1041             }
1042             break;
1043         default:
1044             if (SvIMMORTAL(sv)) {
1045                 if (relem <= lastrelem)
1046                     relem++;
1047                 break;
1048             }
1049             if (relem <= lastrelem) {
1050                 sv_setsv(sv, *relem);
1051                 *(relem++) = sv;
1052             }
1053             else
1054                 sv_setsv(sv, &PL_sv_undef);
1055             SvSETMAGIC(sv);
1056             break;
1057         }
1058     }
1059     if (PL_delaymagic & ~DM_DELAY) {
1060         if (PL_delaymagic & DM_UID) {
1061 #ifdef HAS_SETRESUID
1062             (void)setresuid((PL_delaymagic & DM_RUID) ? PL_uid  : (Uid_t)-1,
1063                             (PL_delaymagic & DM_EUID) ? PL_euid : (Uid_t)-1,
1064                             (Uid_t)-1);
1065 #else
1066 #  ifdef HAS_SETREUID
1067             (void)setreuid((PL_delaymagic & DM_RUID) ? PL_uid  : (Uid_t)-1,
1068                            (PL_delaymagic & DM_EUID) ? PL_euid : (Uid_t)-1);
1069 #  else
1070 #    ifdef HAS_SETRUID
1071             if ((PL_delaymagic & DM_UID) == DM_RUID) {
1072                 (void)setruid(PL_uid);
1073                 PL_delaymagic &= ~DM_RUID;
1074             }
1075 #    endif /* HAS_SETRUID */
1076 #    ifdef HAS_SETEUID
1077             if ((PL_delaymagic & DM_UID) == DM_EUID) {
1078                 (void)seteuid(PL_euid);
1079                 PL_delaymagic &= ~DM_EUID;
1080             }
1081 #    endif /* HAS_SETEUID */
1082             if (PL_delaymagic & DM_UID) {
1083                 if (PL_uid != PL_euid)
1084                     DIE(aTHX_ "No setreuid available");
1085                 (void)PerlProc_setuid(PL_uid);
1086             }
1087 #  endif /* HAS_SETREUID */
1088 #endif /* HAS_SETRESUID */
1089             PL_uid = PerlProc_getuid();
1090             PL_euid = PerlProc_geteuid();
1091         }
1092         if (PL_delaymagic & DM_GID) {
1093 #ifdef HAS_SETRESGID
1094             (void)setresgid((PL_delaymagic & DM_RGID) ? PL_gid  : (Gid_t)-1,
1095                             (PL_delaymagic & DM_EGID) ? PL_egid : (Gid_t)-1,
1096                             (Gid_t)-1);
1097 #else
1098 #  ifdef HAS_SETREGID
1099             (void)setregid((PL_delaymagic & DM_RGID) ? PL_gid  : (Gid_t)-1,
1100                            (PL_delaymagic & DM_EGID) ? PL_egid : (Gid_t)-1);
1101 #  else
1102 #    ifdef HAS_SETRGID
1103             if ((PL_delaymagic & DM_GID) == DM_RGID) {
1104                 (void)setrgid(PL_gid);
1105                 PL_delaymagic &= ~DM_RGID;
1106             }
1107 #    endif /* HAS_SETRGID */
1108 #    ifdef HAS_SETEGID
1109             if ((PL_delaymagic & DM_GID) == DM_EGID) {
1110                 (void)setegid(PL_egid);
1111                 PL_delaymagic &= ~DM_EGID;
1112             }
1113 #    endif /* HAS_SETEGID */
1114             if (PL_delaymagic & DM_GID) {
1115                 if (PL_gid != PL_egid)
1116                     DIE(aTHX_ "No setregid available");
1117                 (void)PerlProc_setgid(PL_gid);
1118             }
1119 #  endif /* HAS_SETREGID */
1120 #endif /* HAS_SETRESGID */
1121             PL_gid = PerlProc_getgid();
1122             PL_egid = PerlProc_getegid();
1123         }
1124         PL_tainting |= (PL_uid && (PL_euid != PL_uid || PL_egid != PL_gid));
1125
1126         if (PL_delaymagic & DM_ARRAY && SvMAGICAL((SV*)ary))
1127             mg_set((SV*)ary);
1128     }
1129     PL_delaymagic = 0;
1130
1131     if (gimme == G_VOID)
1132         SP = firstrelem - 1;
1133     else if (gimme == G_SCALAR) {
1134         dTARGET;
1135         SP = firstrelem;
1136         SETi(lastrelem - firstrelem + 1 - duplicates);
1137     }
1138     else {
1139         if (ary)
1140             SP = lastrelem;
1141         else if (hash) {
1142             if (duplicates) {
1143                 /* Removes from the stack the entries which ended up as
1144                  * duplicated keys in the hash (fix for [perl #24380]) */
1145                 Move(firsthashrelem + duplicates,
1146                         firsthashrelem, duplicates, SV**);
1147                 lastrelem -= duplicates;
1148             }
1149             SP = lastrelem;
1150         }
1151         else
1152             SP = firstrelem + (lastlelem - firstlelem);
1153         lelem = firstlelem + (relem - firstrelem);
1154         while (relem <= SP)
1155             *relem++ = (lelem <= lastlelem) ? *lelem++ : &PL_sv_undef;
1156     }
1157
1158     RETURN;
1159 }
1160
1161 PP(pp_qr)
1162 {
1163     dVAR; dSP;
1164     register PMOP * const pm = cPMOP;
1165     REGEXP * rx = PM_GETRE(pm);
1166     SV * const pkg = CALLREG_PACKAGE(rx);
1167     SV * const rv = sv_newmortal();
1168     SV * const sv = newSVrv(rv, SvPV_nolen(pkg));
1169     if (rx->extflags & RXf_TAINTED)
1170         SvTAINTED_on(rv);
1171     sv_magic(sv,(SV*)ReREFCNT_inc(rx), PERL_MAGIC_qr,0,0);
1172     XPUSHs(rv);
1173     RETURN;
1174 }
1175
1176 PP(pp_match)
1177 {
1178     dVAR; dSP; dTARG;
1179     register PMOP *pm = cPMOP;
1180     PMOP *dynpm = pm;
1181     register const char *t;
1182     register const char *s;
1183     const char *strend;
1184     I32 global;
1185     I32 r_flags = REXEC_CHECKED;
1186     const char *truebase;                       /* Start of string  */
1187     register REGEXP *rx = PM_GETRE(pm);
1188     bool rxtainted;
1189     const I32 gimme = GIMME;
1190     STRLEN len;
1191     I32 minmatch = 0;
1192     const I32 oldsave = PL_savestack_ix;
1193     I32 update_minmatch = 1;
1194     I32 had_zerolen = 0;
1195     U32 gpos = 0;
1196
1197     if (PL_op->op_flags & OPf_STACKED)
1198         TARG = POPs;
1199     else if (PL_op->op_private & OPpTARGET_MY)
1200         GETTARGET;
1201     else {
1202         TARG = DEFSV;
1203         EXTEND(SP,1);
1204     }
1205
1206     PUTBACK;                            /* EVAL blocks need stack_sp. */
1207     s = SvPV_const(TARG, len);
1208     if (!s)
1209         DIE(aTHX_ "panic: pp_match");
1210     strend = s + len;
1211     rxtainted = ((rx->extflags & RXf_TAINTED) ||
1212                  (PL_tainted && (pm->op_pmflags & PMf_RETAINT)));
1213     TAINT_NOT;
1214
1215     RX_MATCH_UTF8_set(rx, DO_UTF8(TARG));
1216
1217     /* PMdf_USED is set after a ?? matches once */
1218     if (
1219 #ifdef USE_ITHREADS
1220         SvREADONLY(PL_regex_pad[pm->op_pmoffset])
1221 #else
1222         pm->op_pmflags & PMf_USED
1223 #endif
1224     ) {
1225       failure:
1226         if (gimme == G_ARRAY)
1227             RETURN;
1228         RETPUSHNO;
1229     }
1230
1231
1232
1233     /* empty pattern special-cased to use last successful pattern if possible */
1234     if (!rx->prelen && PL_curpm) {
1235         pm = PL_curpm;
1236         rx = PM_GETRE(pm);
1237     }
1238
1239     if (rx->minlen > (I32)len)
1240         goto failure;
1241
1242     truebase = t = s;
1243
1244     /* XXXX What part of this is needed with true \G-support? */
1245     if ((global = dynpm->op_pmflags & PMf_GLOBAL)) {
1246         rx->offs[0].start = -1;
1247         if (SvTYPE(TARG) >= SVt_PVMG && SvMAGIC(TARG)) {
1248             MAGIC* const mg = mg_find(TARG, PERL_MAGIC_regex_global);
1249             if (mg && mg->mg_len >= 0) {
1250                 if (!(rx->extflags & RXf_GPOS_SEEN))
1251                     rx->offs[0].end = rx->offs[0].start = mg->mg_len;
1252                 else if (rx->extflags & RXf_ANCH_GPOS) {
1253                     r_flags |= REXEC_IGNOREPOS;
1254                     rx->offs[0].end = rx->offs[0].start = mg->mg_len;
1255                 } else if (rx->extflags & RXf_GPOS_FLOAT)
1256                     gpos = mg->mg_len;
1257                 else
1258                     rx->offs[0].end = rx->offs[0].start = mg->mg_len;
1259                 minmatch = (mg->mg_flags & MGf_MINMATCH) ? rx->gofs + 1 : 0;
1260                 update_minmatch = 0;
1261             }
1262         }
1263     }
1264     /* XXX: comment out !global get safe $1 vars after a
1265        match, BUT be aware that this leads to dramatic slowdowns on
1266        /g matches against large strings.  So far a solution to this problem
1267        appears to be quite tricky.
1268        Test for the unsafe vars are TODO for now. */
1269     if ((  !global &&  rx->nparens)
1270             || SvTEMP(TARG) || PL_sawampersand ||
1271             (rx->extflags & (RXf_EVAL_SEEN|RXf_PMf_KEEPCOPY)))
1272         r_flags |= REXEC_COPY_STR;
1273     if (SvSCREAM(TARG))
1274         r_flags |= REXEC_SCREAM;
1275
1276 play_it_again:
1277     if (global && rx->offs[0].start != -1) {
1278         t = s = rx->offs[0].end + truebase - rx->gofs;
1279         if ((s + rx->minlen) > strend || s < truebase)
1280             goto nope;
1281         if (update_minmatch++)
1282             minmatch = had_zerolen;
1283     }
1284     if (rx->extflags & RXf_USE_INTUIT &&
1285         DO_UTF8(TARG) == ((rx->extflags & RXf_UTF8) != 0)) {
1286         /* FIXME - can PL_bostr be made const char *?  */
1287         PL_bostr = (char *)truebase;
1288         s = CALLREG_INTUIT_START(rx, TARG, (char *)s, (char *)strend, r_flags, NULL);
1289
1290         if (!s)
1291             goto nope;
1292         if ( (rx->extflags & RXf_CHECK_ALL)
1293              && !PL_sawampersand
1294              && !(rx->extflags & RXf_PMf_KEEPCOPY)
1295              && ((rx->extflags & RXf_NOSCAN)
1296                  || !((rx->extflags & RXf_INTUIT_TAIL)
1297                       && (r_flags & REXEC_SCREAM)))
1298              && !SvROK(TARG))   /* Cannot trust since INTUIT cannot guess ^ */
1299             goto yup;
1300     }
1301     if (CALLREGEXEC(rx, (char*)s, (char *)strend, (char*)truebase, minmatch, TARG, INT2PTR(void*, gpos), r_flags))
1302     {
1303         PL_curpm = pm;
1304         if (dynpm->op_pmflags & PMf_ONCE) {
1305 #ifdef USE_ITHREADS
1306             SvREADONLY_on(PL_regex_pad[dynpm->op_pmoffset]);
1307 #else
1308             dynpm->op_pmflags |= PMf_USED;
1309 #endif
1310         }
1311         goto gotcha;
1312     }
1313     else
1314         goto ret_no;
1315     /*NOTREACHED*/
1316
1317   gotcha:
1318     if (rxtainted)
1319         RX_MATCH_TAINTED_on(rx);
1320     TAINT_IF(RX_MATCH_TAINTED(rx));
1321     if (gimme == G_ARRAY) {
1322         const I32 nparens = rx->nparens;
1323         I32 i = (global && !nparens) ? 1 : 0;
1324
1325         SPAGAIN;                        /* EVAL blocks could move the stack. */
1326         EXTEND(SP, nparens + i);
1327         EXTEND_MORTAL(nparens + i);
1328         for (i = !i; i <= nparens; i++) {
1329             PUSHs(sv_newmortal());
1330             if ((rx->offs[i].start != -1) && rx->offs[i].end != -1 ) {
1331                 const I32 len = rx->offs[i].end - rx->offs[i].start;
1332                 s = rx->offs[i].start + truebase;
1333                 if (rx->offs[i].end < 0 || rx->offs[i].start < 0 ||
1334                     len < 0 || len > strend - s)
1335                     DIE(aTHX_ "panic: pp_match start/end pointers");
1336                 sv_setpvn(*SP, s, len);
1337                 if (DO_UTF8(TARG) && is_utf8_string((U8*)s, len))
1338                     SvUTF8_on(*SP);
1339             }
1340         }
1341         if (global) {
1342             if (dynpm->op_pmflags & PMf_CONTINUE) {
1343                 MAGIC* mg = NULL;
1344                 if (SvTYPE(TARG) >= SVt_PVMG && SvMAGIC(TARG))
1345                     mg = mg_find(TARG, PERL_MAGIC_regex_global);
1346                 if (!mg) {
1347 #ifdef PERL_OLD_COPY_ON_WRITE
1348                     if (SvIsCOW(TARG))
1349                         sv_force_normal_flags(TARG, 0);
1350 #endif
1351                     mg = sv_magicext(TARG, NULL, PERL_MAGIC_regex_global,
1352                                      &PL_vtbl_mglob, NULL, 0);
1353                 }
1354                 if (rx->offs[0].start != -1) {
1355                     mg->mg_len = rx->offs[0].end;
1356                     if (rx->offs[0].start + rx->gofs == (UV)rx->offs[0].end)
1357                         mg->mg_flags |= MGf_MINMATCH;
1358                     else
1359                         mg->mg_flags &= ~MGf_MINMATCH;
1360                 }
1361             }
1362             had_zerolen = (rx->offs[0].start != -1
1363                            && (rx->offs[0].start + rx->gofs
1364                                == (UV)rx->offs[0].end));
1365             PUTBACK;                    /* EVAL blocks may use stack */
1366             r_flags |= REXEC_IGNOREPOS | REXEC_NOT_FIRST;
1367             goto play_it_again;
1368         }
1369         else if (!nparens)
1370             XPUSHs(&PL_sv_yes);
1371         LEAVE_SCOPE(oldsave);
1372         RETURN;
1373     }
1374     else {
1375         if (global) {
1376             MAGIC* mg;
1377             if (SvTYPE(TARG) >= SVt_PVMG && SvMAGIC(TARG))
1378                 mg = mg_find(TARG, PERL_MAGIC_regex_global);
1379             else
1380                 mg = NULL;
1381             if (!mg) {
1382 #ifdef PERL_OLD_COPY_ON_WRITE
1383                 if (SvIsCOW(TARG))
1384                     sv_force_normal_flags(TARG, 0);
1385 #endif
1386                 mg = sv_magicext(TARG, NULL, PERL_MAGIC_regex_global,
1387                                  &PL_vtbl_mglob, NULL, 0);
1388             }
1389             if (rx->offs[0].start != -1) {
1390                 mg->mg_len = rx->offs[0].end;
1391                 if (rx->offs[0].start + rx->gofs == (UV)rx->offs[0].end)
1392                     mg->mg_flags |= MGf_MINMATCH;
1393                 else
1394                     mg->mg_flags &= ~MGf_MINMATCH;
1395             }
1396         }
1397         LEAVE_SCOPE(oldsave);
1398         RETPUSHYES;
1399     }
1400
1401 yup:                                    /* Confirmed by INTUIT */
1402     if (rxtainted)
1403         RX_MATCH_TAINTED_on(rx);
1404     TAINT_IF(RX_MATCH_TAINTED(rx));
1405     PL_curpm = pm;
1406     if (dynpm->op_pmflags & PMf_ONCE) {
1407 #ifdef USE_ITHREADS
1408         SvREADONLY_on(PL_regex_pad[dynpm->op_pmoffset]);
1409 #else
1410         dynpm->op_pmflags |= PMf_USED;
1411 #endif
1412     }
1413     if (RX_MATCH_COPIED(rx))
1414         Safefree(rx->subbeg);
1415     RX_MATCH_COPIED_off(rx);
1416     rx->subbeg = NULL;
1417     if (global) {
1418         /* FIXME - should rx->subbeg be const char *?  */
1419         rx->subbeg = (char *) truebase;
1420         rx->offs[0].start = s - truebase;
1421         if (RX_MATCH_UTF8(rx)) {
1422             char * const t = (char*)utf8_hop((U8*)s, rx->minlenret);
1423             rx->offs[0].end = t - truebase;
1424         }
1425         else {
1426             rx->offs[0].end = s - truebase + rx->minlenret;
1427         }
1428         rx->sublen = strend - truebase;
1429         goto gotcha;
1430     }
1431     if (PL_sawampersand || rx->extflags & RXf_PMf_KEEPCOPY) {
1432         I32 off;
1433 #ifdef PERL_OLD_COPY_ON_WRITE
1434         if (SvIsCOW(TARG) || (SvFLAGS(TARG) & CAN_COW_MASK) == CAN_COW_FLAGS) {
1435             if (DEBUG_C_TEST) {
1436                 PerlIO_printf(Perl_debug_log,
1437                               "Copy on write: pp_match $& capture, type %d, truebase=%p, t=%p, difference %d\n",
1438                               (int) SvTYPE(TARG), (void*)truebase, (void*)t,
1439                               (int)(t-truebase));
1440             }
1441             rx->saved_copy = sv_setsv_cow(rx->saved_copy, TARG);
1442             rx->subbeg = (char *) SvPVX_const(rx->saved_copy) + (t - truebase);
1443             assert (SvPOKp(rx->saved_copy));
1444         } else
1445 #endif
1446         {
1447
1448             rx->subbeg = savepvn(t, strend - t);
1449 #ifdef PERL_OLD_COPY_ON_WRITE
1450             rx->saved_copy = NULL;
1451 #endif
1452         }
1453         rx->sublen = strend - t;
1454         RX_MATCH_COPIED_on(rx);
1455         off = rx->offs[0].start = s - t;
1456         rx->offs[0].end = off + rx->minlenret;
1457     }
1458     else {                      /* startp/endp are used by @- @+. */
1459         rx->offs[0].start = s - truebase;
1460         rx->offs[0].end = s - truebase + rx->minlenret;
1461     }
1462     /* including rx->nparens in the below code seems highly suspicious.
1463        -dmq */
1464     rx->nparens = rx->lastparen = rx->lastcloseparen = 0;       /* used by @-, @+, and $^N */
1465     LEAVE_SCOPE(oldsave);
1466     RETPUSHYES;
1467
1468 nope:
1469 ret_no:
1470     if (global && !(dynpm->op_pmflags & PMf_CONTINUE)) {
1471         if (SvTYPE(TARG) >= SVt_PVMG && SvMAGIC(TARG)) {
1472             MAGIC* const mg = mg_find(TARG, PERL_MAGIC_regex_global);
1473             if (mg)
1474                 mg->mg_len = -1;
1475         }
1476     }
1477     LEAVE_SCOPE(oldsave);
1478     if (gimme == G_ARRAY)
1479         RETURN;
1480     RETPUSHNO;
1481 }
1482
1483 OP *
1484 Perl_do_readline(pTHX)
1485 {
1486     dVAR; dSP; dTARGETSTACKED;
1487     register SV *sv;
1488     STRLEN tmplen = 0;
1489     STRLEN offset;
1490     PerlIO *fp;
1491     register IO * const io = GvIO(PL_last_in_gv);
1492     register const I32 type = PL_op->op_type;
1493     const I32 gimme = GIMME_V;
1494
1495     if (io) {
1496         MAGIC * const mg = SvTIED_mg((SV*)io, PERL_MAGIC_tiedscalar);
1497         if (mg) {
1498             PUSHMARK(SP);
1499             XPUSHs(SvTIED_obj((SV*)io, mg));
1500             PUTBACK;
1501             ENTER;
1502             call_method("READLINE", gimme);
1503             LEAVE;
1504             SPAGAIN;
1505             if (gimme == G_SCALAR) {
1506                 SV* const result = POPs;
1507                 SvSetSV_nosteal(TARG, result);
1508                 PUSHTARG;
1509             }
1510             RETURN;
1511         }
1512     }
1513     fp = NULL;
1514     if (io) {
1515         fp = IoIFP(io);
1516         if (!fp) {
1517             if (IoFLAGS(io) & IOf_ARGV) {
1518                 if (IoFLAGS(io) & IOf_START) {
1519                     IoLINES(io) = 0;
1520                     if (av_len(GvAVn(PL_last_in_gv)) < 0) {
1521                         IoFLAGS(io) &= ~IOf_START;
1522                         do_open(PL_last_in_gv,"-",1,FALSE,O_RDONLY,0,NULL);
1523                         sv_setpvn(GvSVn(PL_last_in_gv), "-", 1);
1524                         SvSETMAGIC(GvSV(PL_last_in_gv));
1525                         fp = IoIFP(io);
1526                         goto have_fp;
1527                     }
1528                 }
1529                 fp = nextargv(PL_last_in_gv);
1530                 if (!fp) { /* Note: fp != IoIFP(io) */
1531                     (void)do_close(PL_last_in_gv, FALSE); /* now it does*/
1532                 }
1533             }
1534             else if (type == OP_GLOB)
1535                 fp = Perl_start_glob(aTHX_ POPs, io);
1536         }
1537         else if (type == OP_GLOB)
1538             SP--;
1539         else if (ckWARN(WARN_IO) && IoTYPE(io) == IoTYPE_WRONLY) {
1540             report_evil_fh(PL_last_in_gv, io, OP_phoney_OUTPUT_ONLY);
1541         }
1542     }
1543     if (!fp) {
1544         if ((!io || !(IoFLAGS(io) & IOf_START))
1545             && ckWARN2(WARN_GLOB, WARN_CLOSED))
1546         {
1547             if (type == OP_GLOB)
1548                 Perl_warner(aTHX_ packWARN(WARN_GLOB),
1549                             "glob failed (can't start child: %s)",
1550                             Strerror(errno));
1551             else
1552                 report_evil_fh(PL_last_in_gv, io, PL_op->op_type);
1553         }
1554         if (gimme == G_SCALAR) {
1555             /* undef TARG, and push that undefined value */
1556             if (type != OP_RCATLINE) {
1557                 SV_CHECK_THINKFIRST_COW_DROP(TARG);
1558                 SvOK_off(TARG);
1559             }
1560             PUSHTARG;
1561         }
1562         RETURN;
1563     }
1564   have_fp:
1565     if (gimme == G_SCALAR) {
1566         sv = TARG;
1567         if (type == OP_RCATLINE && SvGMAGICAL(sv))
1568             mg_get(sv);
1569         if (SvROK(sv)) {
1570             if (type == OP_RCATLINE)
1571                 SvPV_force_nolen(sv);
1572             else
1573                 sv_unref(sv);
1574         }
1575         else if (isGV_with_GP(sv)) {
1576             SvPV_force_nolen(sv);
1577         }
1578         SvUPGRADE(sv, SVt_PV);
1579         tmplen = SvLEN(sv);     /* remember if already alloced */
1580         if (!tmplen && !SvREADONLY(sv))
1581             Sv_Grow(sv, 80);    /* try short-buffering it */
1582         offset = 0;
1583         if (type == OP_RCATLINE && SvOK(sv)) {
1584             if (!SvPOK(sv)) {
1585                 SvPV_force_nolen(sv);
1586             }
1587             offset = SvCUR(sv);
1588         }
1589     }
1590     else {
1591         sv = sv_2mortal(newSV(80));
1592         offset = 0;
1593     }
1594
1595     /* This should not be marked tainted if the fp is marked clean */
1596 #define MAYBE_TAINT_LINE(io, sv) \
1597     if (!(IoFLAGS(io) & IOf_UNTAINT)) { \
1598         TAINT;                          \
1599         SvTAINTED_on(sv);               \
1600     }
1601
1602 /* delay EOF state for a snarfed empty file */
1603 #define SNARF_EOF(gimme,rs,io,sv) \
1604     (gimme != G_SCALAR || SvCUR(sv)                                     \
1605      || (IoFLAGS(io) & IOf_NOLINE) || !RsSNARF(rs))
1606
1607     for (;;) {
1608         PUTBACK;
1609         if (!sv_gets(sv, fp, offset)
1610             && (type == OP_GLOB
1611                 || SNARF_EOF(gimme, PL_rs, io, sv)
1612                 || PerlIO_error(fp)))
1613         {
1614             PerlIO_clearerr(fp);
1615             if (IoFLAGS(io) & IOf_ARGV) {
1616                 fp = nextargv(PL_last_in_gv);
1617                 if (fp)
1618                     continue;
1619                 (void)do_close(PL_last_in_gv, FALSE);
1620             }
1621             else if (type == OP_GLOB) {
1622                 if (!do_close(PL_last_in_gv, FALSE) && ckWARN(WARN_GLOB)) {
1623                     Perl_warner(aTHX_ packWARN(WARN_GLOB),
1624                            "glob failed (child exited with status %d%s)",
1625                            (int)(STATUS_CURRENT >> 8),
1626                            (STATUS_CURRENT & 0x80) ? ", core dumped" : "");
1627                 }
1628             }
1629             if (gimme == G_SCALAR) {
1630                 if (type != OP_RCATLINE) {
1631                     SV_CHECK_THINKFIRST_COW_DROP(TARG);
1632                     SvOK_off(TARG);
1633                 }
1634                 SPAGAIN;
1635                 PUSHTARG;
1636             }
1637             MAYBE_TAINT_LINE(io, sv);
1638             RETURN;
1639         }
1640         MAYBE_TAINT_LINE(io, sv);
1641         IoLINES(io)++;
1642         IoFLAGS(io) |= IOf_NOLINE;
1643         SvSETMAGIC(sv);
1644         SPAGAIN;
1645         XPUSHs(sv);
1646         if (type == OP_GLOB) {
1647             const char *t1;
1648
1649             if (SvCUR(sv) > 0 && SvCUR(PL_rs) > 0) {
1650                 char * const tmps = SvEND(sv) - 1;
1651                 if (*tmps == *SvPVX_const(PL_rs)) {
1652                     *tmps = '\0';
1653                     SvCUR_set(sv, SvCUR(sv) - 1);
1654                 }
1655             }
1656             for (t1 = SvPVX_const(sv); *t1; t1++)
1657                 if (!isALPHA(*t1) && !isDIGIT(*t1) &&
1658                     strchr("$&*(){}[]'\";\\|?<>~`", *t1))
1659                         break;
1660             if (*t1 && PerlLIO_lstat(SvPVX_const(sv), &PL_statbuf) < 0) {
1661                 (void)POPs;             /* Unmatched wildcard?  Chuck it... */
1662                 continue;
1663             }
1664         } else if (SvUTF8(sv)) { /* OP_READLINE, OP_RCATLINE */
1665              if (ckWARN(WARN_UTF8)) {
1666                 const U8 * const s = (const U8*)SvPVX_const(sv) + offset;
1667                 const STRLEN len = SvCUR(sv) - offset;
1668                 const U8 *f;
1669
1670                 if (!is_utf8_string_loc(s, len, &f))
1671                     /* Emulate :encoding(utf8) warning in the same case. */
1672                     Perl_warner(aTHX_ packWARN(WARN_UTF8),
1673                                 "utf8 \"\\x%02X\" does not map to Unicode",
1674                                 f < (U8*)SvEND(sv) ? *f : 0);
1675              }
1676         }
1677         if (gimme == G_ARRAY) {
1678             if (SvLEN(sv) - SvCUR(sv) > 20) {
1679                 SvPV_shrink_to_cur(sv);
1680             }
1681             sv = sv_2mortal(newSV(80));
1682             continue;
1683         }
1684         else if (gimme == G_SCALAR && !tmplen && SvLEN(sv) - SvCUR(sv) > 80) {
1685             /* try to reclaim a bit of scalar space (only on 1st alloc) */
1686             const STRLEN new_len
1687                 = SvCUR(sv) < 60 ? 80 : SvCUR(sv)+40; /* allow some slop */
1688             SvPV_renew(sv, new_len);
1689         }
1690         RETURN;
1691     }
1692 }
1693
1694 PP(pp_enter)
1695 {
1696     dVAR; dSP;
1697     register PERL_CONTEXT *cx;
1698     I32 gimme = OP_GIMME(PL_op, -1);
1699
1700     if (gimme == -1) {
1701         if (cxstack_ix >= 0)
1702             gimme = cxstack[cxstack_ix].blk_gimme;
1703         else
1704             gimme = G_SCALAR;
1705     }
1706
1707     ENTER;
1708
1709     SAVETMPS;
1710     PUSHBLOCK(cx, CXt_BLOCK, SP);
1711
1712     RETURN;
1713 }
1714
1715 PP(pp_helem)
1716 {
1717     dVAR; dSP;
1718     HE* he;
1719     SV **svp;
1720     SV * const keysv = POPs;
1721     HV * const hv = (HV*)POPs;
1722     const U32 lval = PL_op->op_flags & OPf_MOD || LVRET;
1723     const U32 defer = PL_op->op_private & OPpLVAL_DEFER;
1724     SV *sv;
1725     const U32 hash = (SvIsCOW_shared_hash(keysv)) ? SvSHARED_HASH(keysv) : 0;
1726     I32 preeminent = 0;
1727
1728     if (SvTYPE(hv) != SVt_PVHV)
1729         RETPUSHUNDEF;
1730
1731     if (PL_op->op_private & OPpLVAL_INTRO) {
1732         MAGIC *mg;
1733         HV *stash;
1734         /* does the element we're localizing already exist? */
1735         preeminent = /* can we determine whether it exists? */
1736             (    !SvRMAGICAL(hv)
1737                 || mg_find((SV*)hv, PERL_MAGIC_env)
1738                 || (     (mg = mg_find((SV*)hv, PERL_MAGIC_tied))
1739                         /* Try to preserve the existenceness of a tied hash
1740                         * element by using EXISTS and DELETE if possible.
1741                         * Fallback to FETCH and STORE otherwise */
1742                     && (stash = SvSTASH(SvRV(SvTIED_obj((SV*)hv, mg))))
1743                     && gv_fetchmethod_autoload(stash, "EXISTS", TRUE)
1744                     && gv_fetchmethod_autoload(stash, "DELETE", TRUE)
1745                 )
1746             ) ? hv_exists_ent(hv, keysv, 0) : 1;
1747     }
1748     he = hv_fetch_ent(hv, keysv, lval && !defer, hash);
1749     svp = he ? &HeVAL(he) : NULL;
1750     if (lval) {
1751         if (!svp || *svp == &PL_sv_undef) {
1752             SV* lv;
1753             SV* key2;
1754             if (!defer) {
1755                 DIE(aTHX_ PL_no_helem_sv, SVfARG(keysv));
1756             }
1757             lv = sv_newmortal();
1758             sv_upgrade(lv, SVt_PVLV);
1759             LvTYPE(lv) = 'y';
1760             sv_magic(lv, key2 = newSVsv(keysv), PERL_MAGIC_defelem, NULL, 0);
1761             SvREFCNT_dec(key2); /* sv_magic() increments refcount */
1762             LvTARG(lv) = SvREFCNT_inc_simple(hv);
1763             LvTARGLEN(lv) = 1;
1764             PUSHs(lv);
1765             RETURN;
1766         }
1767         if (PL_op->op_private & OPpLVAL_INTRO) {
1768             if (HvNAME_get(hv) && isGV(*svp))
1769                 save_gp((GV*)*svp, !(PL_op->op_flags & OPf_SPECIAL));
1770             else {
1771                 if (!preeminent) {
1772                     STRLEN keylen;
1773                     const char * const key = SvPV_const(keysv, keylen);
1774                     SAVEDELETE(hv, savepvn(key,keylen),
1775                                SvUTF8(keysv) ? -(I32)keylen : (I32)keylen);
1776                 } else
1777                     save_helem(hv, keysv, svp);
1778             }
1779         }
1780         else if (PL_op->op_private & OPpDEREF)
1781             vivify_ref(*svp, PL_op->op_private & OPpDEREF);
1782     }
1783     sv = (svp ? *svp : &PL_sv_undef);
1784     /* This makes C<local $tied{foo} = $tied{foo}> possible.
1785      * Pushing the magical RHS on to the stack is useless, since
1786      * that magic is soon destined to be misled by the local(),
1787      * and thus the later pp_sassign() will fail to mg_get() the
1788      * old value.  This should also cure problems with delayed
1789      * mg_get()s.  GSAR 98-07-03 */
1790     if (!lval && SvGMAGICAL(sv))
1791         sv = sv_mortalcopy(sv);
1792     PUSHs(sv);
1793     RETURN;
1794 }
1795
1796 PP(pp_leave)
1797 {
1798     dVAR; dSP;
1799     register PERL_CONTEXT *cx;
1800     SV **newsp;
1801     PMOP *newpm;
1802     I32 gimme;
1803
1804     if (PL_op->op_flags & OPf_SPECIAL) {
1805         cx = &cxstack[cxstack_ix];
1806         cx->blk_oldpm = PL_curpm;       /* fake block should preserve $1 et al */
1807     }
1808
1809     POPBLOCK(cx,newpm);
1810
1811     gimme = OP_GIMME(PL_op, -1);
1812     if (gimme == -1) {
1813         if (cxstack_ix >= 0)
1814             gimme = cxstack[cxstack_ix].blk_gimme;
1815         else
1816             gimme = G_SCALAR;
1817     }
1818
1819     TAINT_NOT;
1820     if (gimme == G_VOID)
1821         SP = newsp;
1822     else if (gimme == G_SCALAR) {
1823         register SV **mark;
1824         MARK = newsp + 1;
1825         if (MARK <= SP) {
1826             if (SvFLAGS(TOPs) & (SVs_PADTMP|SVs_TEMP))
1827                 *MARK = TOPs;
1828             else
1829                 *MARK = sv_mortalcopy(TOPs);
1830         } else {
1831             MEXTEND(mark,0);
1832             *MARK = &PL_sv_undef;
1833         }
1834         SP = MARK;
1835     }
1836     else if (gimme == G_ARRAY) {
1837         /* in case LEAVE wipes old return values */
1838         register SV **mark;
1839         for (mark = newsp + 1; mark <= SP; mark++) {
1840             if (!(SvFLAGS(*mark) & (SVs_PADTMP|SVs_TEMP))) {
1841                 *mark = sv_mortalcopy(*mark);
1842                 TAINT_NOT;      /* Each item is independent */
1843             }
1844         }
1845     }
1846     PL_curpm = newpm;   /* Don't pop $1 et al till now */
1847
1848     LEAVE;
1849
1850     RETURN;
1851 }
1852
1853 PP(pp_iter)
1854 {
1855     dVAR; dSP;
1856     register PERL_CONTEXT *cx;
1857     SV *sv, *oldsv;
1858     AV* av;
1859     SV **itersvp;
1860
1861     EXTEND(SP, 1);
1862     cx = &cxstack[cxstack_ix];
1863     if (CxTYPE(cx) != CXt_LOOP)
1864         DIE(aTHX_ "panic: pp_iter");
1865
1866     itersvp = CxITERVAR(cx);
1867     av = cx->blk_loop.iterary;
1868     if (SvTYPE(av) != SVt_PVAV) {
1869         /* iterate ($min .. $max) */
1870         if (cx->blk_loop.iterlval) {
1871             /* string increment */
1872             register SV* cur = cx->blk_loop.iterlval;
1873             STRLEN maxlen = 0;
1874             const char *max =
1875               SvOK((SV*)av) ?
1876               SvPV_const((SV*)av, maxlen) : (const char *)"";
1877             if (!SvNIOK(cur) && SvCUR(cur) <= maxlen) {
1878                 if (SvREFCNT(*itersvp) == 1 && !SvMAGICAL(*itersvp)) {
1879                     /* safe to reuse old SV */
1880                     sv_setsv(*itersvp, cur);
1881                 }
1882                 else
1883                 {
1884                     /* we need a fresh SV every time so that loop body sees a
1885                      * completely new SV for closures/references to work as
1886                      * they used to */
1887                     oldsv = *itersvp;
1888                     *itersvp = newSVsv(cur);
1889                     SvREFCNT_dec(oldsv);
1890                 }
1891                 if (strEQ(SvPVX_const(cur), max))
1892                     sv_setiv(cur, 0); /* terminate next time */
1893                 else
1894                     sv_inc(cur);
1895                 RETPUSHYES;
1896             }
1897             RETPUSHNO;
1898         }
1899         /* integer increment */
1900         if (cx->blk_loop.iterix > cx->blk_loop.itermax)
1901             RETPUSHNO;
1902
1903         /* don't risk potential race */
1904         if (SvREFCNT(*itersvp) == 1 && !SvMAGICAL(*itersvp)) {
1905             /* safe to reuse old SV */
1906             sv_setiv(*itersvp, cx->blk_loop.iterix++);
1907         }
1908         else
1909         {
1910             /* we need a fresh SV every time so that loop body sees a
1911              * completely new SV for closures/references to work as they
1912              * used to */
1913             oldsv = *itersvp;
1914             *itersvp = newSViv(cx->blk_loop.iterix++);
1915             SvREFCNT_dec(oldsv);
1916         }
1917         RETPUSHYES;
1918     }
1919
1920     /* iterate array */
1921     if (PL_op->op_private & OPpITER_REVERSED) {
1922         /* In reverse, use itermax as the min :-)  */
1923         if (cx->blk_loop.iterix <= cx->blk_loop.itermax)
1924             RETPUSHNO;
1925
1926         if (SvMAGICAL(av) || AvREIFY(av)) {
1927             SV * const * const svp = av_fetch(av, --cx->blk_loop.iterix, FALSE);
1928             sv = svp ? *svp : NULL;
1929         }
1930         else {
1931             sv = AvARRAY(av)[--cx->blk_loop.iterix];
1932         }
1933     }
1934     else {
1935         if (cx->blk_loop.iterix >= (av == PL_curstack ? cx->blk_oldsp :
1936                                     AvFILL(av)))
1937             RETPUSHNO;
1938
1939         if (SvMAGICAL(av) || AvREIFY(av)) {
1940             SV * const * const svp = av_fetch(av, ++cx->blk_loop.iterix, FALSE);
1941             sv = svp ? *svp : NULL;
1942         }
1943         else {
1944             sv = AvARRAY(av)[++cx->blk_loop.iterix];
1945         }
1946     }
1947
1948     if (sv && SvIS_FREED(sv)) {
1949         *itersvp = NULL;
1950         Perl_croak(aTHX_ "Use of freed value in iteration");
1951     }
1952
1953     if (sv)
1954         SvTEMP_off(sv);
1955     else
1956         sv = &PL_sv_undef;
1957     if (av != PL_curstack && sv == &PL_sv_undef) {
1958         SV *lv = cx->blk_loop.iterlval;
1959         if (lv && SvREFCNT(lv) > 1) {
1960             SvREFCNT_dec(lv);
1961             lv = NULL;
1962         }
1963         if (lv)
1964             SvREFCNT_dec(LvTARG(lv));
1965         else {
1966             lv = cx->blk_loop.iterlval = newSV_type(SVt_PVLV);
1967             LvTYPE(lv) = 'y';
1968             sv_magic(lv, NULL, PERL_MAGIC_defelem, NULL, 0);
1969         }
1970         LvTARG(lv) = SvREFCNT_inc_simple(av);
1971         LvTARGOFF(lv) = cx->blk_loop.iterix;
1972         LvTARGLEN(lv) = (STRLEN)UV_MAX;
1973         sv = (SV*)lv;
1974     }
1975
1976     oldsv = *itersvp;
1977     *itersvp = SvREFCNT_inc_simple_NN(sv);
1978     SvREFCNT_dec(oldsv);
1979
1980     RETPUSHYES;
1981 }
1982
1983 PP(pp_subst)
1984 {
1985     dVAR; dSP; dTARG;
1986     register PMOP *pm = cPMOP;
1987     PMOP *rpm = pm;
1988     register char *s;
1989     char *strend;
1990     register char *m;
1991     const char *c;
1992     register char *d;
1993     STRLEN clen;
1994     I32 iters = 0;
1995     I32 maxiters;
1996     register I32 i;
1997     bool once;
1998     bool rxtainted;
1999     char *orig;
2000     I32 r_flags;
2001     register REGEXP *rx = PM_GETRE(pm);
2002     STRLEN len;
2003     int force_on_match = 0;
2004     const I32 oldsave = PL_savestack_ix;
2005     STRLEN slen;
2006     bool doutf8 = FALSE;
2007 #ifdef PERL_OLD_COPY_ON_WRITE
2008     bool is_cow;
2009 #endif
2010     SV *nsv = NULL;
2011
2012     /* known replacement string? */
2013     register SV *dstr = (pm->op_pmflags & PMf_CONST) ? POPs : NULL;
2014     if (PL_op->op_flags & OPf_STACKED)
2015         TARG = POPs;
2016     else if (PL_op->op_private & OPpTARGET_MY)
2017         GETTARGET;
2018     else {
2019         TARG = DEFSV;
2020         EXTEND(SP,1);
2021     }
2022
2023 #ifdef PERL_OLD_COPY_ON_WRITE
2024     /* Awooga. Awooga. "bool" types that are actually char are dangerous,
2025        because they make integers such as 256 "false".  */
2026     is_cow = SvIsCOW(TARG) ? TRUE : FALSE;
2027 #else
2028     if (SvIsCOW(TARG))
2029         sv_force_normal_flags(TARG,0);
2030 #endif
2031     if (
2032 #ifdef PERL_OLD_COPY_ON_WRITE
2033         !is_cow &&
2034 #endif
2035         (SvREADONLY(TARG)
2036          || ( ((SvTYPE(TARG) == SVt_PVGV && isGV_with_GP(TARG))
2037                || SvTYPE(TARG) > SVt_PVLV)
2038              && !(SvTYPE(TARG) == SVt_PVGV && SvFAKE(TARG)))))
2039         DIE(aTHX_ PL_no_modify);
2040     PUTBACK;
2041
2042     s = SvPV_mutable(TARG, len);
2043     if (!SvPOKp(TARG) || SvTYPE(TARG) == SVt_PVGV)
2044         force_on_match = 1;
2045     rxtainted = ((rx->extflags & RXf_TAINTED) ||
2046                  (PL_tainted && (pm->op_pmflags & PMf_RETAINT)));
2047     if (PL_tainted)
2048         rxtainted |= 2;
2049     TAINT_NOT;
2050
2051     RX_MATCH_UTF8_set(rx, DO_UTF8(TARG));
2052
2053   force_it:
2054     if (!pm || !s)
2055         DIE(aTHX_ "panic: pp_subst");
2056
2057     strend = s + len;
2058     slen = RX_MATCH_UTF8(rx) ? utf8_length((U8*)s, (U8*)strend) : len;
2059     maxiters = 2 * slen + 10;   /* We can match twice at each
2060                                    position, once with zero-length,
2061                                    second time with non-zero. */
2062
2063     if (!rx->prelen && PL_curpm) {
2064         pm = PL_curpm;
2065         rx = PM_GETRE(pm);
2066     }
2067     r_flags = (rx->nparens || SvTEMP(TARG) || PL_sawampersand
2068             || (rx->extflags & (RXf_EVAL_SEEN|RXf_PMf_KEEPCOPY)) )
2069                ? REXEC_COPY_STR : 0;
2070     if (SvSCREAM(TARG))
2071         r_flags |= REXEC_SCREAM;
2072
2073     orig = m = s;
2074     if (rx->extflags & RXf_USE_INTUIT) {
2075         PL_bostr = orig;
2076         s = CALLREG_INTUIT_START(rx, TARG, s, strend, r_flags, NULL);
2077
2078         if (!s)
2079             goto nope;
2080         /* How to do it in subst? */
2081 /*      if ( (rx->extflags & RXf_CHECK_ALL)
2082              && !PL_sawampersand
2083              && !(rx->extflags & RXf_KEEPCOPY)
2084              && ((rx->extflags & RXf_NOSCAN)
2085                  || !((rx->extflags & RXf_INTUIT_TAIL)
2086                       && (r_flags & REXEC_SCREAM))))
2087             goto yup;
2088 */
2089     }
2090
2091     /* only replace once? */
2092     once = !(rpm->op_pmflags & PMf_GLOBAL);
2093
2094     /* known replacement string? */
2095     if (dstr) {
2096         /* replacement needing upgrading? */
2097         if (DO_UTF8(TARG) && !doutf8) {
2098              nsv = sv_newmortal();
2099              SvSetSV(nsv, dstr);
2100              if (PL_encoding)
2101                   sv_recode_to_utf8(nsv, PL_encoding);
2102              else
2103                   sv_utf8_upgrade(nsv);
2104              c = SvPV_const(nsv, clen);
2105              doutf8 = TRUE;
2106         }
2107         else {
2108             c = SvPV_const(dstr, clen);
2109             doutf8 = DO_UTF8(dstr);
2110         }
2111     }
2112     else {
2113         c = NULL;
2114         doutf8 = FALSE;
2115     }
2116
2117     /* can do inplace substitution? */
2118     if (c
2119 #ifdef PERL_OLD_COPY_ON_WRITE
2120         && !is_cow
2121 #endif
2122         && (I32)clen <= rx->minlenret && (once || !(r_flags & REXEC_COPY_STR))
2123         && !(rx->extflags & RXf_LOOKBEHIND_SEEN)
2124         && (!doutf8 || SvUTF8(TARG))) {
2125         if (!CALLREGEXEC(rx, s, strend, orig, 0, TARG, NULL,
2126                          r_flags | REXEC_CHECKED))
2127         {
2128             SPAGAIN;
2129             PUSHs(&PL_sv_no);
2130             LEAVE_SCOPE(oldsave);
2131             RETURN;
2132         }
2133 #ifdef PERL_OLD_COPY_ON_WRITE
2134         if (SvIsCOW(TARG)) {
2135             assert (!force_on_match);
2136             goto have_a_cow;
2137         }
2138 #endif
2139         if (force_on_match) {
2140             force_on_match = 0;
2141             s = SvPV_force(TARG, len);
2142             goto force_it;
2143         }
2144         d = s;
2145         PL_curpm = pm;
2146         SvSCREAM_off(TARG);     /* disable possible screamer */
2147         if (once) {
2148             rxtainted |= RX_MATCH_TAINTED(rx);
2149             m = orig + rx->offs[0].start;
2150             d = orig + rx->offs[0].end;
2151             s = orig;
2152             if (m - s > strend - d) {  /* faster to shorten from end */
2153                 if (clen) {
2154                     Copy(c, m, clen, char);
2155                     m += clen;
2156                 }
2157                 i = strend - d;
2158                 if (i > 0) {
2159                     Move(d, m, i, char);
2160                     m += i;
2161                 }
2162                 *m = '\0';
2163                 SvCUR_set(TARG, m - s);
2164             }
2165             else if ((i = m - s)) {     /* faster from front */
2166                 d -= clen;
2167                 m = d;
2168                 sv_chop(TARG, d-i);
2169                 s += i;
2170                 while (i--)
2171                     *--d = *--s;
2172                 if (clen)
2173                     Copy(c, m, clen, char);
2174             }
2175             else if (clen) {
2176                 d -= clen;
2177                 sv_chop(TARG, d);
2178                 Copy(c, d, clen, char);
2179             }
2180             else {
2181                 sv_chop(TARG, d);
2182             }
2183             TAINT_IF(rxtainted & 1);
2184             SPAGAIN;
2185             PUSHs(&PL_sv_yes);
2186         }
2187         else {
2188             do {
2189                 if (iters++ > maxiters)
2190                     DIE(aTHX_ "Substitution loop");
2191                 rxtainted |= RX_MATCH_TAINTED(rx);
2192                 m = rx->offs[0].start + orig;
2193                 if ((i = m - s)) {
2194                     if (s != d)
2195                         Move(s, d, i, char);
2196                     d += i;
2197                 }
2198                 if (clen) {
2199                     Copy(c, d, clen, char);
2200                     d += clen;
2201                 }
2202                 s = rx->offs[0].end + orig;
2203             } while (CALLREGEXEC(rx, s, strend, orig, s == m,
2204                                  TARG, NULL,
2205                                  /* don't match same null twice */
2206                                  REXEC_NOT_FIRST|REXEC_IGNOREPOS));
2207             if (s != d) {
2208                 i = strend - s;
2209                 SvCUR_set(TARG, d - SvPVX_const(TARG) + i);
2210                 Move(s, d, i+1, char);          /* include the NUL */
2211             }
2212             TAINT_IF(rxtainted & 1);
2213             SPAGAIN;
2214             PUSHs(sv_2mortal(newSViv((I32)iters)));
2215         }
2216         (void)SvPOK_only_UTF8(TARG);
2217         TAINT_IF(rxtainted);
2218         if (SvSMAGICAL(TARG)) {
2219             PUTBACK;
2220             mg_set(TARG);
2221             SPAGAIN;
2222         }
2223         SvTAINT(TARG);
2224         if (doutf8)
2225             SvUTF8_on(TARG);
2226         LEAVE_SCOPE(oldsave);
2227         RETURN;
2228     }
2229
2230     if (CALLREGEXEC(rx, s, strend, orig, 0, TARG, NULL,
2231                     r_flags | REXEC_CHECKED))
2232     {
2233         if (force_on_match) {
2234             force_on_match = 0;
2235             s = SvPV_force(TARG, len);
2236             goto force_it;
2237         }
2238 #ifdef PERL_OLD_COPY_ON_WRITE
2239       have_a_cow:
2240 #endif
2241         rxtainted |= RX_MATCH_TAINTED(rx);
2242         dstr = newSVpvn(m, s-m);
2243         SAVEFREESV(dstr);
2244         if (DO_UTF8(TARG))
2245             SvUTF8_on(dstr);
2246         PL_curpm = pm;
2247         if (!c) {
2248             register PERL_CONTEXT *cx;
2249             SPAGAIN;
2250             PUSHSUBST(cx);
2251             RETURNOP(cPMOP->op_pmreplrootu.op_pmreplroot);
2252         }
2253         r_flags |= REXEC_IGNOREPOS | REXEC_NOT_FIRST;
2254         do {
2255             if (iters++ > maxiters)
2256                 DIE(aTHX_ "Substitution loop");
2257             rxtainted |= RX_MATCH_TAINTED(rx);
2258             if (RX_MATCH_COPIED(rx) && rx->subbeg != orig) {
2259                 m = s;
2260                 s = orig;
2261                 orig = rx->subbeg;
2262                 s = orig + (m - s);
2263                 strend = s + (strend - m);
2264             }
2265             m = rx->offs[0].start + orig;
2266             if (doutf8 && !SvUTF8(dstr))
2267                 sv_catpvn_utf8_upgrade(dstr, s, m - s, nsv);
2268             else
2269                 sv_catpvn(dstr, s, m-s);
2270             s = rx->offs[0].end + orig;
2271             if (clen)
2272                 sv_catpvn(dstr, c, clen);
2273             if (once)
2274                 break;
2275         } while (CALLREGEXEC(rx, s, strend, orig, s == m,
2276                              TARG, NULL, r_flags));
2277         if (doutf8 && !DO_UTF8(TARG))
2278             sv_catpvn_utf8_upgrade(dstr, s, strend - s, nsv);
2279         else
2280             sv_catpvn(dstr, s, strend - s);
2281
2282 #ifdef PERL_OLD_COPY_ON_WRITE
2283         /* The match may make the string COW. If so, brilliant, because that's
2284            just saved us one malloc, copy and free - the regexp has donated
2285            the old buffer, and we malloc an entirely new one, rather than the
2286            regexp malloc()ing a buffer and copying our original, only for
2287            us to throw it away here during the substitution.  */
2288         if (SvIsCOW(TARG)) {
2289             sv_force_normal_flags(TARG, SV_COW_DROP_PV);
2290         } else
2291 #endif
2292         {
2293             SvPV_free(TARG);
2294         }
2295         SvPV_set(TARG, SvPVX(dstr));
2296         SvCUR_set(TARG, SvCUR(dstr));
2297         SvLEN_set(TARG, SvLEN(dstr));
2298         doutf8 |= DO_UTF8(dstr);
2299         SvPV_set(dstr, NULL);
2300
2301         TAINT_IF(rxtainted & 1);
2302         SPAGAIN;
2303         PUSHs(sv_2mortal(newSViv((I32)iters)));
2304
2305         (void)SvPOK_only(TARG);
2306         if (doutf8)
2307             SvUTF8_on(TARG);
2308         TAINT_IF(rxtainted);
2309         SvSETMAGIC(TARG);
2310         SvTAINT(TARG);
2311         LEAVE_SCOPE(oldsave);
2312         RETURN;
2313     }
2314     goto ret_no;
2315
2316 nope:
2317 ret_no:
2318     SPAGAIN;
2319     PUSHs(&PL_sv_no);
2320     LEAVE_SCOPE(oldsave);
2321     RETURN;
2322 }
2323
2324 PP(pp_grepwhile)
2325 {
2326     dVAR; dSP;
2327
2328     if (SvTRUEx(POPs))
2329         PL_stack_base[PL_markstack_ptr[-1]++] = PL_stack_base[*PL_markstack_ptr];
2330     ++*PL_markstack_ptr;
2331     LEAVE;                                      /* exit inner scope */
2332
2333     /* All done yet? */
2334     if (PL_stack_base + *PL_markstack_ptr > SP) {
2335         I32 items;
2336         const I32 gimme = GIMME_V;
2337
2338         LEAVE;                                  /* exit outer scope */
2339         (void)POPMARK;                          /* pop src */
2340         items = --*PL_markstack_ptr - PL_markstack_ptr[-1];
2341         (void)POPMARK;                          /* pop dst */
2342         SP = PL_stack_base + POPMARK;           /* pop original mark */
2343         if (gimme == G_SCALAR) {
2344             if (PL_op->op_private & OPpGREP_LEX) {
2345                 SV* const sv = sv_newmortal();
2346                 sv_setiv(sv, items);
2347                 PUSHs(sv);
2348             }
2349             else {
2350                 dTARGET;
2351                 XPUSHi(items);
2352             }
2353         }
2354         else if (gimme == G_ARRAY)
2355             SP += items;
2356         RETURN;
2357     }
2358     else {
2359         SV *src;
2360
2361         ENTER;                                  /* enter inner scope */
2362         SAVEVPTR(PL_curpm);
2363
2364         src = PL_stack_base[*PL_markstack_ptr];
2365         SvTEMP_off(src);
2366         if (PL_op->op_private & OPpGREP_LEX)
2367             PAD_SVl(PL_op->op_targ) = src;
2368         else
2369             DEFSV = src;
2370
2371         RETURNOP(cLOGOP->op_other);
2372     }
2373 }
2374
2375 PP(pp_leavesub)
2376 {
2377     dVAR; dSP;
2378     SV **mark;
2379     SV **newsp;
2380     PMOP *newpm;
2381     I32 gimme;
2382     register PERL_CONTEXT *cx;
2383     SV *sv;
2384
2385     if (CxMULTICALL(&cxstack[cxstack_ix]))
2386         return 0;
2387
2388     POPBLOCK(cx,newpm);
2389     cxstack_ix++; /* temporarily protect top context */
2390
2391     TAINT_NOT;
2392     if (gimme == G_SCALAR) {
2393         MARK = newsp + 1;
2394         if (MARK <= SP) {
2395             if (cx->blk_sub.cv && CvDEPTH(cx->blk_sub.cv) > 1) {
2396                 if (SvTEMP(TOPs)) {
2397                     *MARK = SvREFCNT_inc(TOPs);
2398                     FREETMPS;
2399                     sv_2mortal(*MARK);
2400                 }
2401                 else {
2402                     sv = SvREFCNT_inc(TOPs);    /* FREETMPS could clobber it */
2403                     FREETMPS;
2404                     *MARK = sv_mortalcopy(sv);
2405                     SvREFCNT_dec(sv);
2406                 }
2407             }
2408             else
2409                 *MARK = SvTEMP(TOPs) ? TOPs : sv_mortalcopy(TOPs);
2410         }
2411         else {
2412             MEXTEND(MARK, 0);
2413             *MARK = &PL_sv_undef;
2414         }
2415         SP = MARK;
2416     }
2417     else if (gimme == G_ARRAY) {
2418         for (MARK = newsp + 1; MARK <= SP; MARK++) {
2419             if (!SvTEMP(*MARK)) {
2420                 *MARK = sv_mortalcopy(*MARK);
2421                 TAINT_NOT;      /* Each item is independent */
2422             }
2423         }
2424     }
2425     PUTBACK;
2426
2427     LEAVE;
2428     cxstack_ix--;
2429     POPSUB(cx,sv);      /* Stack values are safe: release CV and @_ ... */
2430     PL_curpm = newpm;   /* ... and pop $1 et al */
2431
2432     LEAVESUB(sv);
2433     return cx->blk_sub.retop;
2434 }
2435
2436 /* This duplicates the above code because the above code must not
2437  * get any slower by more conditions */
2438 PP(pp_leavesublv)
2439 {
2440     dVAR; dSP;
2441     SV **mark;
2442     SV **newsp;
2443     PMOP *newpm;
2444     I32 gimme;
2445     register PERL_CONTEXT *cx;
2446     SV *sv;
2447
2448     if (CxMULTICALL(&cxstack[cxstack_ix]))
2449         return 0;
2450
2451     POPBLOCK(cx,newpm);
2452     cxstack_ix++; /* temporarily protect top context */
2453
2454     TAINT_NOT;
2455
2456     if (cx->blk_sub.lval & OPpENTERSUB_INARGS) {
2457         /* We are an argument to a function or grep().
2458          * This kind of lvalueness was legal before lvalue
2459          * subroutines too, so be backward compatible:
2460          * cannot report errors.  */
2461
2462         /* Scalar context *is* possible, on the LHS of -> only,
2463          * as in f()->meth().  But this is not an lvalue. */
2464         if (gimme == G_SCALAR)
2465             goto temporise;
2466         if (gimme == G_ARRAY) {
2467             if (!CvLVALUE(cx->blk_sub.cv))
2468                 goto temporise_array;
2469             EXTEND_MORTAL(SP - newsp);
2470             for (mark = newsp + 1; mark <= SP; mark++) {
2471                 if (SvTEMP(*mark))
2472                     NOOP;
2473                 else if (SvFLAGS(*mark) & (SVs_PADTMP | SVf_READONLY))
2474                     *mark = sv_mortalcopy(*mark);
2475                 else {
2476                     /* Can be a localized value subject to deletion. */
2477                     PL_tmps_stack[++PL_tmps_ix] = *mark;
2478                     SvREFCNT_inc_void(*mark);
2479                 }
2480             }
2481         }
2482     }
2483     else if (cx->blk_sub.lval) {     /* Leave it as it is if we can. */
2484         /* Here we go for robustness, not for speed, so we change all
2485          * the refcounts so the caller gets a live guy. Cannot set
2486          * TEMP, so sv_2mortal is out of question. */
2487         if (!CvLVALUE(cx->blk_sub.cv)) {
2488             LEAVE;
2489             cxstack_ix--;
2490             POPSUB(cx,sv);
2491             PL_curpm = newpm;
2492             LEAVESUB(sv);
2493             DIE(aTHX_ "Can't modify non-lvalue subroutine call");
2494         }
2495         if (gimme == G_SCALAR) {
2496             MARK = newsp + 1;
2497             EXTEND_MORTAL(1);
2498             if (MARK == SP) {
2499                 /* Temporaries are bad unless they happen to be elements
2500                  * of a tied hash or array */
2501                 if (SvFLAGS(TOPs) & (SVs_TEMP | SVs_PADTMP | SVf_READONLY) &&
2502                     !(SvRMAGICAL(TOPs) && mg_find(TOPs, PERL_MAGIC_tiedelem))) {
2503                     LEAVE;
2504                     cxstack_ix--;
2505                     POPSUB(cx,sv);
2506                     PL_curpm = newpm;
2507                     LEAVESUB(sv);
2508                     DIE(aTHX_ "Can't return %s from lvalue subroutine",
2509                         SvREADONLY(TOPs) ? (TOPs == &PL_sv_undef) ? "undef"
2510                         : "a readonly value" : "a temporary");
2511                 }
2512                 else {                  /* Can be a localized value
2513                                          * subject to deletion. */
2514                     PL_tmps_stack[++PL_tmps_ix] = *mark;
2515                     SvREFCNT_inc_void(*mark);
2516                 }
2517             }
2518             else {                      /* Should not happen? */
2519                 LEAVE;
2520                 cxstack_ix--;
2521                 POPSUB(cx,sv);
2522                 PL_curpm = newpm;
2523                 LEAVESUB(sv);
2524                 DIE(aTHX_ "%s returned from lvalue subroutine in scalar context",
2525                     (MARK > SP ? "Empty array" : "Array"));
2526             }
2527             SP = MARK;
2528         }
2529         else if (gimme == G_ARRAY) {
2530             EXTEND_MORTAL(SP - newsp);
2531             for (mark = newsp + 1; mark <= SP; mark++) {
2532                 if (*mark != &PL_sv_undef
2533                     && SvFLAGS(*mark) & (SVs_TEMP | SVs_PADTMP | SVf_READONLY)) {
2534                     /* Might be flattened array after $#array =  */
2535                     PUTBACK;
2536                     LEAVE;
2537                     cxstack_ix--;
2538                     POPSUB(cx,sv);
2539                     PL_curpm = newpm;
2540                     LEAVESUB(sv);
2541                     DIE(aTHX_ "Can't return a %s from lvalue subroutine",
2542                         SvREADONLY(TOPs) ? "readonly value" : "temporary");
2543                 }
2544                 else {
2545                     /* Can be a localized value subject to deletion. */
2546                     PL_tmps_stack[++PL_tmps_ix] = *mark;
2547                     SvREFCNT_inc_void(*mark);
2548                 }
2549             }
2550         }
2551     }
2552     else {
2553         if (gimme == G_SCALAR) {
2554           temporise:
2555             MARK = newsp + 1;
2556             if (MARK <= SP) {
2557                 if (cx->blk_sub.cv && CvDEPTH(cx->blk_sub.cv) > 1) {
2558                     if (SvTEMP(TOPs)) {
2559                         *MARK = SvREFCNT_inc(TOPs);
2560                         FREETMPS;
2561                         sv_2mortal(*MARK);
2562                     }
2563                     else {
2564                         sv = SvREFCNT_inc(TOPs); /* FREETMPS could clobber it */
2565                         FREETMPS;
2566                         *MARK = sv_mortalcopy(sv);
2567                         SvREFCNT_dec(sv);
2568                     }
2569                 }
2570                 else
2571                     *MARK = SvTEMP(TOPs) ? TOPs : sv_mortalcopy(TOPs);
2572             }
2573             else {
2574                 MEXTEND(MARK, 0);
2575                 *MARK = &PL_sv_undef;
2576             }
2577             SP = MARK;
2578         }
2579         else if (gimme == G_ARRAY) {
2580           temporise_array:
2581             for (MARK = newsp + 1; MARK <= SP; MARK++) {
2582                 if (!SvTEMP(*MARK)) {
2583                     *MARK = sv_mortalcopy(*MARK);
2584                     TAINT_NOT;  /* Each item is independent */
2585                 }
2586             }
2587         }
2588     }
2589     PUTBACK;
2590
2591     LEAVE;
2592     cxstack_ix--;
2593     POPSUB(cx,sv);      /* Stack values are safe: release CV and @_ ... */
2594     PL_curpm = newpm;   /* ... and pop $1 et al */
2595
2596     LEAVESUB(sv);
2597     return cx->blk_sub.retop;
2598 }
2599
2600 PP(pp_entersub)
2601 {
2602     dVAR; dSP; dPOPss;
2603     GV *gv;
2604     register CV *cv;
2605     register PERL_CONTEXT *cx;
2606     I32 gimme;
2607     const bool hasargs = (PL_op->op_flags & OPf_STACKED) != 0;
2608
2609     if (!sv)
2610         DIE(aTHX_ "Not a CODE reference");
2611     switch (SvTYPE(sv)) {
2612         /* This is overwhelming the most common case:  */
2613     case SVt_PVGV:
2614         if (!(cv = GvCVu((GV*)sv))) {
2615             HV *stash;
2616             cv = sv_2cv(sv, &stash, &gv, 0);
2617         }
2618         if (!cv) {
2619             ENTER;
2620             SAVETMPS;
2621             goto try_autoload;
2622         }
2623         break;
2624     default:
2625         if (!SvROK(sv)) {
2626             const char *sym;
2627             STRLEN len;
2628             if (sv == &PL_sv_yes) {             /* unfound import, ignore */
2629                 if (hasargs)
2630                     SP = PL_stack_base + POPMARK;
2631                 RETURN;
2632             }
2633             if (SvGMAGICAL(sv)) {
2634                 mg_get(sv);
2635                 if (SvROK(sv))
2636                     goto got_rv;
2637                 if (SvPOKp(sv)) {
2638                     sym = SvPVX_const(sv);
2639                     len = SvCUR(sv);
2640                 } else {
2641                     sym = NULL;
2642                     len = 0;
2643                 }
2644             }
2645             else {
2646                 sym = SvPV_const(sv, len);
2647             }
2648             if (!sym)
2649                 DIE(aTHX_ PL_no_usym, "a subroutine");
2650             if (PL_op->op_private & HINT_STRICT_REFS)
2651                 DIE(aTHX_ PL_no_symref, sym, "a subroutine");
2652             cv = get_cvn_flags(sym, len, GV_ADD|SvUTF8(sv));
2653             break;
2654         }
2655   got_rv:
2656         {
2657             SV * const * sp = &sv;              /* Used in tryAMAGICunDEREF macro. */
2658             tryAMAGICunDEREF(to_cv);
2659         }
2660         cv = (CV*)SvRV(sv);
2661         if (SvTYPE(cv) == SVt_PVCV)
2662             break;
2663         /* FALL THROUGH */
2664     case SVt_PVHV:
2665     case SVt_PVAV:
2666         DIE(aTHX_ "Not a CODE reference");
2667         /* This is the second most common case:  */
2668     case SVt_PVCV:
2669         cv = (CV*)sv;
2670         break;
2671     }
2672
2673     ENTER;
2674     SAVETMPS;
2675
2676   retry:
2677     if (!CvROOT(cv) && !CvXSUB(cv)) {
2678         GV* autogv;
2679         SV* sub_name;
2680
2681         /* anonymous or undef'd function leaves us no recourse */
2682         if (CvANON(cv) || !(gv = CvGV(cv)))
2683             DIE(aTHX_ "Undefined subroutine called");
2684
2685         /* autoloaded stub? */
2686         if (cv != GvCV(gv)) {
2687             cv = GvCV(gv);
2688         }
2689         /* should call AUTOLOAD now? */
2690         else {
2691 try_autoload:
2692             if ((autogv = gv_autoload4(GvSTASH(gv), GvNAME(gv), GvNAMELEN(gv),
2693                                    FALSE)))
2694             {
2695                 cv = GvCV(autogv);
2696             }
2697             /* sorry */
2698             else {
2699                 sub_name = sv_newmortal();
2700                 gv_efullname3(sub_name, gv, NULL);
2701                 DIE(aTHX_ "Undefined subroutine &%"SVf" called", SVfARG(sub_name));
2702             }
2703         }
2704         if (!cv)
2705             DIE(aTHX_ "Not a CODE reference");
2706         goto retry;
2707     }
2708
2709     gimme = GIMME_V;
2710     if ((PL_op->op_private & OPpENTERSUB_DB) && GvCV(PL_DBsub) && !CvNODEBUG(cv)) {
2711          Perl_get_db_sub(aTHX_ &sv, cv);
2712          if (CvISXSUB(cv))
2713              PL_curcopdb = PL_curcop;
2714          cv = GvCV(PL_DBsub);
2715
2716         if (!cv || (!CvXSUB(cv) && !CvSTART(cv)))
2717             DIE(aTHX_ "No DB::sub routine defined");
2718     }
2719
2720     if (!(CvISXSUB(cv))) {
2721         /* This path taken at least 75% of the time   */
2722         dMARK;
2723         register I32 items = SP - MARK;
2724         AV* const padlist = CvPADLIST(cv);
2725         PUSHBLOCK(cx, CXt_SUB, MARK);
2726         PUSHSUB(cx);
2727         cx->blk_sub.retop = PL_op->op_next;
2728         CvDEPTH(cv)++;
2729         /* XXX This would be a natural place to set C<PL_compcv = cv> so
2730          * that eval'' ops within this sub know the correct lexical space.
2731          * Owing the speed considerations, we choose instead to search for
2732          * the cv using find_runcv() when calling doeval().
2733          */
2734         if (CvDEPTH(cv) >= 2) {
2735             PERL_STACK_OVERFLOW_CHECK();
2736             pad_push(padlist, CvDEPTH(cv));
2737         }
2738         SAVECOMPPAD();
2739         PAD_SET_CUR_NOSAVE(padlist, CvDEPTH(cv));
2740         if (hasargs) {
2741             AV* const av = (AV*)PAD_SVl(0);
2742             if (AvREAL(av)) {
2743                 /* @_ is normally not REAL--this should only ever
2744                  * happen when DB::sub() calls things that modify @_ */
2745                 av_clear(av);
2746                 AvREAL_off(av);
2747                 AvREIFY_on(av);
2748             }
2749             cx->blk_sub.savearray = GvAV(PL_defgv);
2750             GvAV(PL_defgv) = (AV*)SvREFCNT_inc_simple(av);
2751             CX_CURPAD_SAVE(cx->blk_sub);
2752             cx->blk_sub.argarray = av;
2753             ++MARK;
2754
2755             if (items > AvMAX(av) + 1) {
2756                 SV **ary = AvALLOC(av);
2757                 if (AvARRAY(av) != ary) {
2758                     AvMAX(av) += AvARRAY(av) - AvALLOC(av);
2759                     AvARRAY(av) = ary;
2760                 }
2761                 if (items > AvMAX(av) + 1) {
2762                     AvMAX(av) = items - 1;
2763                     Renew(ary,items,SV*);
2764                     AvALLOC(av) = ary;
2765                     AvARRAY(av) = ary;
2766                 }
2767             }
2768             Copy(MARK,AvARRAY(av),items,SV*);
2769             AvFILLp(av) = items - 1;
2770
2771             while (items--) {
2772                 if (*MARK)
2773                     SvTEMP_off(*MARK);
2774                 MARK++;
2775             }
2776         }
2777         /* warning must come *after* we fully set up the context
2778          * stuff so that __WARN__ handlers can safely dounwind()
2779          * if they want to
2780          */
2781         if (CvDEPTH(cv) == 100 && ckWARN(WARN_RECURSION)
2782             && !(PERLDB_SUB && cv == GvCV(PL_DBsub)))
2783             sub_crush_depth(cv);
2784 #if 0
2785         DEBUG_S(PerlIO_printf(Perl_debug_log,
2786                               "%p entersub returning %p\n", (void*)thr, (void*)CvSTART(cv)));
2787 #endif
2788         RETURNOP(CvSTART(cv));
2789     }
2790     else {
2791         I32 markix = TOPMARK;
2792
2793         PUTBACK;
2794
2795         if (!hasargs) {
2796             /* Need to copy @_ to stack. Alternative may be to
2797              * switch stack to @_, and copy return values
2798              * back. This would allow popping @_ in XSUB, e.g.. XXXX */
2799             AV * const av = GvAV(PL_defgv);
2800             const I32 items = AvFILLp(av) + 1;   /* @_ is not tieable */
2801
2802             if (items) {
2803                 /* Mark is at the end of the stack. */
2804                 EXTEND(SP, items);
2805                 Copy(AvARRAY(av), SP + 1, items, SV*);
2806                 SP += items;
2807                 PUTBACK ;
2808             }
2809         }
2810         /* We assume first XSUB in &DB::sub is the called one. */
2811         if (PL_curcopdb) {
2812             SAVEVPTR(PL_curcop);
2813             PL_curcop = PL_curcopdb;
2814             PL_curcopdb = NULL;
2815         }
2816         /* Do we need to open block here? XXXX */
2817         if (CvXSUB(cv)) /* XXX this is supposed to be true */
2818             (void)(*CvXSUB(cv))(aTHX_ cv);
2819
2820         /* Enforce some sanity in scalar context. */
2821         if (gimme == G_SCALAR && ++markix != PL_stack_sp - PL_stack_base ) {
2822             if (markix > PL_stack_sp - PL_stack_base)
2823                 *(PL_stack_base + markix) = &PL_sv_undef;
2824             else
2825                 *(PL_stack_base + markix) = *PL_stack_sp;
2826             PL_stack_sp = PL_stack_base + markix;
2827         }
2828         LEAVE;
2829         return NORMAL;
2830     }
2831 }
2832
2833 void
2834 Perl_sub_crush_depth(pTHX_ CV *cv)
2835 {
2836     if (CvANON(cv))
2837         Perl_warner(aTHX_ packWARN(WARN_RECURSION), "Deep recursion on anonymous subroutine");
2838     else {
2839         SV* const tmpstr = sv_newmortal();
2840         gv_efullname3(tmpstr, CvGV(cv), NULL);
2841         Perl_warner(aTHX_ packWARN(WARN_RECURSION), "Deep recursion on subroutine \"%"SVf"\"",
2842                     SVfARG(tmpstr));
2843     }
2844 }
2845
2846 PP(pp_aelem)
2847 {
2848     dVAR; dSP;
2849     SV** svp;
2850     SV* const elemsv = POPs;
2851     IV elem = SvIV(elemsv);
2852     AV* const av = (AV*)POPs;
2853     const U32 lval = PL_op->op_flags & OPf_MOD || LVRET;
2854     const U32 defer = (PL_op->op_private & OPpLVAL_DEFER) && (elem > av_len(av));
2855     SV *sv;
2856
2857     if (SvROK(elemsv) && !SvGAMAGIC(elemsv) && ckWARN(WARN_MISC))
2858         Perl_warner(aTHX_ packWARN(WARN_MISC),
2859                     "Use of reference \"%"SVf"\" as array index",
2860                     SVfARG(elemsv));
2861     if (elem > 0)
2862         elem -= CopARYBASE_get(PL_curcop);
2863     if (SvTYPE(av) != SVt_PVAV)
2864         RETPUSHUNDEF;
2865     svp = av_fetch(av, elem, lval && !defer);
2866     if (lval) {
2867 #ifdef PERL_MALLOC_WRAP
2868          if (SvUOK(elemsv)) {
2869               const UV uv = SvUV(elemsv);
2870               elem = uv > IV_MAX ? IV_MAX : uv;
2871          }
2872          else if (SvNOK(elemsv))
2873               elem = (IV)SvNV(elemsv);
2874          if (elem > 0) {
2875               static const char oom_array_extend[] =
2876                 "Out of memory during array extend"; /* Duplicated in av.c */
2877               MEM_WRAP_CHECK_1(elem,SV*,oom_array_extend);
2878          }
2879 #endif
2880         if (!svp || *svp == &PL_sv_undef) {
2881             SV* lv;
2882             if (!defer)
2883                 DIE(aTHX_ PL_no_aelem, elem);
2884             lv = sv_newmortal();
2885             sv_upgrade(lv, SVt_PVLV);
2886             LvTYPE(lv) = 'y';
2887             sv_magic(lv, NULL, PERL_MAGIC_defelem, NULL, 0);
2888             LvTARG(lv) = SvREFCNT_inc_simple(av);
2889             LvTARGOFF(lv) = elem;
2890             LvTARGLEN(lv) = 1;
2891             PUSHs(lv);
2892             RETURN;
2893         }
2894         if (PL_op->op_private & OPpLVAL_INTRO)
2895             save_aelem(av, elem, svp);
2896         else if (PL_op->op_private & OPpDEREF)
2897             vivify_ref(*svp, PL_op->op_private & OPpDEREF);
2898     }
2899     sv = (svp ? *svp : &PL_sv_undef);
2900     if (!lval && SvGMAGICAL(sv))        /* see note in pp_helem() */
2901         sv = sv_mortalcopy(sv);
2902     PUSHs(sv);
2903     RETURN;
2904 }
2905
2906 void
2907 Perl_vivify_ref(pTHX_ SV *sv, U32 to_what)
2908 {
2909     SvGETMAGIC(sv);
2910     if (!SvOK(sv)) {
2911         if (SvREADONLY(sv))
2912             Perl_croak(aTHX_ PL_no_modify);
2913         if (SvTYPE(sv) < SVt_RV)
2914             sv_upgrade(sv, SVt_RV);
2915         else if (SvTYPE(sv) >= SVt_PV) {
2916             SvPV_free(sv);
2917             SvLEN_set(sv, 0);
2918             SvCUR_set(sv, 0);
2919         }
2920         switch (to_what) {
2921         case OPpDEREF_SV:
2922             SvRV_set(sv, newSV(0));
2923             break;
2924         case OPpDEREF_AV:
2925             SvRV_set(sv, (SV*)newAV());
2926             break;
2927         case OPpDEREF_HV:
2928             SvRV_set(sv, (SV*)newHV());
2929             break;
2930         }
2931         SvROK_on(sv);
2932         SvSETMAGIC(sv);
2933     }
2934 }
2935
2936 PP(pp_method)
2937 {
2938     dVAR; dSP;
2939     SV* const sv = TOPs;
2940
2941     if (SvROK(sv)) {
2942         SV* const rsv = SvRV(sv);
2943         if (SvTYPE(rsv) == SVt_PVCV) {
2944             SETs(rsv);
2945             RETURN;
2946         }
2947     }
2948
2949     SETs(method_common(sv, NULL));
2950     RETURN;
2951 }
2952
2953 PP(pp_method_named)
2954 {
2955     dVAR; dSP;
2956     SV* const sv = cSVOP_sv;
2957     U32 hash = SvSHARED_HASH(sv);
2958
2959     XPUSHs(method_common(sv, &hash));
2960     RETURN;
2961 }
2962
2963 STATIC SV *
2964 S_method_common(pTHX_ SV* meth, U32* hashp)
2965 {
2966     dVAR;
2967     SV* ob;
2968     GV* gv;
2969     HV* stash;
2970     STRLEN namelen;
2971     const char* packname = NULL;
2972     SV *packsv = NULL;
2973     STRLEN packlen;
2974     const char * const name = SvPV_const(meth, namelen);
2975     SV * const sv = *(PL_stack_base + TOPMARK + 1);
2976
2977     if (!sv)
2978         Perl_croak(aTHX_ "Can't call method \"%s\" on an undefined value", name);
2979
2980     SvGETMAGIC(sv);
2981     if (SvROK(sv))
2982         ob = (SV*)SvRV(sv);
2983     else {
2984         GV* iogv;
2985
2986         /* this isn't a reference */
2987         if(SvOK(sv) && (packname = SvPV_const(sv, packlen))) {
2988           const HE* const he = hv_fetch_ent(PL_stashcache, sv, 0, 0);
2989           if (he) {
2990             stash = INT2PTR(HV*,SvIV(HeVAL(he)));
2991             goto fetch;
2992           }
2993         }
2994
2995         if (!SvOK(sv) ||
2996             !(packname) ||
2997             !(iogv = gv_fetchsv(sv, 0, SVt_PVIO)) ||
2998             !(ob=(SV*)GvIO(iogv)))
2999         {
3000             /* this isn't the name of a filehandle either */
3001             if (!packname ||
3002                 ((UTF8_IS_START(*packname) && DO_UTF8(sv))
3003                     ? !isIDFIRST_utf8((U8*)packname)
3004                     : !isIDFIRST(*packname)
3005                 ))
3006             {
3007                 Perl_croak(aTHX_ "Can't call method \"%s\" %s", name,
3008                            SvOK(sv) ? "without a package or object reference"
3009                                     : "on an undefined value");
3010             }
3011             /* assume it's a package name */
3012             stash = gv_stashpvn(packname, packlen, 0);
3013             if (!stash)
3014                 packsv = sv;
3015             else {
3016                 SV* const ref = newSViv(PTR2IV(stash));
3017                 hv_store(PL_stashcache, packname, packlen, ref, 0);
3018             }
3019             goto fetch;
3020         }
3021         /* it _is_ a filehandle name -- replace with a reference */
3022         *(PL_stack_base + TOPMARK + 1) = sv_2mortal(newRV((SV*)iogv));
3023     }
3024
3025     /* if we got here, ob should be a reference or a glob */
3026     if (!ob || !(SvOBJECT(ob)
3027                  || (SvTYPE(ob) == SVt_PVGV && (ob = (SV*)GvIO((GV*)ob))
3028                      && SvOBJECT(ob))))
3029     {
3030         Perl_croak(aTHX_ "Can't call method \"%s\" on unblessed reference",
3031                    (SvSCREAM(meth) && strEQ(name,"isa")) ? "DOES" :
3032                    name);
3033     }
3034
3035     stash = SvSTASH(ob);
3036
3037   fetch:
3038     /* NOTE: stash may be null, hope hv_fetch_ent and
3039        gv_fetchmethod can cope (it seems they can) */
3040
3041     /* shortcut for simple names */
3042     if (hashp) {
3043         const HE* const he = hv_fetch_ent(stash, meth, 0, *hashp);
3044         if (he) {
3045             gv = (GV*)HeVAL(he);
3046             if (isGV(gv) && GvCV(gv) &&
3047                 (!GvCVGEN(gv) || GvCVGEN(gv)
3048                   == (PL_sub_generation + HvMROMETA(stash)->cache_gen)))
3049                 return (SV*)GvCV(gv);
3050         }
3051     }
3052
3053     gv = gv_fetchmethod(stash ? stash : (HV*)packsv, name);
3054
3055     if (!gv) {
3056         /* This code tries to figure out just what went wrong with
3057            gv_fetchmethod.  It therefore needs to duplicate a lot of
3058            the internals of that function.  We can't move it inside
3059            Perl_gv_fetchmethod_autoload(), however, since that would
3060            cause UNIVERSAL->can("NoSuchPackage::foo") to croak, and we
3061            don't want that.
3062         */
3063         const char* leaf = name;
3064         const char* sep = NULL;
3065         const char* p;
3066
3067         for (p = name; *p; p++) {
3068             if (*p == '\'')
3069                 sep = p, leaf = p + 1;
3070             else if (*p == ':' && *(p + 1) == ':')
3071                 sep = p, leaf = p + 2;
3072         }
3073         if (!sep || ((sep - name) == 5 && strnEQ(name, "SUPER", 5))) {
3074             /* the method name is unqualified or starts with SUPER:: */
3075             bool need_strlen = 1;
3076             if (sep) {
3077                 packname = CopSTASHPV(PL_curcop);
3078             }
3079             else if (stash) {
3080                 HEK * const packhek = HvNAME_HEK(stash);
3081                 if (packhek) {
3082                     packname = HEK_KEY(packhek);
3083                     packlen = HEK_LEN(packhek);
3084                     need_strlen = 0;
3085                 } else {
3086                     goto croak;
3087                 }
3088             }
3089
3090             if (!packname) {
3091             croak:
3092                 Perl_croak(aTHX_
3093                            "Can't use anonymous symbol table for method lookup");
3094             }
3095             else if (need_strlen)
3096                 packlen = strlen(packname);
3097
3098         }
3099         else {
3100             /* the method name is qualified */
3101             packname = name;
3102             packlen = sep - name;
3103         }
3104
3105         /* we're relying on gv_fetchmethod not autovivifying the stash */
3106         if (gv_stashpvn(packname, packlen, 0)) {
3107             Perl_croak(aTHX_
3108                        "Can't locate object method \"%s\" via package \"%.*s\"",
3109                        leaf, (int)packlen, packname);
3110         }
3111         else {
3112             Perl_croak(aTHX_
3113                        "Can't locate object method \"%s\" via package \"%.*s\""
3114                        " (perhaps you forgot to load \"%.*s\"?)",
3115                        leaf, (int)packlen, packname, (int)packlen, packname);
3116         }
3117     }
3118     return isGV(gv) ? (SV*)GvCV(gv) : (SV*)gv;
3119 }
3120
3121 /*
3122  * Local variables:
3123  * c-indentation-style: bsd
3124  * c-basic-offset: 4
3125  * indent-tabs-mode: t
3126  * End:
3127  *
3128  * ex: set ts=8 sts=4 sw=4 noet:
3129  */