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