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