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     else if (PL_op->op_private & OPpASSIGN_STATE) {
 131         if (SvPADSTALE(right))
 132             SvPADSTALE_off(right);
 133         else {
 134             (void)POPs;
 135             PUSHs(right);
 136             RETURN; /* ignore assignment */
 137         }
 138     }
 139     if (PL_tainting && PL_tainted && !SvTAINTED(left))
 140         TAINT_NOT;
 141     if (PL_op->op_private & OPpASSIGN_CV_TO_GV) {
 142         SV * const cv = SvRV(left);
 143         const U32 cv_type = SvTYPE(cv);
 144         const U32 gv_type = SvTYPE(right);
 145         const bool got_coderef = cv_type == SVt_PVCV || cv_type == SVt_PVFM;
 146
 147         if (!got_coderef) {
 148             assert(SvROK(cv));
 149         }
 150
 151         /* Can do the optimisation if right (LVALUE) is not a typeglob,
 152            left (RVALUE) is a reference to something, and we're in void
 153            context. */
 154         if (!got_coderef && gv_type != SVt_PVGV && GIMME_V == G_VOID) {
 155             /* Is the target symbol table currently empty?  */
 156             GV * const gv = gv_fetchsv(right, GV_NOINIT, SVt_PVGV);
 157             if (SvTYPE(gv) != SVt_PVGV && !SvOK(gv)) {
 158                 /* Good. Create a new proxy constant subroutine in the target.
 159                    The gv becomes a(nother) reference to the constant.  */
 160                 SV *const value = SvRV(cv);
 161
 162                 SvUPGRADE((SV *)gv, SVt_RV);
 163                 SvPCS_IMPORTED_on(gv);
 164                 SvRV_set(gv, value);
 165                 SvREFCNT_inc_simple_void(value);
 166                 SETs(right);
 167                 RETURN;
 168             }
 169         }
 170
 171         /* Need to fix things up.  */
 172         if (gv_type != SVt_PVGV) {
 173             /* Need to fix GV.  */
 174             right = (SV*)gv_fetchsv(right, GV_ADD, SVt_PVGV);
 175         }
 176
 177         if (!got_coderef) {
 178             /* We've been returned a constant rather than a full subroutine,
 179                but they expect a subroutine reference to apply.  */
 180             ENTER;
 181             SvREFCNT_inc_void(SvRV(cv));
 182             /* newCONSTSUB takes a reference count on the passed in SV
 183                from us.  We set the name to NULL, otherwise we get into
 184                all sorts of fun as the reference to our new sub is
 185                donated to the GV that we're about to assign to.
 186             */
 187             SvRV_set(left, (SV *)newCONSTSUB(GvSTASH(right), NULL,
 188                                                  SvRV(cv)));
 189             SvREFCNT_dec(cv);
 190             LEAVE;
 191         }
 192
 193         if (strEQ(GvNAME(right),"isa")) {
 194             GvCVGEN(right) = 0;
 195             ++PL_sub_generation;
 196         }
 197     }
 198     SvSetMagicSV(right, left);
 199     SETs(right);
 200     RETURN;
 201 }
 202
 203 PP(pp_cond_expr)
 204 {
 205     dVAR; dSP;
 206     if (SvTRUEx(POPs))
 207         RETURNOP(cLOGOP->op_other);
 208     else
 209         RETURNOP(cLOGOP->op_next);
 210 }
 211
 212 PP(pp_unstack)
 213 {
 214     dVAR;
 215     I32 oldsave;
 216     TAINT_NOT;          /* Each statement is presumed innocent */
 217     PL_stack_sp = PL_stack_base + cxstack[cxstack_ix].blk_oldsp;
 218     FREETMPS;
 219     oldsave = PL_scopestack[PL_scopestack_ix - 1];
 220     LEAVE_SCOPE(oldsave);
 221     return NORMAL;
 222 }
 223
 224 PP(pp_concat)
 225 {
 226   dVAR; dSP; dATARGET; tryAMAGICbin(concat,opASSIGN);
 227   {
 228     dPOPTOPssrl;
 229     bool lbyte;
 230     STRLEN rlen;
 231     const char *rpv = NULL;
 232     bool rbyte = FALSE;
 233     bool rcopied = FALSE;
 234
 235     if (TARG == right && right != left) {
 236         /* mg_get(right) may happen here ... */
 237         rpv = SvPV_const(right, rlen);
 238         rbyte = !DO_UTF8(right);
 239         right = sv_2mortal(newSVpvn(rpv, rlen));
 240         rpv = SvPV_const(right, rlen);  /* no point setting UTF-8 here */
 241         rcopied = TRUE;
 242     }
 243
 244     if (TARG != left) {
 245         STRLEN llen;
 246         const char* const lpv = SvPV_const(left, llen); /* mg_get(left) may happen here */
 247         lbyte = !DO_UTF8(left);
 248         sv_setpvn(TARG, lpv, llen);
 249         if (!lbyte)
 250             SvUTF8_on(TARG);
 251         else
 252             SvUTF8_off(TARG);
 253     }
 254     else { /* TARG == left */
 255         STRLEN llen;
 256         SvGETMAGIC(left);               /* or mg_get(left) may happen here */
 257         if (!SvOK(TARG)) {
 258             if (left == right && ckWARN(WARN_UNINITIALIZED))
 259                 report_uninit(right);
 260             sv_setpvn(left, "", 0);
 261         }
 262         (void)SvPV_nomg_const(left, llen);    /* Needed to set UTF8 flag */
 263         lbyte = !DO_UTF8(left);
 264         if (IN_BYTES)
 265             SvUTF8_off(TARG);
 266     }
 267
 268     /* or mg_get(right) may happen here */
 269     if (!rcopied) {
 270         rpv = SvPV_const(right, rlen);
 271         rbyte = !DO_UTF8(right);
 272     }
 273     if (lbyte != rbyte) {
 274         if (lbyte)
 275             sv_utf8_upgrade_nomg(TARG);
 276         else {
 277             if (!rcopied)
 278                 right = sv_2mortal(newSVpvn(rpv, rlen));
 279             sv_utf8_upgrade_nomg(right);
 280             rpv = SvPV_const(right, rlen);
 281         }
 282     }
 283     sv_catpvn_nomg(TARG, rpv, rlen);
 284
 285     SETTARG;
 286     RETURN;
 287   }
 288 }
 289
 290 PP(pp_padsv)
 291 {
 292     dVAR; dSP; dTARGET;
 293     XPUSHs(TARG);
 294     if (PL_op->op_flags & OPf_MOD) {
 295         if (PL_op->op_private & OPpLVAL_INTRO)
 296             if (!(PL_op->op_private & OPpPAD_STATE))
 297                 SAVECLEARSV(PAD_SVl(PL_op->op_targ));
 298         if (PL_op->op_private & OPpDEREF) {
 299             PUTBACK;
 300             vivify_ref(PAD_SVl(PL_op->op_targ), PL_op->op_private & OPpDEREF);
 301             SPAGAIN;
 302         }
 303     }
 304     RETURN;
 305 }
 306
 307 PP(pp_readline)
 308 {
 309     dVAR;
 310     tryAMAGICunTARGET(iter, 0);
 311     PL_last_in_gv = (GV*)(*PL_stack_sp--);
 312     if (SvTYPE(PL_last_in_gv) != SVt_PVGV) {
 313         if (SvROK(PL_last_in_gv) && SvTYPE(SvRV(PL_last_in_gv)) == SVt_PVGV)
 314             PL_last_in_gv = (GV*)SvRV(PL_last_in_gv);
 315         else {
 316             dSP;
 317             XPUSHs((SV*)PL_last_in_gv);
 318             PUTBACK;
 319             pp_rv2gv();
 320             PL_last_in_gv = (GV*)(*PL_stack_sp--);
 321         }
 322     }
 323     return do_readline();
 324 }
 325
 326 PP(pp_eq)
 327 {
 328     dVAR; dSP; tryAMAGICbinSET(eq,0);
 329 #ifndef NV_PRESERVES_UV
 330     if (SvROK(TOPs) && !SvAMAGIC(TOPs) && SvROK(TOPm1s) && !SvAMAGIC(TOPm1s)) {
 331         SP--;
 332         SETs(boolSV(SvRV(TOPs) == SvRV(TOPp1s)));
 333         RETURN;
 334     }
 335 #endif
 336 #ifdef PERL_PRESERVE_IVUV
 337     SvIV_please(TOPs);
 338     if (SvIOK(TOPs)) {
 339         /* Unless the left argument is integer in range we are going
 340            to have to use NV maths. Hence only attempt to coerce the
 341            right argument if we know the left is integer.  */
 342       SvIV_please(TOPm1s);
 343         if (SvIOK(TOPm1s)) {
 344             const bool auvok = SvUOK(TOPm1s);
 345             const bool buvok = SvUOK(TOPs);
 346
 347             if (auvok == buvok) { /* ## IV == IV or UV == UV ## */
 348                 /* Casting IV to UV before comparison isn't going to matter
 349                    on 2s complement. On 1s complement or sign&magnitude
 350                    (if we have any of them) it could to make negative zero
 351                    differ from normal zero. As I understand it. (Need to
 352                    check - is negative zero implementation defined behaviour
 353                    anyway?). NWC  */
 354                 const UV buv = SvUVX(POPs);
 355                 const UV auv = SvUVX(TOPs);
 356
 357                 SETs(boolSV(auv == buv));
 358                 RETURN;
 359             }
 360             {                   /* ## Mixed IV,UV ## */
 361                 SV *ivp, *uvp;
 362                 IV iv;
 363
 364                 /* == is commutative so doesn't matter which is left or right */
 365                 if (auvok) {
 366                     /* top of stack (b) is the iv */
 367                     ivp = *SP;
 368                     uvp = *--SP;
 369                 } else {
 370                     uvp = *SP;
 371                     ivp = *--SP;
 372                 }
 373                 iv = SvIVX(ivp);
 374                 if (iv < 0)
 375                     /* As uv is a UV, it's >0, so it cannot be == */
 376                     SETs(&PL_sv_no);
 377                 else
 378                     /* we know iv is >= 0 */
 379                     SETs(boolSV((UV)iv == SvUVX(uvp)));
 380                 RETURN;
 381             }
 382         }
 383     }
 384 #endif
 385     {
 386 #if defined(NAN_COMPARE_BROKEN) && defined(Perl_isnan)
 387       dPOPTOPnnrl;
 388       if (Perl_isnan(left) || Perl_isnan(right))
 389           RETSETNO;
 390       SETs(boolSV(left == right));
 391 #else
 392       dPOPnv;
 393       SETs(boolSV(TOPn == value));
 394 #endif
 395       RETURN;
 396     }
 397 }
 398
 399 PP(pp_preinc)
 400 {
 401     dVAR; dSP;
 402     if (SvTYPE(TOPs) >= SVt_PVGV && SvTYPE(TOPs) != SVt_PVLV)
 403         DIE(aTHX_ PL_no_modify);
 404     if (!SvREADONLY(TOPs) && SvIOK_notUV(TOPs) && !SvNOK(TOPs) && !SvPOK(TOPs)
 405         && SvIVX(TOPs) != IV_MAX)
 406     {
 407         SvIV_set(TOPs, SvIVX(TOPs) + 1);
 408         SvFLAGS(TOPs) &= ~(SVp_NOK|SVp_POK);
 409     }
 410     else /* Do all the PERL_PRESERVE_IVUV conditionals in sv_inc */
 411         sv_inc(TOPs);
 412     SvSETMAGIC(TOPs);
 413     return NORMAL;
 414 }
 415
 416 PP(pp_or)
 417 {
 418     dVAR; dSP;
 419     if (SvTRUE(TOPs))
 420         RETURN;
 421     else {
 422         if (PL_op->op_type == OP_OR)
 423             --SP;
 424         RETURNOP(cLOGOP->op_other);
 425     }
 426 }
 427
 428 PP(pp_defined)
 429 {
 430     dVAR; dSP;
 431     register SV* sv;
 432     bool defined;
 433     const int op_type = PL_op->op_type;
 434     const bool is_dor = (op_type == OP_DOR || op_type == OP_DORASSIGN);
 435
 436     if (is_dor) {
 437         sv = TOPs;
 438         if (!sv || !SvANY(sv)) {
 439             if (op_type == OP_DOR)
 440                 --SP;
 441             RETURNOP(cLOGOP->op_other);
 442         }
 443     } else if (op_type == OP_DEFINED) {
 444         sv = POPs;
 445         if (!sv || !SvANY(sv))
 446             RETPUSHNO;
 447     } else
 448         DIE(aTHX_ "panic:  Invalid op (%s) in pp_defined()", OP_NAME(PL_op));
 449
 450     defined = FALSE;
 451     switch (SvTYPE(sv)) {
 452     case SVt_PVAV:
 453         if (AvMAX(sv) >= 0 || SvGMAGICAL(sv) || (SvRMAGICAL(sv) && mg_find(sv, PERL_MAGIC_tied)))
 454             defined = TRUE;
 455         break;
 456     case SVt_PVHV:
 457         if (HvARRAY(sv) || SvGMAGICAL(sv) || (SvRMAGICAL(sv) && mg_find(sv, PERL_MAGIC_tied)))
 458             defined = TRUE;
 459         break;
 460     case SVt_PVCV:
 461         if (CvROOT(sv) || CvXSUB(sv))
 462             defined = TRUE;
 463         break;
 464     default:
 465         SvGETMAGIC(sv);
 466         if (SvOK(sv))
 467             defined = TRUE;
 468         break;
 469     }
 470
 471     if (is_dor) {
 472         if(defined)
 473             RETURN;
 474         if(op_type == OP_DOR)
 475             --SP;
 476         RETURNOP(cLOGOP->op_other);
 477     }
 478     /* assuming OP_DEFINED */
 479     if(defined)
 480         RETPUSHYES;
 481     RETPUSHNO;
 482 }
 483
 484 PP(pp_add)
 485 {
 486     dVAR; dSP; dATARGET; bool useleft; tryAMAGICbin(add,opASSIGN);
 487     useleft = USE_LEFT(TOPm1s);
 488 #ifdef PERL_PRESERVE_IVUV
 489     /* We must see if we can perform the addition with integers if possible,
 490        as the integer code detects overflow while the NV code doesn't.
 491        If either argument hasn't had a numeric conversion yet attempt to get
 492        the IV. It's important to do this now, rather than just assuming that
 493        it's not IOK as a PV of "9223372036854775806" may not take well to NV
 494        addition, and an SV which is NOK, NV=6.0 ought to be coerced to
 495        integer in case the second argument is IV=9223372036854775806
 496        We can (now) rely on sv_2iv to do the right thing, only setting the
 497        public IOK flag if the value in the NV (or PV) slot is truly integer.
 498
 499        A side effect is that this also aggressively prefers integer maths over
 500        fp maths for integer values.
 501
 502        How to detect overflow?
 503
 504        C 99 section 6.2.6.1 says
 505
 506        The range of nonnegative values of a signed integer type is a subrange
 507        of the corresponding unsigned integer type, and the representation of
 508        the same value in each type is the same. A computation involving
 509        unsigned operands can never overflow, because a result that cannot be
 510        represented by the resulting unsigned integer type is reduced modulo
 511        the number that is one greater than the largest value that can be
 512        represented by the resulting type.
 513
 514        (the 9th paragraph)
 515
 516        which I read as "unsigned ints wrap."
 517
 518        signed integer overflow seems to be classed as "exception condition"
 519
 520        If an exceptional condition occurs during the evaluation of an
 521        expression (that is, if the result is not mathematically defined or not
 522        in the range of representable values for its type), the behavior is
 523        undefined.
 524
 525        (6.5, the 5th paragraph)
 526
 527        I had assumed that on 2s complement machines signed arithmetic would
 528        wrap, hence coded pp_add and pp_subtract on the assumption that
 529        everything perl builds on would be happy.  After much wailing and
 530        gnashing of teeth it would seem that irix64 knows its ANSI spec well,
 531        knows that it doesn't need to, and doesn't.  Bah.  Anyway, the all-
 532        unsigned code below is actually shorter than the old code. :-)
 533     */
 534
 535     SvIV_please(TOPs);
 536     if (SvIOK(TOPs)) {
 537         /* Unless the left argument is integer in range we are going to have to
 538            use NV maths. Hence only attempt to coerce the right argument if
 539            we know the left is integer.  */
 540         register UV auv = 0;
 541         bool auvok = FALSE;
 542         bool a_valid = 0;
 543
 544         if (!useleft) {
 545             auv = 0;
 546             a_valid = auvok = 1;
 547             /* left operand is undef, treat as zero. + 0 is identity,
 548                Could SETi or SETu right now, but space optimise by not adding
 549                lots of code to speed up what is probably a rarish case.  */
 550         } else {
 551             /* Left operand is defined, so is it IV? */
 552             SvIV_please(TOPm1s);
 553             if (SvIOK(TOPm1s)) {
 554                 if ((auvok = SvUOK(TOPm1s)))
 555                     auv = SvUVX(TOPm1s);
 556                 else {
 557                     register const IV aiv = SvIVX(TOPm1s);
 558                     if (aiv >= 0) {
 559                         auv = aiv;
 560                         auvok = 1;      /* Now acting as a sign flag.  */
 561                     } else { /* 2s complement assumption for IV_MIN */
 562                         auv = (UV)-aiv;
 563                     }
 564                 }
 565                 a_valid = 1;
 566             }
 567         }
 568         if (a_valid) {
 569             bool result_good = 0;
 570             UV result;
 571             register UV buv;
 572             bool buvok = SvUOK(TOPs);
 573
 574             if (buvok)
 575                 buv = SvUVX(TOPs);
 576             else {
 577                 register const IV biv = SvIVX(TOPs);
 578                 if (biv >= 0) {
 579                     buv = biv;
 580                     buvok = 1;
 581                 } else
 582                     buv = (UV)-biv;
 583             }
 584             /* ?uvok if value is >= 0. basically, flagged as UV if it's +ve,
 585                else "IV" now, independent of how it came in.
 586                if a, b represents positive, A, B negative, a maps to -A etc
 587                a + b =>  (a + b)
 588                A + b => -(a - b)
 589                a + B =>  (a - b)
 590                A + B => -(a + b)
 591                all UV maths. negate result if A negative.
 592                add if signs same, subtract if signs differ. */
 593
 594             if (auvok ^ buvok) {
 595                 /* Signs differ.  */
 596                 if (auv >= buv) {
 597                     result = auv - buv;
 598                     /* Must get smaller */
 599                     if (result <= auv)
 600                         result_good = 1;
 601                 } else {
 602                     result = buv - auv;
 603                     if (result <= buv) {
 604                         /* result really should be -(auv-buv). as its negation
 605                            of true value, need to swap our result flag  */
 606                         auvok = !auvok;
 607                         result_good = 1;
 608                     }
 609                 }
 610             } else {
 611                 /* Signs same */
 612                 result = auv + buv;
 613                 if (result >= auv)
 614                     result_good = 1;
 615             }
 616             if (result_good) {
 617                 SP--;
 618                 if (auvok)
 619                     SETu( result );
 620                 else {
 621                     /* Negate result */
 622                     if (result <= (UV)IV_MIN)
 623                         SETi( -(IV)result );
 624                     else {
 625                         /* result valid, but out of range for IV.  */
 626                         SETn( -(NV)result );
 627                     }
 628                 }
 629                 RETURN;
 630             } /* Overflow, drop through to NVs.  */
 631         }
 632     }
 633 #endif
 634     {
 635         dPOPnv;
 636         if (!useleft) {
 637             /* left operand is undef, treat as zero. + 0.0 is identity. */
 638             SETn(value);
 639             RETURN;
 640         }
 641         SETn( value + TOPn );
 642         RETURN;
 643     }
 644 }
 645
 646 PP(pp_aelemfast)
 647 {
 648     dVAR; dSP;
 649     AV * const av = PL_op->op_flags & OPf_SPECIAL ?
 650                 (AV*)PAD_SV(PL_op->op_targ) : GvAV(cGVOP_gv);
 651     const U32 lval = PL_op->op_flags & OPf_MOD;
 652     SV** const svp = av_fetch(av, PL_op->op_private, lval);
 653     SV *sv = (svp ? *svp : &PL_sv_undef);
 654     EXTEND(SP, 1);
 655     if (!lval && SvGMAGICAL(sv))        /* see note in pp_helem() */
 656         sv = sv_mortalcopy(sv);
 657     PUSHs(sv);
 658     RETURN;
 659 }
 660
 661 PP(pp_join)
 662 {
 663     dVAR; dSP; dMARK; dTARGET;
 664     MARK++;
 665     do_join(TARG, *MARK, MARK, SP);
 666     SP = MARK;
 667     SETs(TARG);
 668     RETURN;
 669 }
 670
 671 PP(pp_pushre)
 672 {
 673     dVAR; dSP;
 674 #ifdef DEBUGGING
 675     /*
 676      * We ass_u_me that LvTARGOFF() comes first, and that two STRLENs
 677      * will be enough to hold an OP*.
 678      */
 679     SV* const sv = sv_newmortal();
 680     sv_upgrade(sv, SVt_PVLV);
 681     LvTYPE(sv) = '/';
 682     Copy(&PL_op, &LvTARGOFF(sv), 1, OP*);
 683     XPUSHs(sv);
 684 #else
 685     XPUSHs((SV*)PL_op);
 686 #endif
 687     RETURN;
 688 }
 689
 690 /* Oversized hot code. */
 691
 692 PP(pp_print)
 693 {
 694     dVAR; dSP; dMARK; dORIGMARK;
 695     IO *io;
 696     register PerlIO *fp;
 697     MAGIC *mg;
 698     GV * const gv = (PL_op->op_flags & OPf_STACKED) ? (GV*)*++MARK : PL_defoutgv;
 699
 700     if (gv && (io = GvIO(gv))
 701         && (mg = SvTIED_mg((SV*)io, PERL_MAGIC_tiedscalar)))
 702     {
 703       had_magic:
 704         if (MARK == ORIGMARK) {
 705             /* If using default handle then we need to make space to
 706              * pass object as 1st arg, so move other args up ...
 707              */
 708             MEXTEND(SP, 1);
 709             ++MARK;
 710             Move(MARK, MARK + 1, (SP - MARK) + 1, SV*);
 711             ++SP;
 712         }
 713         PUSHMARK(MARK - 1);
 714         *MARK = SvTIED_obj((SV*)io, mg);
 715         PUTBACK;
 716         ENTER;
 717         call_method("PRINT", G_SCALAR);
 718         LEAVE;
 719         SPAGAIN;
 720         MARK = ORIGMARK + 1;
 721         *MARK = *SP;
 722         SP = MARK;
 723         RETURN;
 724     }
 725     if (!(io = GvIO(gv))) {
 726         if ((GvEGV(gv)) && (io = GvIO(GvEGV(gv)))
 727             && (mg = SvTIED_mg((SV*)io, PERL_MAGIC_tiedscalar)))
 728             goto had_magic;
 729         if (ckWARN2(WARN_UNOPENED,WARN_CLOSED))
 730             report_evil_fh(gv, io, PL_op->op_type);
 731         SETERRNO(EBADF,RMS_IFI);
 732         goto just_say_no;
 733     }
 734     else if (!(fp = IoOFP(io))) {
 735         if (ckWARN2(WARN_CLOSED, WARN_IO))  {
 736             if (IoIFP(io))
 737                 report_evil_fh(gv, io, OP_phoney_INPUT_ONLY);
 738             else if (ckWARN2(WARN_UNOPENED,WARN_CLOSED))
 739                 report_evil_fh(gv, io, PL_op->op_type);
 740         }
 741         SETERRNO(EBADF,IoIFP(io)?RMS_FAC:RMS_IFI);
 742         goto just_say_no;
 743     }
 744     else {
 745         MARK++;
 746         if (PL_ofs_sv && SvOK(PL_ofs_sv)) {
 747             while (MARK <= SP) {
 748                 if (!do_print(*MARK, fp))
 749                     break;
 750                 MARK++;
 751                 if (MARK <= SP) {
 752                     if (!do_print(PL_ofs_sv, fp)) { /* $, */
 753                         MARK--;
 754                         break;
 755                     }
 756                 }
 757             }
 758         }
 759         else {
 760             while (MARK <= SP) {
 761                 if (!do_print(*MARK, fp))
 762                     break;
 763                 MARK++;
 764             }
 765         }
 766         if (MARK <= SP)
 767             goto just_say_no;
 768         else {
 769             if (PL_op->op_type == OP_SAY) {
 770                 if (PerlIO_write(fp, "\n", 1) == 0 || PerlIO_error(fp))
 771                     goto just_say_no;
 772             }
 773             else if (PL_ors_sv && SvOK(PL_ors_sv))
 774                 if (!do_print(PL_ors_sv, fp)) /* $\ */
 775                     goto just_say_no;
 776
 777             if (IoFLAGS(io) & IOf_FLUSH)
 778                 if (PerlIO_flush(fp) == EOF)
 779                     goto just_say_no;
 780         }
 781     }
 782     SP = ORIGMARK;
 783     XPUSHs(&PL_sv_yes);
 784     RETURN;
 785
 786   just_say_no:
 787     SP = ORIGMARK;
 788     XPUSHs(&PL_sv_undef);
 789     RETURN;
 790 }
 791
 792 PP(pp_rv2av)
 793 {
 794     dVAR; dSP; dTOPss;
 795     const I32 gimme = GIMME_V;
 796     static const char return_array_to_lvalue_scalar[] = "Can't return array to lvalue scalar context";
 797     static const char return_hash_to_lvalue_scalar[] = "Can't return hash to lvalue scalar context";
 798     static const char an_array[] = "an ARRAY";
 799     static const char a_hash[] = "a HASH";
 800     const bool is_pp_rv2av = PL_op->op_type == OP_RV2AV;
 801     const svtype type = is_pp_rv2av ? SVt_PVAV : SVt_PVHV;
 802
 803     if (SvROK(sv)) {
 804       wasref:
 805         tryAMAGICunDEREF_var(is_pp_rv2av ? to_av_amg : to_hv_amg);
 806
 807         sv = SvRV(sv);
 808         if (SvTYPE(sv) != type)
 809             DIE(aTHX_ "Not %s reference", is_pp_rv2av ? an_array : a_hash);
 810         if (PL_op->op_flags & OPf_REF) {
 811             SETs(sv);
 812             RETURN;
 813         }
 814         else if (LVRET) {
 815             if (gimme != G_ARRAY)
 816                 Perl_croak(aTHX_ is_pp_rv2av ? return_array_to_lvalue_scalar
 817                            : return_hash_to_lvalue_scalar);
 818             SETs(sv);
 819             RETURN;
 820         }
 821         else if (PL_op->op_flags & OPf_MOD
 822                 && PL_op->op_private & OPpLVAL_INTRO)
 823             Perl_croak(aTHX_ PL_no_localize_ref);
 824     }
 825     else {
 826         if (SvTYPE(sv) == type) {
 827             if (PL_op->op_flags & OPf_REF) {
 828                 SETs(sv);
 829                 RETURN;
 830             }
 831             else if (LVRET) {
 832                 if (gimme != G_ARRAY)
 833                     Perl_croak(aTHX_
 834                                is_pp_rv2av ? return_array_to_lvalue_scalar
 835                                : return_hash_to_lvalue_scalar);
 836                 SETs(sv);
 837                 RETURN;
 838             }
 839         }
 840         else {
 841             GV *gv;
 842
 843             if (SvTYPE(sv) != SVt_PVGV) {
 844                 if (SvGMAGICAL(sv)) {
 845                     mg_get(sv);
 846                     if (SvROK(sv))
 847                         goto wasref;
 848                 }
 849                 gv = Perl_softref2xv(aTHX_ sv, is_pp_rv2av ? an_array : a_hash,
 850                                      type, &sp);
 851                 if (!gv)
 852                     RETURN;
 853             }
 854             else {
 855                 gv = (GV*)sv;
 856             }
 857             sv = is_pp_rv2av ? (SV*)GvAVn(gv) : (SV*)GvHVn(gv);
 858             if (PL_op->op_private & OPpLVAL_INTRO)
 859                 sv = is_pp_rv2av ? (SV*)save_ary(gv) : (SV*)save_hash(gv);
 860             if (PL_op->op_flags & OPf_REF) {
 861                 SETs(sv);
 862                 RETURN;
 863             }
 864             else if (LVRET) {
 865                 if (gimme != G_ARRAY)
 866                     Perl_croak(aTHX_
 867                                is_pp_rv2av ? return_array_to_lvalue_scalar
 868                                : return_hash_to_lvalue_scalar);
 869                 SETs(sv);
 870                 RETURN;
 871             }
 872         }
 873     }
 874
 875     if (is_pp_rv2av) {
 876         AV *const av = (AV*)sv;
 877         /* The guts of pp_rv2av, with no intenting change to preserve history
 878            (until such time as we get tools that can do blame annotation across
 879            whitespace changes.  */
 880     if (gimme == G_ARRAY) {
 881         const I32 maxarg = AvFILL(av) + 1;
 882         (void)POPs;                     /* XXXX May be optimized away? */
 883         EXTEND(SP, maxarg);
 884         if (SvRMAGICAL(av)) {
 885             U32 i;
 886             for (i=0; i < (U32)maxarg; i++) {
 887                 SV ** const svp = av_fetch(av, i, FALSE);
 888                 /* See note in pp_helem, and bug id #27839 */
 889                 SP[i+1] = svp
 890                     ? SvGMAGICAL(*svp) ? sv_mortalcopy(*svp) : *svp
 891                     : &PL_sv_undef;
 892             }
 893         }
 894         else {
 895             Copy(AvARRAY(av), SP+1, maxarg, SV*);
 896         }
 897         SP += maxarg;
 898     }
 899     else if (gimme == G_SCALAR) {
 900         dTARGET;
 901         const I32 maxarg = AvFILL(av) + 1;
 902         SETi(maxarg);
 903     }
 904     } else {
 905         /* The guts of pp_rv2hv  */
 906     if (gimme == G_ARRAY) { /* array wanted */
 907         *PL_stack_sp = sv;
 908         return do_kv();
 909     }
 910     else if (gimme == G_SCALAR) {
 911         dTARGET;
 912     TARG = Perl_hv_scalar(aTHX_ (HV*)sv);
 913         SPAGAIN;
 914         SETTARG;
 915     }
 916     }
 917     RETURN;
 918 }
 919
 920 STATIC void
 921 S_do_oddball(pTHX_ HV *hash, SV **relem, SV **firstrelem)
 922 {
 923     dVAR;
 924     if (*relem) {
 925         SV *tmpstr;
 926         const HE *didstore;
 927
 928         if (ckWARN(WARN_MISC)) {
 929             const char *err;
 930             if (relem == firstrelem &&
 931                 SvROK(*relem) &&
 932                 (SvTYPE(SvRV(*relem)) == SVt_PVAV ||
 933                  SvTYPE(SvRV(*relem)) == SVt_PVHV))
 934             {
 935                 err = "Reference found where even-sized list expected";
 936             }
 937             else
 938                 err = "Odd number of elements in hash assignment";
 939             Perl_warner(aTHX_ packWARN(WARN_MISC), err);
 940         }
 941
 942         tmpstr = newSV(0);
 943         didstore = hv_store_ent(hash,*relem,tmpstr,0);
 944         if (SvMAGICAL(hash)) {
 945             if (SvSMAGICAL(tmpstr))
 946                 mg_set(tmpstr);
 947             if (!didstore)
 948                 sv_2mortal(tmpstr);
 949         }
 950         TAINT_NOT;
 951     }
 952 }
 953
 954 PP(pp_aassign)
 955 {
 956     dVAR; dSP;
 957     SV **lastlelem = PL_stack_sp;
 958     SV **lastrelem = PL_stack_base + POPMARK;
 959     SV **firstrelem = PL_stack_base + POPMARK + 1;
 960     SV **firstlelem = lastrelem + 1;
 961
 962     register SV **relem;
 963     register SV **lelem;
 964
 965     register SV *sv;
 966     register AV *ary;
 967
 968     I32 gimme;
 969     HV *hash;
 970     I32 i;
 971     int magic;
 972     int duplicates = 0;
 973     SV **firsthashrelem = NULL; /* "= 0" keeps gcc 2.95 quiet  */
 974
 975     if (PL_op->op_private & OPpASSIGN_STATE) {
 976         if (SvPADSTALE(*firstlelem))
 977             SvPADSTALE_off(*firstlelem);
 978         else
 979             RETURN; /* ignore assignment */
 980     }
 981
 982     PL_delaymagic = DM_DELAY;           /* catch simultaneous items */
 983     gimme = GIMME_V;
 984
 985     /* If there's a common identifier on both sides we have to take
 986      * special care that assigning the identifier on the left doesn't
 987      * clobber a value on the right that's used later in the list.
 988      */
 989     if (PL_op->op_private & (OPpASSIGN_COMMON)) {
 990         EXTEND_MORTAL(lastrelem - firstrelem + 1);
 991         for (relem = firstrelem; relem <= lastrelem; relem++) {
 992             if ((sv = *relem)) {
 993                 TAINT_NOT;      /* Each item is independent */
 994                 *relem = sv_mortalcopy(sv);
 995             }
 996         }
 997     }
 998
 999     relem = firstrelem;
1000     lelem = firstlelem;
1001     ary = NULL;
1002     hash = NULL;
1003
1004     while (lelem <= lastlelem) {
1005         TAINT_NOT;              /* Each item stands on its own, taintwise. */
1006         sv = *lelem++;
1007         switch (SvTYPE(sv)) {
1008         case SVt_PVAV:
1009             ary = (AV*)sv;
1010             magic = SvMAGICAL(ary) != 0;
1011             av_clear(ary);
1012             av_extend(ary, lastrelem - relem);
1013             i = 0;
1014             while (relem <= lastrelem) {        /* gobble up all the rest */
1015                 SV **didstore;
1016                 assert(*relem);
1017                 sv = newSVsv(*relem);
1018                 *(relem++) = sv;
1019                 didstore = av_store(ary,i++,sv);
1020                 if (magic) {
1021                     if (SvSMAGICAL(sv))
1022                         mg_set(sv);
1023                     if (!didstore)
1024                         sv_2mortal(sv);
1025                 }
1026                 TAINT_NOT;
1027             }
1028             break;
1029         case SVt_PVHV: {                                /* normal hash */
1030                 SV *tmpstr;
1031
1032                 hash = (HV*)sv;
1033                 magic = SvMAGICAL(hash) != 0;
1034                 hv_clear(hash);
1035                 firsthashrelem = relem;
1036
1037                 while (relem < lastrelem) {     /* gobble up all the rest */
1038                     HE *didstore;
1039                     sv = *relem ? *relem : &PL_sv_no;
1040                     relem++;
1041                     tmpstr = newSV(0);
1042                     if (*relem)
1043                         sv_setsv(tmpstr,*relem);        /* value */
1044                     *(relem++) = tmpstr;
1045                     if (gimme != G_VOID && hv_exists_ent(hash, sv, 0))
1046                         /* key overwrites an existing entry */
1047                         duplicates += 2;
1048                     didstore = hv_store_ent(hash,sv,tmpstr,0);
1049                     if (magic) {
1050                         if (SvSMAGICAL(tmpstr))
1051                             mg_set(tmpstr);
1052                         if (!didstore)
1053                             sv_2mortal(tmpstr);
1054                     }
1055                     TAINT_NOT;
1056                 }
1057                 if (relem == lastrelem) {
1058                     do_oddball(hash, relem, firstrelem);
1059                     relem++;
1060                 }
1061             }
1062             break;
1063         default:
1064             if (SvIMMORTAL(sv)) {
1065                 if (relem <= lastrelem)
1066                     relem++;
1067                 break;
1068             }
1069             if (relem <= lastrelem) {
1070                 sv_setsv(sv, *relem);
1071                 *(relem++) = sv;
1072             }
1073             else
1074                 sv_setsv(sv, &PL_sv_undef);
1075             SvSETMAGIC(sv);
1076             break;
1077         }
1078     }
1079     if (PL_delaymagic & ~DM_DELAY) {
1080         if (PL_delaymagic & DM_UID) {
1081 #ifdef HAS_SETRESUID
1082             (void)setresuid((PL_delaymagic & DM_RUID) ? PL_uid  : (Uid_t)-1,
1083                             (PL_delaymagic & DM_EUID) ? PL_euid : (Uid_t)-1,
1084                             (Uid_t)-1);
1085 #else
1086 #  ifdef HAS_SETREUID
1087             (void)setreuid((PL_delaymagic & DM_RUID) ? PL_uid  : (Uid_t)-1,
1088                            (PL_delaymagic & DM_EUID) ? PL_euid : (Uid_t)-1);
1089 #  else
1090 #    ifdef HAS_SETRUID
1091             if ((PL_delaymagic & DM_UID) == DM_RUID) {
1092                 (void)setruid(PL_uid);
1093                 PL_delaymagic &= ~DM_RUID;
1094             }
1095 #    endif /* HAS_SETRUID */
1096 #    ifdef HAS_SETEUID
1097             if ((PL_delaymagic & DM_UID) == DM_EUID) {
1098                 (void)seteuid(PL_euid);
1099                 PL_delaymagic &= ~DM_EUID;
1100             }
1101 #    endif /* HAS_SETEUID */
1102             if (PL_delaymagic & DM_UID) {
1103                 if (PL_uid != PL_euid)
1104                     DIE(aTHX_ "No setreuid available");
1105                 (void)PerlProc_setuid(PL_uid);
1106             }
1107 #  endif /* HAS_SETREUID */
1108 #endif /* HAS_SETRESUID */
1109             PL_uid = PerlProc_getuid();
1110             PL_euid = PerlProc_geteuid();
1111         }
1112         if (PL_delaymagic & DM_GID) {
1113 #ifdef HAS_SETRESGID
1114             (void)setresgid((PL_delaymagic & DM_RGID) ? PL_gid  : (Gid_t)-1,
1115                             (PL_delaymagic & DM_EGID) ? PL_egid : (Gid_t)-1,
1116                             (Gid_t)-1);
1117 #else
1118 #  ifdef HAS_SETREGID
1119             (void)setregid((PL_delaymagic & DM_RGID) ? PL_gid  : (Gid_t)-1,
1120                            (PL_delaymagic & DM_EGID) ? PL_egid : (Gid_t)-1);
1121 #  else
1122 #    ifdef HAS_SETRGID
1123             if ((PL_delaymagic & DM_GID) == DM_RGID) {
1124                 (void)setrgid(PL_gid);
1125                 PL_delaymagic &= ~DM_RGID;
1126             }
1127 #    endif /* HAS_SETRGID */
1128 #    ifdef HAS_SETEGID
1129             if ((PL_delaymagic & DM_GID) == DM_EGID) {
1130                 (void)setegid(PL_egid);
1131                 PL_delaymagic &= ~DM_EGID;
1132             }
1133 #    endif /* HAS_SETEGID */
1134             if (PL_delaymagic & DM_GID) {
1135                 if (PL_gid != PL_egid)
1136                     DIE(aTHX_ "No setregid available");
1137                 (void)PerlProc_setgid(PL_gid);
1138             }
1139 #  endif /* HAS_SETREGID */
1140 #endif /* HAS_SETRESGID */
1141             PL_gid = PerlProc_getgid();
1142             PL_egid = PerlProc_getegid();
1143         }
1144         PL_tainting |= (PL_uid && (PL_euid != PL_uid || PL_egid != PL_gid));
1145     }
1146     PL_delaymagic = 0;
1147
1148     if (gimme == G_VOID)
1149         SP = firstrelem - 1;
1150     else if (gimme == G_SCALAR) {
1151         dTARGET;
1152         SP = firstrelem;
1153         SETi(lastrelem - firstrelem + 1 - duplicates);
1154     }
1155     else {
1156         if (ary)
1157             SP = lastrelem;
1158         else if (hash) {
1159             if (duplicates) {
1160                 /* Removes from the stack the entries which ended up as
1161                  * duplicated keys in the hash (fix for [perl #24380]) */
1162                 Move(firsthashrelem + duplicates,
1163                         firsthashrelem, duplicates, SV**);
1164                 lastrelem -= duplicates;
1165             }
1166             SP = lastrelem;
1167         }
1168         else
1169             SP = firstrelem + (lastlelem - firstlelem);
1170         lelem = firstlelem + (relem - firstrelem);
1171         while (relem <= SP)
1172             *relem++ = (lelem <= lastlelem) ? *lelem++ : &PL_sv_undef;
1173     }
1174     RETURN;
1175 }
1176
1177 PP(pp_qr)
1178 {
1179     dVAR; dSP;
1180     register PMOP * const pm = cPMOP;
1181     SV * const rv = sv_newmortal();
1182     SV * const sv = newSVrv(rv, "Regexp");
1183     if (pm->op_pmdynflags & PMdf_TAINTED)
1184         SvTAINTED_on(rv);
1185     sv_magic(sv,(SV*)ReREFCNT_inc(PM_GETRE(pm)), PERL_MAGIC_qr,0,0);
1186     XPUSHs(rv);
1187     RETURN;
1188 }
1189
1190 PP(pp_match)
1191 {
1192     dVAR; dSP; dTARG;
1193     register PMOP *pm = cPMOP;
1194     PMOP *dynpm = pm;
1195     register const char *t;
1196     register const char *s;
1197     const char *strend;
1198     I32 global;
1199     I32 r_flags = REXEC_CHECKED;
1200     const char *truebase;                       /* Start of string  */
1201     register REGEXP *rx = PM_GETRE(pm);
1202     bool rxtainted;
1203     const I32 gimme = GIMME;
1204     STRLEN len;
1205     I32 minmatch = 0;
1206     const I32 oldsave = PL_savestack_ix;
1207     I32 update_minmatch = 1;
1208     I32 had_zerolen = 0;
1209     U32 gpos = 0;
1210
1211     if (PL_op->op_flags & OPf_STACKED)
1212         TARG = POPs;
1213     else if (PL_op->op_private & OPpTARGET_MY)
1214         GETTARGET;
1215     else {
1216         TARG = DEFSV;
1217         EXTEND(SP,1);
1218     }
1219
1220     PUTBACK;                            /* EVAL blocks need stack_sp. */
1221     s = SvPV_const(TARG, len);
1222     if (!s)
1223         DIE(aTHX_ "panic: pp_match");
1224     strend = s + len;
1225     rxtainted = ((pm->op_pmdynflags & PMdf_TAINTED) ||
1226                  (PL_tainted && (pm->op_pmflags & PMf_RETAINT)));
1227     TAINT_NOT;
1228
1229     RX_MATCH_UTF8_set(rx, DO_UTF8(TARG));
1230
1231     /* PMdf_USED is set after a ?? matches once */
1232     if (pm->op_pmdynflags & PMdf_USED) {
1233       failure:
1234         if (gimme == G_ARRAY)
1235             RETURN;
1236         RETPUSHNO;
1237     }
1238
1239     /* empty pattern special-cased to use last successful pattern if possible */
1240     if (!rx->prelen && PL_curpm) {
1241         pm = PL_curpm;
1242         rx = PM_GETRE(pm);
1243     }
1244
1245     if (rx->minlen > (I32)len)
1246         goto failure;
1247
1248     truebase = t = s;
1249
1250     /* XXXX What part of this is needed with true \G-support? */
1251     if ((global = dynpm->op_pmflags & PMf_GLOBAL)) {
1252         rx->offs[0].start = -1;
1253         if (SvTYPE(TARG) >= SVt_PVMG && SvMAGIC(TARG)) {
1254             MAGIC* const mg = mg_find(TARG, PERL_MAGIC_regex_global);
1255             if (mg && mg->mg_len >= 0) {
1256                 if (!(rx->extflags & RXf_GPOS_SEEN))
1257                     rx->offs[0].end = rx->offs[0].start = mg->mg_len;
1258                 else if (rx->extflags & RXf_ANCH_GPOS) {
1259                     r_flags |= REXEC_IGNOREPOS;
1260                     rx->offs[0].end = rx->offs[0].start = mg->mg_len;
1261                 } else if (rx->extflags & RXf_GPOS_FLOAT)
1262                     gpos = mg->mg_len;
1263                 else
1264                     rx->offs[0].end = rx->offs[0].start = mg->mg_len;
1265                 minmatch = (mg->mg_flags & MGf_MINMATCH) ? rx->gofs + 1 : 0;
1266                 update_minmatch = 0;
1267             }
1268         }
1269     }
1270     /* remove comment to get faster /g but possibly unsafe $1 vars after a
1271        match. Test for the unsafe vars will fail as well*/
1272     if (( /* !global &&  */ rx->nparens)
1273             || SvTEMP(TARG) || PL_sawampersand ||
1274             (pm->op_pmflags & (PMf_EVAL|PMf_KEEPCOPY)))
1275         r_flags |= REXEC_COPY_STR;
1276     if (SvSCREAM(TARG))
1277         r_flags |= REXEC_SCREAM;
1278
1279 play_it_again:
1280     if (global && rx->offs[0].start != -1) {
1281         t = s = rx->offs[0].end + truebase - rx->gofs;
1282         if ((s + rx->minlen) > strend || s < truebase)
1283             goto nope;
1284         if (update_minmatch++)
1285             minmatch = had_zerolen;
1286     }
1287     if (rx->extflags & RXf_USE_INTUIT &&
1288         DO_UTF8(TARG) == ((rx->extflags & RXf_UTF8) != 0)) {
1289         /* FIXME - can PL_bostr be made const char *?  */
1290         PL_bostr = (char *)truebase;
1291         s = CALLREG_INTUIT_START(rx, TARG, (char *)s, (char *)strend, r_flags, NULL);
1292
1293         if (!s)
1294             goto nope;
1295         if ( (rx->extflags & RXf_CHECK_ALL)
1296              && !PL_sawampersand
1297              && !(pm->op_pmflags & PMf_KEEPCOPY)
1298              && ((rx->extflags & RXf_NOSCAN)
1299                  || !((rx->extflags & RXf_INTUIT_TAIL)
1300                       && (r_flags & REXEC_SCREAM)))
1301              && !SvROK(TARG))   /* Cannot trust since INTUIT cannot guess ^ */
1302             goto yup;
1303     }
1304     if (CALLREGEXEC(rx, (char*)s, (char *)strend, (char*)truebase, minmatch, TARG, INT2PTR(void*, gpos), r_flags))
1305     {
1306         PL_curpm = pm;
1307         if (dynpm->op_pmflags & PMf_ONCE)
1308             dynpm->op_pmdynflags |= PMdf_USED;
1309         goto gotcha;
1310     }
1311     else
1312         goto ret_no;
1313     /*NOTREACHED*/
1314
1315   gotcha:
1316     if (rxtainted)
1317         RX_MATCH_TAINTED_on(rx);
1318     TAINT_IF(RX_MATCH_TAINTED(rx));
1319     if (gimme == G_ARRAY) {
1320         const I32 nparens = rx->nparens;
1321         I32 i = (global && !nparens) ? 1 : 0;
1322
1323         SPAGAIN;                        /* EVAL blocks could move the stack. */
1324         EXTEND(SP, nparens + i);
1325         EXTEND_MORTAL(nparens + i);
1326         for (i = !i; i <= nparens; i++) {
1327             PUSHs(sv_newmortal());
1328             if ((rx->offs[i].start != -1) && rx->offs[i].end != -1 ) {
1329                 const I32 len = rx->offs[i].end - rx->offs[i].start;
1330                 s = rx->offs[i].start + truebase;
1331                 if (rx->offs[i].end < 0 || rx->offs[i].start < 0 ||
1332                     len < 0 || len > strend - s)
1333                     DIE(aTHX_ "panic: pp_match start/end pointers");
1334                 sv_setpvn(*SP, s, len);
1335                 if (DO_UTF8(TARG) && is_utf8_string((U8*)s, len))
1336                     SvUTF8_on(*SP);
1337             }
1338         }
1339         if (global) {
1340             if (dynpm->op_pmflags & PMf_CONTINUE) {
1341                 MAGIC* mg = NULL;
1342                 if (SvTYPE(TARG) >= SVt_PVMG && SvMAGIC(TARG))
1343                     mg = mg_find(TARG, PERL_MAGIC_regex_global);
1344                 if (!mg) {
1345 #ifdef PERL_OLD_COPY_ON_WRITE
1346                     if (SvIsCOW(TARG))
1347                         sv_force_normal_flags(TARG, 0);
1348 #endif
1349                     mg = sv_magicext(TARG, NULL, PERL_MAGIC_regex_global,
1350                                      &PL_vtbl_mglob, NULL, 0);
1351                 }
1352                 if (rx->offs[0].start != -1) {
1353                     mg->mg_len = rx->offs[0].end;
1354                     if (rx->offs[0].start + rx->gofs == (UV)rx->offs[0].end)
1355                         mg->mg_flags |= MGf_MINMATCH;
1356                     else
1357                         mg->mg_flags &= ~MGf_MINMATCH;
1358                 }
1359             }
1360             had_zerolen = (rx->offs[0].start != -1
1361                            && (rx->offs[0].start + rx->gofs
1362                                == (UV)rx->offs[0].end));
1363             PUTBACK;                    /* EVAL blocks may use stack */
1364             r_flags |= REXEC_IGNOREPOS | REXEC_NOT_FIRST;
1365             goto play_it_again;
1366         }
1367         else if (!nparens)
1368             XPUSHs(&PL_sv_yes);
1369         LEAVE_SCOPE(oldsave);
1370         RETURN;
1371     }
1372     else {
1373         if (global) {
1374             MAGIC* mg;
1375             if (SvTYPE(TARG) >= SVt_PVMG && SvMAGIC(TARG))
1376                 mg = mg_find(TARG, PERL_MAGIC_regex_global);
1377             else
1378                 mg = NULL;
1379             if (!mg) {
1380 #ifdef PERL_OLD_COPY_ON_WRITE
1381                 if (SvIsCOW(TARG))
1382                     sv_force_normal_flags(TARG, 0);
1383 #endif
1384                 mg = sv_magicext(TARG, NULL, PERL_MAGIC_regex_global,
1385                                  &PL_vtbl_mglob, NULL, 0);
1386             }
1387             if (rx->offs[0].start != -1) {
1388                 mg->mg_len = rx->offs[0].end;
1389                 if (rx->offs[0].start + rx->gofs == (UV)rx->offs[0].end)
1390                     mg->mg_flags |= MGf_MINMATCH;
1391                 else
1392                     mg->mg_flags &= ~MGf_MINMATCH;
1393             }
1394         }
1395         LEAVE_SCOPE(oldsave);
1396         RETPUSHYES;
1397     }
1398
1399 yup:                                    /* Confirmed by INTUIT */
1400     if (rxtainted)
1401         RX_MATCH_TAINTED_on(rx);
1402     TAINT_IF(RX_MATCH_TAINTED(rx));
1403     PL_curpm = pm;
1404     if (dynpm->op_pmflags & PMf_ONCE)
1405         dynpm->op_pmdynflags |= PMdf_USED;
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 || pm->op_pmflags & 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 = ((pm->op_pmdynflags & PMdf_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             || (pm->op_pmflags & (PMf_EVAL|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              && !(pm->op_pmflags & PMf_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_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) == PL_sub_generation))
3044                 return (SV*)GvCV(gv);
3045         }
3046     }
3047
3048     gv = gv_fetchmethod(stash ? stash : (HV*)packsv, name);
3049
3050     if (!gv) {
3051         /* This code tries to figure out just what went wrong with
3052            gv_fetchmethod.  It therefore needs to duplicate a lot of
3053            the internals of that function.  We can't move it inside
3054            Perl_gv_fetchmethod_autoload(), however, since that would
3055            cause UNIVERSAL->can("NoSuchPackage::foo") to croak, and we
3056            don't want that.
3057         */
3058         const char* leaf = name;
3059         const char* sep = NULL;
3060         const char* p;
3061
3062         for (p = name; *p; p++) {
3063             if (*p == '\'')
3064                 sep = p, leaf = p + 1;
3065             else if (*p == ':' && *(p + 1) == ':')
3066                 sep = p, leaf = p + 2;
3067         }
3068         if (!sep || ((sep - name) == 5 && strnEQ(name, "SUPER", 5))) {
3069             /* the method name is unqualified or starts with SUPER:: */
3070             bool need_strlen = 1;
3071             if (sep) {
3072                 packname = CopSTASHPV(PL_curcop);
3073             }
3074             else if (stash) {
3075                 HEK * const packhek = HvNAME_HEK(stash);
3076                 if (packhek) {
3077                     packname = HEK_KEY(packhek);
3078                     packlen = HEK_LEN(packhek);
3079                     need_strlen = 0;
3080                 } else {
3081                     goto croak;
3082                 }
3083             }
3084
3085             if (!packname) {
3086             croak:
3087                 Perl_croak(aTHX_
3088                            "Can't use anonymous symbol table for method lookup");
3089             }
3090             else if (need_strlen)
3091                 packlen = strlen(packname);
3092
3093         }
3094         else {
3095             /* the method name is qualified */
3096             packname = name;
3097             packlen = sep - name;
3098         }
3099
3100         /* we're relying on gv_fetchmethod not autovivifying the stash */
3101         if (gv_stashpvn(packname, packlen, 0)) {
3102             Perl_croak(aTHX_
3103                        "Can't locate object method \"%s\" via package \"%.*s\"",
3104                        leaf, (int)packlen, packname);
3105         }
3106         else {
3107             Perl_croak(aTHX_
3108                        "Can't locate object method \"%s\" via package \"%.*s\""
3109                        " (perhaps you forgot to load \"%.*s\"?)",
3110                        leaf, (int)packlen, packname, (int)packlen, packname);
3111         }
3112     }
3113     return isGV(gv) ? (SV*)GvCV(gv) : (SV*)gv;
3114 }
3115
3116 /*
3117  * Local variables:
3118  * c-indentation-style: bsd
3119  * c-basic-offset: 4
3120  * indent-tabs-mode: t
3121  * End:
3122  *
3123  * ex: set ts=8 sts=4 sw=4 noet:
3124  */