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