pp_hot.c

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