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