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