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