pp_hot.c

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