pp_hot.c

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