pp_hot.c

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