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