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