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