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