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     if ((!global && rx->nparens)
1268             || SvTEMP(TARG) || PL_sawampersand)
1269         r_flags |= REXEC_COPY_STR;
1270     if (SvSCREAM(TARG))
1271         r_flags |= REXEC_SCREAM;
1272
1273     if (pm->op_pmflags & (PMf_MULTILINE|PMf_SINGLELINE)) {
1274         SAVEINT(PL_multiline);
1275         PL_multiline = pm->op_pmflags & PMf_MULTILINE;
1276     }
1277
1278 play_it_again:
1279     if (global && rx->startp[0] != -1) {
1280         t = s = rx->endp[0] + truebase;
1281         if ((s + rx->minlen) > strend)
1282             goto nope;
1283         if (update_minmatch++)
1284             minmatch = had_zerolen;
1285     }
1286     if (rx->reganch & RE_USE_INTUIT &&
1287         DO_UTF8(TARG) == ((rx->reganch & ROPT_UTF8) != 0)) {
1288         PL_bostr = truebase;
1289         s = CALLREG_INTUIT_START(aTHX_ rx, TARG, s, strend, r_flags, NULL);
1290
1291         if (!s)
1292             goto nope;
1293         if ( (rx->reganch & ROPT_CHECK_ALL)
1294              && !PL_sawampersand
1295              && ((rx->reganch & ROPT_NOSCAN)
1296                  || !((rx->reganch & RE_INTUIT_TAIL)
1297                       && (r_flags & REXEC_SCREAM)))
1298              && !SvROK(TARG))   /* Cannot trust since INTUIT cannot guess ^ */
1299             goto yup;
1300     }
1301     if (CALLREGEXEC(aTHX_ rx, s, strend, truebase, minmatch, TARG, NULL, r_flags))
1302     {
1303         PL_curpm = pm;
1304         if (pm->op_pmflags & PMf_ONCE)
1305             pm->op_pmdynflags |= PMdf_USED;
1306         goto gotcha;
1307     }
1308     else
1309         goto ret_no;
1310     /*NOTREACHED*/
1311
1312   gotcha:
1313     if (rxtainted)
1314         RX_MATCH_TAINTED_on(rx);
1315     TAINT_IF(RX_MATCH_TAINTED(rx));
1316     if (gimme == G_ARRAY) {
1317         I32 nparens, i, len;
1318
1319         nparens = rx->nparens;
1320         if (global && !nparens)
1321             i = 1;
1322         else
1323             i = 0;
1324         SPAGAIN;                        /* EVAL blocks could move the stack. */
1325         EXTEND(SP, nparens + i);
1326         EXTEND_MORTAL(nparens + i);
1327         for (i = !i; i <= nparens; i++) {
1328             PUSHs(sv_newmortal());
1329             /*SUPPRESS 560*/
1330             if ((rx->startp[i] != -1) && rx->endp[i] != -1 ) {
1331                 len = rx->endp[i] - rx->startp[i];
1332                 s = rx->startp[i] + truebase;
1333                 sv_setpvn(*SP, s, len);
1334                 if (DO_UTF8(TARG) && is_utf8_string((U8*)s, len))
1335                     SvUTF8_on(*SP);
1336             }
1337         }
1338         if (global) {
1339             if (pm->op_pmflags & PMf_CONTINUE) {
1340                 MAGIC* mg = 0;
1341                 if (SvTYPE(TARG) >= SVt_PVMG && SvMAGIC(TARG))
1342                     mg = mg_find(TARG, PERL_MAGIC_regex_global);
1343                 if (!mg) {
1344                     sv_magic(TARG, (SV*)0, PERL_MAGIC_regex_global, Nullch, 0);
1345                     mg = mg_find(TARG, PERL_MAGIC_regex_global);
1346                 }
1347                 if (rx->startp[0] != -1) {
1348                     mg->mg_len = rx->endp[0];
1349                     if (rx->startp[0] == rx->endp[0])
1350                         mg->mg_flags |= MGf_MINMATCH;
1351                     else
1352                         mg->mg_flags &= ~MGf_MINMATCH;
1353                 }
1354             }
1355             had_zerolen = (rx->startp[0] != -1
1356                            && rx->startp[0] == rx->endp[0]);
1357             PUTBACK;                    /* EVAL blocks may use stack */
1358             r_flags |= REXEC_IGNOREPOS | REXEC_NOT_FIRST;
1359             goto play_it_again;
1360         }
1361         else if (!nparens)
1362             XPUSHs(&PL_sv_yes);
1363         LEAVE_SCOPE(oldsave);
1364         RETURN;
1365     }
1366     else {
1367         if (global) {
1368             MAGIC* mg = 0;
1369             if (SvTYPE(TARG) >= SVt_PVMG && SvMAGIC(TARG))
1370                 mg = mg_find(TARG, PERL_MAGIC_regex_global);
1371             if (!mg) {
1372                 sv_magic(TARG, (SV*)0, PERL_MAGIC_regex_global, Nullch, 0);
1373                 mg = mg_find(TARG, PERL_MAGIC_regex_global);
1374             }
1375             if (rx->startp[0] != -1) {
1376                 mg->mg_len = rx->endp[0];
1377                 if (rx->startp[0] == rx->endp[0])
1378                     mg->mg_flags |= MGf_MINMATCH;
1379                 else
1380                     mg->mg_flags &= ~MGf_MINMATCH;
1381             }
1382         }
1383         LEAVE_SCOPE(oldsave);
1384         RETPUSHYES;
1385     }
1386
1387 yup:                                    /* Confirmed by INTUIT */
1388     if (rxtainted)
1389         RX_MATCH_TAINTED_on(rx);
1390     TAINT_IF(RX_MATCH_TAINTED(rx));
1391     PL_curpm = pm;
1392     if (pm->op_pmflags & PMf_ONCE)
1393         pm->op_pmdynflags |= PMdf_USED;
1394     if (RX_MATCH_COPIED(rx))
1395         Safefree(rx->subbeg);
1396     RX_MATCH_COPIED_off(rx);
1397     rx->subbeg = Nullch;
1398     if (global) {
1399         rx->subbeg = truebase;
1400         rx->startp[0] = s - truebase;
1401         if (PL_reg_match_utf8) {
1402             char *t = (char*)utf8_hop((U8*)s, rx->minlen);
1403             rx->endp[0] = t - truebase;
1404         }
1405         else {
1406             rx->endp[0] = s - truebase + rx->minlen;
1407         }
1408         rx->sublen = strend - truebase;
1409         goto gotcha;
1410     }
1411     if (PL_sawampersand) {
1412         I32 off;
1413
1414         rx->subbeg = savepvn(t, strend - t);
1415         rx->sublen = strend - t;
1416         RX_MATCH_COPIED_on(rx);
1417         off = rx->startp[0] = s - t;
1418         rx->endp[0] = off + rx->minlen;
1419     }
1420     else {                      /* startp/endp are used by @- @+. */
1421         rx->startp[0] = s - truebase;
1422         rx->endp[0] = s - truebase + rx->minlen;
1423     }
1424     rx->nparens = rx->lastparen = 0;    /* used by @- and @+ */
1425     LEAVE_SCOPE(oldsave);
1426     RETPUSHYES;
1427
1428 nope:
1429 ret_no:
1430     if (global && !(pm->op_pmflags & PMf_CONTINUE)) {
1431         if (SvTYPE(TARG) >= SVt_PVMG && SvMAGIC(TARG)) {
1432             MAGIC* mg = mg_find(TARG, PERL_MAGIC_regex_global);
1433             if (mg)
1434                 mg->mg_len = -1;
1435         }
1436     }
1437     LEAVE_SCOPE(oldsave);
1438     if (gimme == G_ARRAY)
1439         RETURN;
1440     RETPUSHNO;
1441 }
1442
1443 OP *
1444 Perl_do_readline(pTHX)
1445 {
1446     dSP; dTARGETSTACKED;
1447     register SV *sv;
1448     STRLEN tmplen = 0;
1449     STRLEN offset;
1450     PerlIO *fp;
1451     register IO *io = GvIO(PL_last_in_gv);
1452     register I32 type = PL_op->op_type;
1453     I32 gimme = GIMME_V;
1454     MAGIC *mg;
1455
1456     if (io && (mg = SvTIED_mg((SV*)io, PERL_MAGIC_tiedscalar))) {
1457         PUSHMARK(SP);
1458         XPUSHs(SvTIED_obj((SV*)io, mg));
1459         PUTBACK;
1460         ENTER;
1461         call_method("READLINE", gimme);
1462         LEAVE;
1463         SPAGAIN;
1464         if (gimme == G_SCALAR)
1465             SvSetMagicSV_nosteal(TARG, TOPs);
1466         RETURN;
1467     }
1468     fp = Nullfp;
1469     if (io) {
1470         fp = IoIFP(io);
1471         if (!fp) {
1472             if (IoFLAGS(io) & IOf_ARGV) {
1473                 if (IoFLAGS(io) & IOf_START) {
1474                     IoLINES(io) = 0;
1475                     if (av_len(GvAVn(PL_last_in_gv)) < 0) {
1476                         IoFLAGS(io) &= ~IOf_START;
1477                         do_open(PL_last_in_gv,"-",1,FALSE,O_RDONLY,0,Nullfp);
1478                         sv_setpvn(GvSV(PL_last_in_gv), "-", 1);
1479                         SvSETMAGIC(GvSV(PL_last_in_gv));
1480                         fp = IoIFP(io);
1481                         goto have_fp;
1482                     }
1483                 }
1484                 fp = nextargv(PL_last_in_gv);
1485                 if (!fp) { /* Note: fp != IoIFP(io) */
1486                     (void)do_close(PL_last_in_gv, FALSE); /* now it does*/
1487                 }
1488             }
1489             else if (type == OP_GLOB)
1490                 fp = Perl_start_glob(aTHX_ POPs, io);
1491         }
1492         else if (type == OP_GLOB)
1493             SP--;
1494         else if (ckWARN(WARN_IO) && IoTYPE(io) == IoTYPE_WRONLY) {
1495             report_evil_fh(PL_last_in_gv, io, OP_phoney_OUTPUT_ONLY);
1496         }
1497     }
1498     if (!fp) {
1499         if (ckWARN2(WARN_GLOB, WARN_CLOSED)
1500                 && (!io || !(IoFLAGS(io) & IOf_START))) {
1501             if (type == OP_GLOB)
1502                 Perl_warner(aTHX_ WARN_GLOB,
1503                             "glob failed (can't start child: %s)",
1504                             Strerror(errno));
1505             else
1506                 report_evil_fh(PL_last_in_gv, io, PL_op->op_type);
1507         }
1508         if (gimme == G_SCALAR) {
1509             (void)SvOK_off(TARG);
1510             PUSHTARG;
1511         }
1512         RETURN;
1513     }
1514   have_fp:
1515     if (gimme == G_SCALAR) {
1516         sv = TARG;
1517         if (SvROK(sv))
1518             sv_unref(sv);
1519         (void)SvUPGRADE(sv, SVt_PV);
1520         tmplen = SvLEN(sv);     /* remember if already alloced */
1521         if (!tmplen)
1522             Sv_Grow(sv, 80);    /* try short-buffering it */
1523         if (type == OP_RCATLINE)
1524             offset = SvCUR(sv);
1525         else
1526             offset = 0;
1527     }
1528     else {
1529         sv = sv_2mortal(NEWSV(57, 80));
1530         offset = 0;
1531     }
1532
1533     /* This should not be marked tainted if the fp is marked clean */
1534 #define MAYBE_TAINT_LINE(io, sv) \
1535     if (!(IoFLAGS(io) & IOf_UNTAINT)) { \
1536         TAINT;                          \
1537         SvTAINTED_on(sv);               \
1538     }
1539
1540 /* delay EOF state for a snarfed empty file */
1541 #define SNARF_EOF(gimme,rs,io,sv) \
1542     (gimme != G_SCALAR || SvCUR(sv)                                     \
1543      || (IoFLAGS(io) & IOf_NOLINE) || !RsSNARF(rs))
1544
1545     for (;;) {
1546         PUTBACK;
1547         if (!sv_gets(sv, fp, offset)
1548             && (type == OP_GLOB || SNARF_EOF(gimme, PL_rs, io, sv)))
1549         {
1550             PerlIO_clearerr(fp);
1551             if (IoFLAGS(io) & IOf_ARGV) {
1552                 fp = nextargv(PL_last_in_gv);
1553                 if (fp)
1554                     continue;
1555                 (void)do_close(PL_last_in_gv, FALSE);
1556             }
1557             else if (type == OP_GLOB) {
1558                 if (!do_close(PL_last_in_gv, FALSE) && ckWARN(WARN_GLOB)) {
1559                     Perl_warner(aTHX_ WARN_GLOB,
1560                            "glob failed (child exited with status %d%s)",
1561                            (int)(STATUS_CURRENT >> 8),
1562                            (STATUS_CURRENT & 0x80) ? ", core dumped" : "");
1563                 }
1564             }
1565             if (gimme == G_SCALAR) {
1566                 (void)SvOK_off(TARG);
1567                 SPAGAIN;
1568                 PUSHTARG;
1569             }
1570             MAYBE_TAINT_LINE(io, sv);
1571             RETURN;
1572         }
1573         MAYBE_TAINT_LINE(io, sv);
1574         IoLINES(io)++;
1575         IoFLAGS(io) |= IOf_NOLINE;
1576         SvSETMAGIC(sv);
1577         SPAGAIN;
1578         XPUSHs(sv);
1579         if (type == OP_GLOB) {
1580             char *tmps;
1581
1582             if (SvCUR(sv) > 0 && SvCUR(PL_rs) > 0) {
1583                 tmps = SvEND(sv) - 1;
1584                 if (*tmps == *SvPVX(PL_rs)) {
1585                     *tmps = '\0';
1586                     SvCUR(sv)--;
1587                 }
1588             }
1589             for (tmps = SvPVX(sv); *tmps; tmps++)
1590                 if (!isALPHA(*tmps) && !isDIGIT(*tmps) &&
1591                     strchr("$&*(){}[]'\";\\|?<>~`", *tmps))
1592                         break;
1593             if (*tmps && PerlLIO_lstat(SvPVX(sv), &PL_statbuf) < 0) {
1594                 (void)POPs;             /* Unmatched wildcard?  Chuck it... */
1595                 continue;
1596             }
1597         }
1598         if (gimme == G_ARRAY) {
1599             if (SvLEN(sv) - SvCUR(sv) > 20) {
1600                 SvLEN_set(sv, SvCUR(sv)+1);
1601                 Renew(SvPVX(sv), SvLEN(sv), char);
1602             }
1603             sv = sv_2mortal(NEWSV(58, 80));
1604             continue;
1605         }
1606         else if (gimme == G_SCALAR && !tmplen && SvLEN(sv) - SvCUR(sv) > 80) {
1607             /* try to reclaim a bit of scalar space (only on 1st alloc) */
1608             if (SvCUR(sv) < 60)
1609                 SvLEN_set(sv, 80);
1610             else
1611                 SvLEN_set(sv, SvCUR(sv)+40);    /* allow some slop */
1612             Renew(SvPVX(sv), SvLEN(sv), char);
1613         }
1614         RETURN;
1615     }
1616 }
1617
1618 PP(pp_enter)
1619 {
1620     dSP;
1621     register PERL_CONTEXT *cx;
1622     I32 gimme = OP_GIMME(PL_op, -1);
1623
1624     if (gimme == -1) {
1625         if (cxstack_ix >= 0)
1626             gimme = cxstack[cxstack_ix].blk_gimme;
1627         else
1628             gimme = G_SCALAR;
1629     }
1630
1631     ENTER;
1632
1633     SAVETMPS;
1634     PUSHBLOCK(cx, CXt_BLOCK, SP);
1635
1636     RETURN;
1637 }
1638
1639 PP(pp_helem)
1640 {
1641     dSP;
1642     HE* he;
1643     SV **svp;
1644     SV *keysv = POPs;
1645     HV *hv = (HV*)POPs;
1646     U32 lval = PL_op->op_flags & OPf_MOD || LVRET;
1647     U32 defer = PL_op->op_private & OPpLVAL_DEFER;
1648     SV *sv;
1649     U32 hash = (SvFAKE(keysv) && SvREADONLY(keysv)) ? SvUVX(keysv) : 0;
1650     I32 preeminent = 0;
1651
1652     if (SvTYPE(hv) == SVt_PVHV) {
1653         if (PL_op->op_private & OPpLVAL_INTRO)
1654             preeminent = SvRMAGICAL(hv) ? 1 : hv_exists_ent(hv, keysv, 0);
1655         he = hv_fetch_ent(hv, keysv, lval && !defer, hash);
1656         svp = he ? &HeVAL(he) : 0;
1657     }
1658     else if (SvTYPE(hv) == SVt_PVAV) {
1659         if (PL_op->op_private & OPpLVAL_INTRO)
1660             DIE(aTHX_ "Can't localize pseudo-hash element");
1661         svp = avhv_fetch_ent((AV*)hv, keysv, lval && !defer, hash);
1662     }
1663     else {
1664         RETPUSHUNDEF;
1665     }
1666     if (lval) {
1667         if (!svp || *svp == &PL_sv_undef) {
1668             SV* lv;
1669             SV* key2;
1670             if (!defer) {
1671                 STRLEN n_a;
1672                 DIE(aTHX_ PL_no_helem, SvPV(keysv, n_a));
1673             }
1674             lv = sv_newmortal();
1675             sv_upgrade(lv, SVt_PVLV);
1676             LvTYPE(lv) = 'y';
1677             sv_magic(lv, key2 = newSVsv(keysv), PERL_MAGIC_defelem, Nullch, 0);
1678             SvREFCNT_dec(key2); /* sv_magic() increments refcount */
1679             LvTARG(lv) = SvREFCNT_inc(hv);
1680             LvTARGLEN(lv) = 1;
1681             PUSHs(lv);
1682             RETURN;
1683         }
1684         if (PL_op->op_private & OPpLVAL_INTRO) {
1685             if (HvNAME(hv) && isGV(*svp))
1686                 save_gp((GV*)*svp, !(PL_op->op_flags & OPf_SPECIAL));
1687             else {
1688                 if (!preeminent) {
1689                     STRLEN keylen;
1690                     char *key = SvPV(keysv, keylen);
1691                     SAVEDELETE(hv, savepvn(key,keylen), keylen);
1692                 } else
1693                     save_helem(hv, keysv, svp);
1694             }
1695         }
1696         else if (PL_op->op_private & OPpDEREF)
1697             vivify_ref(*svp, PL_op->op_private & OPpDEREF);
1698     }
1699     sv = (svp ? *svp : &PL_sv_undef);
1700     /* This makes C<local $tied{foo} = $tied{foo}> possible.
1701      * Pushing the magical RHS on to the stack is useless, since
1702      * that magic is soon destined to be misled by the local(),
1703      * and thus the later pp_sassign() will fail to mg_get() the
1704      * old value.  This should also cure problems with delayed
1705      * mg_get()s.  GSAR 98-07-03 */
1706     if (!lval && SvGMAGICAL(sv))
1707         sv = sv_mortalcopy(sv);
1708     PUSHs(sv);
1709     RETURN;
1710 }
1711
1712 PP(pp_leave)
1713 {
1714     dSP;
1715     register PERL_CONTEXT *cx;
1716     register SV **mark;
1717     SV **newsp;
1718     PMOP *newpm;
1719     I32 gimme;
1720
1721     if (PL_op->op_flags & OPf_SPECIAL) {
1722         cx = &cxstack[cxstack_ix];
1723         cx->blk_oldpm = PL_curpm;       /* fake block should preserve $1 et al */
1724     }
1725
1726     POPBLOCK(cx,newpm);
1727
1728     gimme = OP_GIMME(PL_op, -1);
1729     if (gimme == -1) {
1730         if (cxstack_ix >= 0)
1731             gimme = cxstack[cxstack_ix].blk_gimme;
1732         else
1733             gimme = G_SCALAR;
1734     }
1735
1736     TAINT_NOT;
1737     if (gimme == G_VOID)
1738         SP = newsp;
1739     else if (gimme == G_SCALAR) {
1740         MARK = newsp + 1;
1741         if (MARK <= SP) {
1742             if (SvFLAGS(TOPs) & (SVs_PADTMP|SVs_TEMP))
1743                 *MARK = TOPs;
1744             else
1745                 *MARK = sv_mortalcopy(TOPs);
1746         } else {
1747             MEXTEND(mark,0);
1748             *MARK = &PL_sv_undef;
1749         }
1750         SP = MARK;
1751     }
1752     else if (gimme == G_ARRAY) {
1753         /* in case LEAVE wipes old return values */
1754         for (mark = newsp + 1; mark <= SP; mark++) {
1755             if (!(SvFLAGS(*mark) & (SVs_PADTMP|SVs_TEMP))) {
1756                 *mark = sv_mortalcopy(*mark);
1757                 TAINT_NOT;      /* Each item is independent */
1758             }
1759         }
1760     }
1761     PL_curpm = newpm;   /* Don't pop $1 et al till now */
1762
1763     LEAVE;
1764
1765     RETURN;
1766 }
1767
1768 PP(pp_iter)
1769 {
1770     dSP;
1771     register PERL_CONTEXT *cx;
1772     SV* sv;
1773     AV* av;
1774     SV **itersvp;
1775
1776     EXTEND(SP, 1);
1777     cx = &cxstack[cxstack_ix];
1778     if (CxTYPE(cx) != CXt_LOOP)
1779         DIE(aTHX_ "panic: pp_iter");
1780
1781     itersvp = CxITERVAR(cx);
1782     av = cx->blk_loop.iterary;
1783     if (SvTYPE(av) != SVt_PVAV) {
1784         /* iterate ($min .. $max) */
1785         if (cx->blk_loop.iterlval) {
1786             /* string increment */
1787             register SV* cur = cx->blk_loop.iterlval;
1788             STRLEN maxlen;
1789             char *max = SvPV((SV*)av, maxlen);
1790             if (!SvNIOK(cur) && SvCUR(cur) <= maxlen) {
1791 #ifndef USE_5005THREADS                   /* don't risk potential race */
1792                 if (SvREFCNT(*itersvp) == 1 && !SvMAGICAL(*itersvp)) {
1793                     /* safe to reuse old SV */
1794                     sv_setsv(*itersvp, cur);
1795                 }
1796                 else
1797 #endif
1798                 {
1799                     /* we need a fresh SV every time so that loop body sees a
1800                      * completely new SV for closures/references to work as
1801                      * they used to */
1802                     SvREFCNT_dec(*itersvp);
1803                     *itersvp = newSVsv(cur);
1804                 }
1805                 if (strEQ(SvPVX(cur), max))
1806                     sv_setiv(cur, 0); /* terminate next time */
1807                 else
1808                     sv_inc(cur);
1809                 RETPUSHYES;
1810             }
1811             RETPUSHNO;
1812         }
1813         /* integer increment */
1814         if (cx->blk_loop.iterix > cx->blk_loop.itermax)
1815             RETPUSHNO;
1816
1817 #ifndef USE_5005THREADS                   /* don't risk potential race */
1818         if (SvREFCNT(*itersvp) == 1 && !SvMAGICAL(*itersvp)) {
1819             /* safe to reuse old SV */
1820             sv_setiv(*itersvp, cx->blk_loop.iterix++);
1821         }
1822         else
1823 #endif
1824         {
1825             /* we need a fresh SV every time so that loop body sees a
1826              * completely new SV for closures/references to work as they
1827              * used to */
1828             SvREFCNT_dec(*itersvp);
1829             *itersvp = newSViv(cx->blk_loop.iterix++);
1830         }
1831         RETPUSHYES;
1832     }
1833
1834     /* iterate array */
1835     if (cx->blk_loop.iterix >= (av == PL_curstack ? cx->blk_oldsp : AvFILL(av)))
1836         RETPUSHNO;
1837
1838     SvREFCNT_dec(*itersvp);
1839
1840     if (SvMAGICAL(av) || AvREIFY(av)) {
1841         SV **svp = av_fetch(av, ++cx->blk_loop.iterix, FALSE);
1842         if (svp)
1843             sv = *svp;
1844         else
1845             sv = Nullsv;
1846     }
1847     else {
1848         sv = AvARRAY(av)[++cx->blk_loop.iterix];
1849     }
1850     if (sv)
1851         SvTEMP_off(sv);
1852     else
1853         sv = &PL_sv_undef;
1854     if (av != PL_curstack && sv == &PL_sv_undef) {
1855         SV *lv = cx->blk_loop.iterlval;
1856         if (lv && SvREFCNT(lv) > 1) {
1857             SvREFCNT_dec(lv);
1858             lv = Nullsv;
1859         }
1860         if (lv)
1861             SvREFCNT_dec(LvTARG(lv));
1862         else {
1863             lv = cx->blk_loop.iterlval = NEWSV(26, 0);
1864             sv_upgrade(lv, SVt_PVLV);
1865             LvTYPE(lv) = 'y';
1866             sv_magic(lv, Nullsv, PERL_MAGIC_defelem, Nullch, 0);
1867         }
1868         LvTARG(lv) = SvREFCNT_inc(av);
1869         LvTARGOFF(lv) = cx->blk_loop.iterix;
1870         LvTARGLEN(lv) = (STRLEN)UV_MAX;
1871         sv = (SV*)lv;
1872     }
1873
1874     *itersvp = SvREFCNT_inc(sv);
1875     RETPUSHYES;
1876 }
1877
1878 PP(pp_subst)
1879 {
1880     dSP; dTARG;
1881     register PMOP *pm = cPMOP;
1882     PMOP *rpm = pm;
1883     register SV *dstr;
1884     register char *s;
1885     char *strend;
1886     register char *m;
1887     char *c;
1888     register char *d;
1889     STRLEN clen;
1890     I32 iters = 0;
1891     I32 maxiters;
1892     register I32 i;
1893     bool once;
1894     bool rxtainted;
1895     char *orig;
1896     I32 r_flags;
1897     register REGEXP *rx = PM_GETRE(pm);
1898     STRLEN len;
1899     int force_on_match = 0;
1900     I32 oldsave = PL_savestack_ix;
1901     STRLEN slen;
1902
1903     /* known replacement string? */
1904     dstr = (pm->op_pmflags & PMf_CONST) ? POPs : Nullsv;
1905     if (PL_op->op_flags & OPf_STACKED)
1906         TARG = POPs;
1907     else {
1908         TARG = DEFSV;
1909         EXTEND(SP,1);
1910     }
1911
1912     if (SvFAKE(TARG) && SvREADONLY(TARG))
1913         sv_force_normal(TARG);
1914     if (SvREADONLY(TARG)
1915         || (SvTYPE(TARG) > SVt_PVLV
1916             && !(SvTYPE(TARG) == SVt_PVGV && SvFAKE(TARG))))
1917         DIE(aTHX_ PL_no_modify);
1918     PUTBACK;
1919
1920     s = SvPV(TARG, len);
1921     if (!SvPOKp(TARG) || SvTYPE(TARG) == SVt_PVGV)
1922         force_on_match = 1;
1923     rxtainted = ((pm->op_pmdynflags & PMdf_TAINTED) ||
1924                  (PL_tainted && (pm->op_pmflags & PMf_RETAINT)));
1925     if (PL_tainted)
1926         rxtainted |= 2;
1927     TAINT_NOT;
1928
1929     PL_reg_match_utf8 = DO_UTF8(TARG);
1930
1931   force_it:
1932     if (!pm || !s)
1933         DIE(aTHX_ "panic: pp_subst");
1934
1935     strend = s + len;
1936     slen = PL_reg_match_utf8 ? utf8_length((U8*)s, (U8*)strend) : len;
1937     maxiters = 2 * slen + 10;   /* We can match twice at each
1938                                    position, once with zero-length,
1939                                    second time with non-zero. */
1940
1941     if (!rx->prelen && PL_curpm) {
1942         pm = PL_curpm;
1943         rx = PM_GETRE(pm);
1944     }
1945     r_flags = (rx->nparens || SvTEMP(TARG) || PL_sawampersand)
1946                 ? REXEC_COPY_STR : 0;
1947     if (SvSCREAM(TARG))
1948         r_flags |= REXEC_SCREAM;
1949     if (pm->op_pmflags & (PMf_MULTILINE|PMf_SINGLELINE)) {
1950         SAVEINT(PL_multiline);
1951         PL_multiline = pm->op_pmflags & PMf_MULTILINE;
1952     }
1953     orig = m = s;
1954     if (rx->reganch & RE_USE_INTUIT) {
1955         PL_bostr = orig;
1956         s = CALLREG_INTUIT_START(aTHX_ rx, TARG, s, strend, r_flags, NULL);
1957
1958         if (!s)
1959             goto nope;
1960         /* How to do it in subst? */
1961 /*      if ( (rx->reganch & ROPT_CHECK_ALL)
1962              && !PL_sawampersand
1963              && ((rx->reganch & ROPT_NOSCAN)
1964                  || !((rx->reganch & RE_INTUIT_TAIL)
1965                       && (r_flags & REXEC_SCREAM))))
1966             goto yup;
1967 */
1968     }
1969
1970     /* only replace once? */
1971     once = !(rpm->op_pmflags & PMf_GLOBAL);
1972
1973     /* known replacement string? */
1974     c = dstr ? SvPV(dstr, clen) : Nullch;
1975
1976     /* can do inplace substitution? */
1977     if (c && clen <= rx->minlen && (once || !(r_flags & REXEC_COPY_STR))
1978         && !(rx->reganch & ROPT_LOOKBEHIND_SEEN)) {
1979         if (!CALLREGEXEC(aTHX_ rx, s, strend, orig, 0, TARG, NULL,
1980                          r_flags | REXEC_CHECKED))
1981         {
1982             SPAGAIN;
1983             PUSHs(&PL_sv_no);
1984             LEAVE_SCOPE(oldsave);
1985             RETURN;
1986         }
1987         if (force_on_match) {
1988             force_on_match = 0;
1989             s = SvPV_force(TARG, len);
1990             goto force_it;
1991         }
1992         d = s;
1993         PL_curpm = pm;
1994         SvSCREAM_off(TARG);     /* disable possible screamer */
1995         if (once) {
1996             rxtainted |= RX_MATCH_TAINTED(rx);
1997             m = orig + rx->startp[0];
1998             d = orig + rx->endp[0];
1999             s = orig;
2000             if (m - s > strend - d) {  /* faster to shorten from end */
2001                 if (clen) {
2002                     Copy(c, m, clen, char);
2003                     m += clen;
2004                 }
2005                 i = strend - d;
2006                 if (i > 0) {
2007                     Move(d, m, i, char);
2008                     m += i;
2009                 }
2010                 *m = '\0';
2011                 SvCUR_set(TARG, m - s);
2012             }
2013             /*SUPPRESS 560*/
2014             else if ((i = m - s)) {     /* faster from front */
2015                 d -= clen;
2016                 m = d;
2017                 sv_chop(TARG, d-i);
2018                 s += i;
2019                 while (i--)
2020                     *--d = *--s;
2021                 if (clen)
2022                     Copy(c, m, clen, char);
2023             }
2024             else if (clen) {
2025                 d -= clen;
2026                 sv_chop(TARG, d);
2027                 Copy(c, d, clen, char);
2028             }
2029             else {
2030                 sv_chop(TARG, d);
2031             }
2032             TAINT_IF(rxtainted & 1);
2033             SPAGAIN;
2034             PUSHs(&PL_sv_yes);
2035         }
2036         else {
2037             do {
2038                 if (iters++ > maxiters)
2039                     DIE(aTHX_ "Substitution loop");
2040                 rxtainted |= RX_MATCH_TAINTED(rx);
2041                 m = rx->startp[0] + orig;
2042                 /*SUPPRESS 560*/
2043                 if ((i = m - s)) {
2044                     if (s != d)
2045                         Move(s, d, i, char);
2046                     d += i;
2047                 }
2048                 if (clen) {
2049                     Copy(c, d, clen, char);
2050                     d += clen;
2051                 }
2052                 s = rx->endp[0] + orig;
2053             } while (CALLREGEXEC(aTHX_ rx, s, strend, orig, s == m,
2054                                  TARG, NULL,
2055                                  /* don't match same null twice */
2056                                  REXEC_NOT_FIRST|REXEC_IGNOREPOS));
2057             if (s != d) {
2058                 i = strend - s;
2059                 SvCUR_set(TARG, d - SvPVX(TARG) + i);
2060                 Move(s, d, i+1, char);          /* include the NUL */
2061             }
2062             TAINT_IF(rxtainted & 1);
2063             SPAGAIN;
2064             PUSHs(sv_2mortal(newSViv((I32)iters)));
2065         }
2066         (void)SvPOK_only_UTF8(TARG);
2067         TAINT_IF(rxtainted);
2068         if (SvSMAGICAL(TARG)) {
2069             PUTBACK;
2070             mg_set(TARG);
2071             SPAGAIN;
2072         }
2073         SvTAINT(TARG);
2074         LEAVE_SCOPE(oldsave);
2075         RETURN;
2076     }
2077
2078     if (CALLREGEXEC(aTHX_ rx, s, strend, orig, 0, TARG, NULL,
2079                     r_flags | REXEC_CHECKED))
2080     {
2081         bool isutf8;
2082
2083         if (force_on_match) {
2084             force_on_match = 0;
2085             s = SvPV_force(TARG, len);
2086             goto force_it;
2087         }
2088         rxtainted |= RX_MATCH_TAINTED(rx);
2089         dstr = NEWSV(25, len);
2090         sv_setpvn(dstr, m, s-m);
2091         if (DO_UTF8(TARG))
2092             SvUTF8_on(dstr);
2093         PL_curpm = pm;
2094         if (!c) {
2095             register PERL_CONTEXT *cx;
2096             SPAGAIN;
2097             PUSHSUBST(cx);
2098             RETURNOP(cPMOP->op_pmreplroot);
2099         }
2100         r_flags |= REXEC_IGNOREPOS | REXEC_NOT_FIRST;
2101         do {
2102             if (iters++ > maxiters)
2103                 DIE(aTHX_ "Substitution loop");
2104             rxtainted |= RX_MATCH_TAINTED(rx);
2105             if (RX_MATCH_COPIED(rx) && rx->subbeg != orig) {
2106                 m = s;
2107                 s = orig;
2108                 orig = rx->subbeg;
2109                 s = orig + (m - s);
2110                 strend = s + (strend - m);
2111             }
2112             m = rx->startp[0] + orig;
2113             sv_catpvn(dstr, s, m-s);
2114             s = rx->endp[0] + orig;
2115             if (clen)
2116                 sv_catpvn(dstr, c, clen);
2117             if (once)
2118                 break;
2119         } while (CALLREGEXEC(aTHX_ rx, s, strend, orig, s == m,
2120                              TARG, NULL, r_flags));
2121         sv_catpvn(dstr, s, strend - s);
2122
2123         (void)SvOOK_off(TARG);
2124         Safefree(SvPVX(TARG));
2125         SvPVX(TARG) = SvPVX(dstr);
2126         SvCUR_set(TARG, SvCUR(dstr));
2127         SvLEN_set(TARG, SvLEN(dstr));
2128         isutf8 = DO_UTF8(dstr);
2129         SvPVX(dstr) = 0;
2130         sv_free(dstr);
2131
2132         TAINT_IF(rxtainted & 1);
2133         SPAGAIN;
2134         PUSHs(sv_2mortal(newSViv((I32)iters)));
2135
2136         (void)SvPOK_only(TARG);
2137         if (isutf8)
2138             SvUTF8_on(TARG);
2139         TAINT_IF(rxtainted);
2140         SvSETMAGIC(TARG);
2141         SvTAINT(TARG);
2142         LEAVE_SCOPE(oldsave);
2143         RETURN;
2144     }
2145     goto ret_no;
2146
2147 nope:
2148 ret_no:
2149     SPAGAIN;
2150     PUSHs(&PL_sv_no);
2151     LEAVE_SCOPE(oldsave);
2152     RETURN;
2153 }
2154
2155 PP(pp_grepwhile)
2156 {
2157     dSP;
2158
2159     if (SvTRUEx(POPs))
2160         PL_stack_base[PL_markstack_ptr[-1]++] = PL_stack_base[*PL_markstack_ptr];
2161     ++*PL_markstack_ptr;
2162     LEAVE;                                      /* exit inner scope */
2163
2164     /* All done yet? */
2165     if (PL_stack_base + *PL_markstack_ptr > SP) {
2166         I32 items;
2167         I32 gimme = GIMME_V;
2168
2169         LEAVE;                                  /* exit outer scope */
2170         (void)POPMARK;                          /* pop src */
2171         items = --*PL_markstack_ptr - PL_markstack_ptr[-1];
2172         (void)POPMARK;                          /* pop dst */
2173         SP = PL_stack_base + POPMARK;           /* pop original mark */
2174         if (gimme == G_SCALAR) {
2175             dTARGET;
2176             XPUSHi(items);
2177         }
2178         else if (gimme == G_ARRAY)
2179             SP += items;
2180         RETURN;
2181     }
2182     else {
2183         SV *src;
2184
2185         ENTER;                                  /* enter inner scope */
2186         SAVEVPTR(PL_curpm);
2187
2188         src = PL_stack_base[*PL_markstack_ptr];
2189         SvTEMP_off(src);
2190         DEFSV = src;
2191
2192         RETURNOP(cLOGOP->op_other);
2193     }
2194 }
2195
2196 PP(pp_leavesub)
2197 {
2198     dSP;
2199     SV **mark;
2200     SV **newsp;
2201     PMOP *newpm;
2202     I32 gimme;
2203     register PERL_CONTEXT *cx;
2204     SV *sv;
2205
2206     POPBLOCK(cx,newpm);
2207
2208     TAINT_NOT;
2209     if (gimme == G_SCALAR) {
2210         MARK = newsp + 1;
2211         if (MARK <= SP) {
2212             if (cx->blk_sub.cv && CvDEPTH(cx->blk_sub.cv) > 1) {
2213                 if (SvTEMP(TOPs)) {
2214                     *MARK = SvREFCNT_inc(TOPs);
2215                     FREETMPS;
2216                     sv_2mortal(*MARK);
2217                 }
2218                 else {
2219                     sv = SvREFCNT_inc(TOPs);    /* FREETMPS could clobber it */
2220                     FREETMPS;
2221                     *MARK = sv_mortalcopy(sv);
2222                     SvREFCNT_dec(sv);
2223                 }
2224             }
2225             else
2226                 *MARK = SvTEMP(TOPs) ? TOPs : sv_mortalcopy(TOPs);
2227         }
2228         else {
2229             MEXTEND(MARK, 0);
2230             *MARK = &PL_sv_undef;
2231         }
2232         SP = MARK;
2233     }
2234     else if (gimme == G_ARRAY) {
2235         for (MARK = newsp + 1; MARK <= SP; MARK++) {
2236             if (!SvTEMP(*MARK)) {
2237                 *MARK = sv_mortalcopy(*MARK);
2238                 TAINT_NOT;      /* Each item is independent */
2239             }
2240         }
2241     }
2242     PUTBACK;
2243
2244     POPSUB(cx,sv);      /* Stack values are safe: release CV and @_ ... */
2245     PL_curpm = newpm;   /* ... and pop $1 et al */
2246
2247     LEAVE;
2248     LEAVESUB(sv);
2249     return pop_return();
2250 }
2251
2252 /* This duplicates the above code because the above code must not
2253  * get any slower by more conditions */
2254 PP(pp_leavesublv)
2255 {
2256     dSP;
2257     SV **mark;
2258     SV **newsp;
2259     PMOP *newpm;
2260     I32 gimme;
2261     register PERL_CONTEXT *cx;
2262     SV *sv;
2263
2264     POPBLOCK(cx,newpm);
2265
2266     TAINT_NOT;
2267
2268     if (cx->blk_sub.lval & OPpENTERSUB_INARGS) {
2269         /* We are an argument to a function or grep().
2270          * This kind of lvalueness was legal before lvalue
2271          * subroutines too, so be backward compatible:
2272          * cannot report errors.  */
2273
2274         /* Scalar context *is* possible, on the LHS of -> only,
2275          * as in f()->meth().  But this is not an lvalue. */
2276         if (gimme == G_SCALAR)
2277             goto temporise;
2278         if (gimme == G_ARRAY) {
2279             if (!CvLVALUE(cx->blk_sub.cv))
2280                 goto temporise_array;
2281             EXTEND_MORTAL(SP - newsp);
2282             for (mark = newsp + 1; mark <= SP; mark++) {
2283                 if (SvTEMP(*mark))
2284                     /* empty */ ;
2285                 else if (SvFLAGS(*mark) & (SVs_PADTMP | SVf_READONLY))
2286                     *mark = sv_mortalcopy(*mark);
2287                 else {
2288                     /* Can be a localized value subject to deletion. */
2289                     PL_tmps_stack[++PL_tmps_ix] = *mark;
2290                     (void)SvREFCNT_inc(*mark);
2291                 }
2292             }
2293         }
2294     }
2295     else if (cx->blk_sub.lval) {     /* Leave it as it is if we can. */
2296         /* Here we go for robustness, not for speed, so we change all
2297          * the refcounts so the caller gets a live guy. Cannot set
2298          * TEMP, so sv_2mortal is out of question. */
2299         if (!CvLVALUE(cx->blk_sub.cv)) {
2300             POPSUB(cx,sv);
2301             PL_curpm = newpm;
2302             LEAVE;
2303             LEAVESUB(sv);
2304             DIE(aTHX_ "Can't modify non-lvalue subroutine call");
2305         }
2306         if (gimme == G_SCALAR) {
2307             MARK = newsp + 1;
2308             EXTEND_MORTAL(1);
2309             if (MARK == SP) {
2310                 if (SvFLAGS(TOPs) & (SVs_TEMP | SVs_PADTMP | SVf_READONLY)) {
2311                     POPSUB(cx,sv);
2312                     PL_curpm = newpm;
2313                     LEAVE;
2314                     LEAVESUB(sv);
2315                     DIE(aTHX_ "Can't return a %s from lvalue subroutine",
2316                         SvREADONLY(TOPs) ? "readonly value" : "temporary");
2317                 }
2318                 else {                  /* Can be a localized value
2319                                          * subject to deletion. */
2320                     PL_tmps_stack[++PL_tmps_ix] = *mark;
2321                     (void)SvREFCNT_inc(*mark);
2322                 }
2323             }
2324             else {                      /* Should not happen? */
2325                 POPSUB(cx,sv);
2326                 PL_curpm = newpm;
2327                 LEAVE;
2328                 LEAVESUB(sv);
2329                 DIE(aTHX_ "%s returned from lvalue subroutine in scalar context",
2330                     (MARK > SP ? "Empty array" : "Array"));
2331             }
2332             SP = MARK;
2333         }
2334         else if (gimme == G_ARRAY) {
2335             EXTEND_MORTAL(SP - newsp);
2336             for (mark = newsp + 1; mark <= SP; mark++) {
2337                 if (*mark != &PL_sv_undef
2338                     && SvFLAGS(*mark) & (SVs_TEMP | SVs_PADTMP | SVf_READONLY)) {
2339                     /* Might be flattened array after $#array =  */
2340                     PUTBACK;
2341                     POPSUB(cx,sv);
2342                     PL_curpm = newpm;
2343                     LEAVE;
2344                     LEAVESUB(sv);
2345                     DIE(aTHX_ "Can't return a %s from lvalue subroutine",
2346                         SvREADONLY(TOPs) ? "readonly value" : "temporary");
2347                 }
2348                 else {
2349                     /* Can be a localized value subject to deletion. */
2350                     PL_tmps_stack[++PL_tmps_ix] = *mark;
2351                     (void)SvREFCNT_inc(*mark);
2352                 }
2353             }
2354         }
2355     }
2356     else {
2357         if (gimme == G_SCALAR) {
2358           temporise:
2359             MARK = newsp + 1;
2360             if (MARK <= SP) {
2361                 if (cx->blk_sub.cv && CvDEPTH(cx->blk_sub.cv) > 1) {
2362                     if (SvTEMP(TOPs)) {
2363                         *MARK = SvREFCNT_inc(TOPs);
2364                         FREETMPS;
2365                         sv_2mortal(*MARK);
2366                     }
2367                     else {
2368                         sv = SvREFCNT_inc(TOPs); /* FREETMPS could clobber it */
2369                         FREETMPS;
2370                         *MARK = sv_mortalcopy(sv);
2371                         SvREFCNT_dec(sv);
2372                     }
2373                 }
2374                 else
2375                     *MARK = SvTEMP(TOPs) ? TOPs : sv_mortalcopy(TOPs);
2376             }
2377             else {
2378                 MEXTEND(MARK, 0);
2379                 *MARK = &PL_sv_undef;
2380             }
2381             SP = MARK;
2382         }
2383         else if (gimme == G_ARRAY) {
2384           temporise_array:
2385             for (MARK = newsp + 1; MARK <= SP; MARK++) {
2386                 if (!SvTEMP(*MARK)) {
2387                     *MARK = sv_mortalcopy(*MARK);
2388                     TAINT_NOT;  /* Each item is independent */
2389                 }
2390             }
2391         }
2392     }
2393     PUTBACK;
2394
2395     POPSUB(cx,sv);      /* Stack values are safe: release CV and @_ ... */
2396     PL_curpm = newpm;   /* ... and pop $1 et al */
2397
2398     LEAVE;
2399     LEAVESUB(sv);
2400     return pop_return();
2401 }
2402
2403
2404 STATIC CV *
2405 S_get_db_sub(pTHX_ SV **svp, CV *cv)
2406 {
2407     SV *dbsv = GvSV(PL_DBsub);
2408
2409     if (!PERLDB_SUB_NN) {
2410         GV *gv = CvGV(cv);
2411
2412         save_item(dbsv);
2413         if ( (CvFLAGS(cv) & (CVf_ANON | CVf_CLONED))
2414              || strEQ(GvNAME(gv), "END")
2415              || ((GvCV(gv) != cv) && /* Could be imported, and old sub redefined. */
2416                  !( (SvTYPE(*svp) == SVt_PVGV) && (GvCV((GV*)*svp) == cv)
2417                     && (gv = (GV*)*svp) ))) {
2418             /* Use GV from the stack as a fallback. */
2419             /* GV is potentially non-unique, or contain different CV. */
2420             SV *tmp = newRV((SV*)cv);
2421             sv_setsv(dbsv, tmp);
2422             SvREFCNT_dec(tmp);
2423         }
2424         else {
2425             gv_efullname3(dbsv, gv, Nullch);
2426         }
2427     }
2428     else {
2429         (void)SvUPGRADE(dbsv, SVt_PVIV);
2430         (void)SvIOK_on(dbsv);
2431         SAVEIV(SvIVX(dbsv));
2432         SvIVX(dbsv) = PTR2IV(cv);       /* Do it the quickest way  */
2433     }
2434
2435     if (CvXSUB(cv))
2436         PL_curcopdb = PL_curcop;
2437     cv = GvCV(PL_DBsub);
2438     return cv;
2439 }
2440
2441 PP(pp_entersub)
2442 {
2443     dSP; dPOPss;
2444     GV *gv;
2445     HV *stash;
2446     register CV *cv;
2447     register PERL_CONTEXT *cx;
2448     I32 gimme;
2449     bool hasargs = (PL_op->op_flags & OPf_STACKED) != 0;
2450
2451     if (!sv)
2452         DIE(aTHX_ "Not a CODE reference");
2453     switch (SvTYPE(sv)) {
2454     default:
2455         if (!SvROK(sv)) {
2456             char *sym;
2457             STRLEN n_a;
2458
2459             if (sv == &PL_sv_yes) {             /* unfound import, ignore */
2460                 if (hasargs)
2461                     SP = PL_stack_base + POPMARK;
2462                 RETURN;
2463             }
2464             if (SvGMAGICAL(sv)) {
2465                 mg_get(sv);
2466                 if (SvROK(sv))
2467                     goto got_rv;
2468                 sym = SvPOKp(sv) ? SvPVX(sv) : Nullch;
2469             }
2470             else
2471                 sym = SvPV(sv, n_a);
2472             if (!sym)
2473                 DIE(aTHX_ PL_no_usym, "a subroutine");
2474             if (PL_op->op_private & HINT_STRICT_REFS)
2475                 DIE(aTHX_ PL_no_symref, sym, "a subroutine");
2476             cv = get_cv(sym, TRUE);
2477             break;
2478         }
2479   got_rv:
2480         {
2481             SV **sp = &sv;              /* Used in tryAMAGICunDEREF macro. */
2482             tryAMAGICunDEREF(to_cv);
2483         }
2484         cv = (CV*)SvRV(sv);
2485         if (SvTYPE(cv) == SVt_PVCV)
2486             break;
2487         /* FALL THROUGH */
2488     case SVt_PVHV:
2489     case SVt_PVAV:
2490         DIE(aTHX_ "Not a CODE reference");
2491     case SVt_PVCV:
2492         cv = (CV*)sv;
2493         break;
2494     case SVt_PVGV:
2495         if (!(cv = GvCVu((GV*)sv)))
2496             cv = sv_2cv(sv, &stash, &gv, FALSE);
2497         if (!cv) {
2498             ENTER;
2499             SAVETMPS;
2500             goto try_autoload;
2501         }
2502         break;
2503     }
2504
2505     ENTER;
2506     SAVETMPS;
2507
2508   retry:
2509     if (!CvROOT(cv) && !CvXSUB(cv)) {
2510         GV* autogv;
2511         SV* sub_name;
2512
2513         /* anonymous or undef'd function leaves us no recourse */
2514         if (CvANON(cv) || !(gv = CvGV(cv)))
2515             DIE(aTHX_ "Undefined subroutine called");
2516
2517         /* autoloaded stub? */
2518         if (cv != GvCV(gv)) {
2519             cv = GvCV(gv);
2520         }
2521         /* should call AUTOLOAD now? */
2522         else {
2523 try_autoload:
2524             if ((autogv = gv_autoload4(GvSTASH(gv), GvNAME(gv), GvNAMELEN(gv),
2525                                    FALSE)))
2526             {
2527                 cv = GvCV(autogv);
2528             }
2529             /* sorry */
2530             else {
2531                 sub_name = sv_newmortal();
2532                 gv_efullname3(sub_name, gv, Nullch);
2533                 DIE(aTHX_ "Undefined subroutine &%s called", SvPVX(sub_name));
2534             }
2535         }
2536         if (!cv)
2537             DIE(aTHX_ "Not a CODE reference");
2538         goto retry;
2539     }
2540
2541     gimme = GIMME_V;
2542     if ((PL_op->op_private & OPpENTERSUB_DB) && GvCV(PL_DBsub) && !CvNODEBUG(cv)) {
2543         cv = get_db_sub(&sv, cv);
2544         if (!cv)
2545             DIE(aTHX_ "No DBsub routine");
2546     }
2547
2548 #ifdef USE_5005THREADS
2549     /*
2550      * First we need to check if the sub or method requires locking.
2551      * If so, we gain a lock on the CV, the first argument or the
2552      * stash (for static methods), as appropriate. This has to be
2553      * inline because for FAKE_THREADS, COND_WAIT inlines code to
2554      * reschedule by returning a new op.
2555      */
2556     MUTEX_LOCK(CvMUTEXP(cv));
2557     if (CvFLAGS(cv) & CVf_LOCKED) {
2558         MAGIC *mg;
2559         if (CvFLAGS(cv) & CVf_METHOD) {
2560             if (SP > PL_stack_base + TOPMARK)
2561                 sv = *(PL_stack_base + TOPMARK + 1);
2562             else {
2563                 AV *av = (AV*)PL_curpad[0];
2564                 if (hasargs || !av || AvFILLp(av) < 0
2565                     || !(sv = AvARRAY(av)[0]))
2566                 {
2567                     MUTEX_UNLOCK(CvMUTEXP(cv));
2568                     DIE(aTHX_ "no argument for locked method call");
2569                 }
2570             }
2571             if (SvROK(sv))
2572                 sv = SvRV(sv);
2573             else {
2574                 STRLEN len;
2575                 char *stashname = SvPV(sv, len);
2576                 sv = (SV*)gv_stashpvn(stashname, len, TRUE);
2577             }
2578         }
2579         else {
2580             sv = (SV*)cv;
2581         }
2582         MUTEX_UNLOCK(CvMUTEXP(cv));
2583         mg = condpair_magic(sv);
2584         MUTEX_LOCK(MgMUTEXP(mg));
2585         if (MgOWNER(mg) == thr)
2586             MUTEX_UNLOCK(MgMUTEXP(mg));
2587         else {
2588             while (MgOWNER(mg))
2589                 COND_WAIT(MgOWNERCONDP(mg), MgMUTEXP(mg));
2590             MgOWNER(mg) = thr;
2591             DEBUG_S(PerlIO_printf(Perl_debug_log, "%p: pp_entersub lock %p\n",
2592                                   thr, sv));
2593             MUTEX_UNLOCK(MgMUTEXP(mg));
2594             SAVEDESTRUCTOR_X(Perl_unlock_condpair, sv);
2595         }
2596         MUTEX_LOCK(CvMUTEXP(cv));
2597     }
2598     /*
2599      * Now we have permission to enter the sub, we must distinguish
2600      * four cases. (0) It's an XSUB (in which case we don't care
2601      * about ownership); (1) it's ours already (and we're recursing);
2602      * (2) it's free (but we may already be using a cached clone);
2603      * (3) another thread owns it. Case (1) is easy: we just use it.
2604      * Case (2) means we look for a clone--if we have one, use it
2605      * otherwise grab ownership of cv. Case (3) means we look for a
2606      * clone (for non-XSUBs) and have to create one if we don't
2607      * already have one.
2608      * Why look for a clone in case (2) when we could just grab
2609      * ownership of cv straight away? Well, we could be recursing,
2610      * i.e. we originally tried to enter cv while another thread
2611      * owned it (hence we used a clone) but it has been freed up
2612      * and we're now recursing into it. It may or may not be "better"
2613      * to use the clone but at least CvDEPTH can be trusted.
2614      */
2615     if (CvOWNER(cv) == thr || CvXSUB(cv))
2616         MUTEX_UNLOCK(CvMUTEXP(cv));
2617     else {
2618         /* Case (2) or (3) */
2619         SV **svp;
2620
2621         /*
2622          * XXX Might it be better to release CvMUTEXP(cv) while we
2623          * do the hv_fetch? We might find someone has pinched it
2624          * when we look again, in which case we would be in case
2625          * (3) instead of (2) so we'd have to clone. Would the fact
2626          * that we released the mutex more quickly make up for this?
2627          */
2628         if ((svp = hv_fetch(thr->cvcache, (char *)cv, sizeof(cv), FALSE)))
2629         {
2630             /* We already have a clone to use */
2631             MUTEX_UNLOCK(CvMUTEXP(cv));
2632             cv = *(CV**)svp;
2633             DEBUG_S(PerlIO_printf(Perl_debug_log,
2634                                   "entersub: %p already has clone %p:%s\n",
2635                                   thr, cv, SvPEEK((SV*)cv)));
2636             CvOWNER(cv) = thr;
2637             SvREFCNT_inc(cv);
2638             if (CvDEPTH(cv) == 0)
2639                 SAVEDESTRUCTOR_X(unset_cvowner, (void*) cv);
2640         }
2641         else {
2642             /* (2) => grab ownership of cv. (3) => make clone */
2643             if (!CvOWNER(cv)) {
2644                 CvOWNER(cv) = thr;
2645                 SvREFCNT_inc(cv);
2646                 MUTEX_UNLOCK(CvMUTEXP(cv));
2647                 DEBUG_S(PerlIO_printf(Perl_debug_log,
2648                             "entersub: %p grabbing %p:%s in stash %s\n",
2649                             thr, cv, SvPEEK((SV*)cv), CvSTASH(cv) ?
2650                                 HvNAME(CvSTASH(cv)) : "(none)"));
2651             }
2652             else {
2653                 /* Make a new clone. */
2654                 CV *clonecv;
2655                 SvREFCNT_inc(cv); /* don't let it vanish from under us */
2656                 MUTEX_UNLOCK(CvMUTEXP(cv));
2657                 DEBUG_S((PerlIO_printf(Perl_debug_log,
2658                                        "entersub: %p cloning %p:%s\n",
2659                                        thr, cv, SvPEEK((SV*)cv))));
2660                 /*
2661                  * We're creating a new clone so there's no race
2662                  * between the original MUTEX_UNLOCK and the
2663                  * SvREFCNT_inc since no one will be trying to undef
2664                  * it out from underneath us. At least, I don't think
2665                  * there's a race...
2666                  */
2667                 clonecv = cv_clone(cv);
2668                 SvREFCNT_dec(cv); /* finished with this */
2669                 hv_store(thr->cvcache, (char*)cv, sizeof(cv), (SV*)clonecv,0);
2670                 CvOWNER(clonecv) = thr;
2671                 cv = clonecv;
2672                 SvREFCNT_inc(cv);
2673             }
2674             DEBUG_S(if (CvDEPTH(cv) != 0)
2675                         PerlIO_printf(Perl_debug_log, "depth %ld != 0\n",
2676                                      CvDEPTH(cv)));
2677             SAVEDESTRUCTOR_X(unset_cvowner, (void*) cv);
2678         }
2679     }
2680 #endif /* USE_5005THREADS */
2681
2682     if (CvXSUB(cv)) {
2683 #ifdef PERL_XSUB_OLDSTYLE
2684         if (CvOLDSTYLE(cv)) {
2685             I32 (*fp3)(int,int,int);
2686             dMARK;
2687             register I32 items = SP - MARK;
2688                                         /* We dont worry to copy from @_. */
2689             while (SP > mark) {
2690                 SP[1] = SP[0];
2691                 SP--;
2692             }
2693             PL_stack_sp = mark + 1;
2694             fp3 = (I32(*)(int,int,int))CvXSUB(cv);
2695             items = (*fp3)(CvXSUBANY(cv).any_i32,
2696                            MARK - PL_stack_base + 1,
2697                            items);
2698             PL_stack_sp = PL_stack_base + items;
2699         }
2700         else
2701 #endif /* PERL_XSUB_OLDSTYLE */
2702         {
2703             I32 markix = TOPMARK;
2704
2705             PUTBACK;
2706
2707             if (!hasargs) {
2708                 /* Need to copy @_ to stack. Alternative may be to
2709                  * switch stack to @_, and copy return values
2710                  * back. This would allow popping @_ in XSUB, e.g.. XXXX */
2711                 AV* av;
2712                 I32 items;
2713 #ifdef USE_5005THREADS
2714                 av = (AV*)PL_curpad[0];
2715 #else
2716                 av = GvAV(PL_defgv);
2717 #endif /* USE_5005THREADS */
2718                 items = AvFILLp(av) + 1;   /* @_ is not tieable */
2719
2720                 if (items) {
2721                     /* Mark is at the end of the stack. */
2722                     EXTEND(SP, items);
2723                     Copy(AvARRAY(av), SP + 1, items, SV*);
2724                     SP += items;
2725                     PUTBACK ;
2726                 }
2727             }
2728             /* We assume first XSUB in &DB::sub is the called one. */
2729             if (PL_curcopdb) {
2730                 SAVEVPTR(PL_curcop);
2731                 PL_curcop = PL_curcopdb;
2732                 PL_curcopdb = NULL;
2733             }
2734             /* Do we need to open block here? XXXX */
2735             (void)(*CvXSUB(cv))(aTHX_ cv);
2736
2737             /* Enforce some sanity in scalar context. */
2738             if (gimme == G_SCALAR && ++markix != PL_stack_sp - PL_stack_base ) {
2739                 if (markix > PL_stack_sp - PL_stack_base)
2740                     *(PL_stack_base + markix) = &PL_sv_undef;
2741                 else
2742                     *(PL_stack_base + markix) = *PL_stack_sp;
2743                 PL_stack_sp = PL_stack_base + markix;
2744             }
2745         }
2746         LEAVE;
2747         return NORMAL;
2748     }
2749     else {
2750         dMARK;
2751         register I32 items = SP - MARK;
2752         AV* padlist = CvPADLIST(cv);
2753         SV** svp = AvARRAY(padlist);
2754         push_return(PL_op->op_next);
2755         PUSHBLOCK(cx, CXt_SUB, MARK);
2756         PUSHSUB(cx);
2757         CvDEPTH(cv)++;
2758         /* XXX This would be a natural place to set C<PL_compcv = cv> so
2759          * that eval'' ops within this sub know the correct lexical space.
2760          * Owing the speed considerations, we choose to search for the cv
2761          * in doeval() instead.
2762          */
2763         if (CvDEPTH(cv) < 2)
2764             (void)SvREFCNT_inc(cv);
2765         else {  /* save temporaries on recursion? */
2766             PERL_STACK_OVERFLOW_CHECK();
2767             if (CvDEPTH(cv) > AvFILLp(padlist)) {
2768                 AV *av;
2769                 AV *newpad = newAV();
2770                 SV **oldpad = AvARRAY(svp[CvDEPTH(cv)-1]);
2771                 I32 ix = AvFILLp((AV*)svp[1]);
2772                 I32 names_fill = AvFILLp((AV*)svp[0]);
2773                 svp = AvARRAY(svp[0]);
2774                 for ( ;ix > 0; ix--) {
2775                     if (names_fill >= ix && svp[ix] != &PL_sv_undef) {
2776                         char *name = SvPVX(svp[ix]);
2777                         if ((SvFLAGS(svp[ix]) & SVf_FAKE) /* outer lexical? */
2778                             || *name == '&')              /* anonymous code? */
2779                         {
2780                             av_store(newpad, ix, SvREFCNT_inc(oldpad[ix]));
2781                         }
2782                         else {                          /* our own lexical */
2783                             if (*name == '@')
2784                                 av_store(newpad, ix, sv = (SV*)newAV());
2785                             else if (*name == '%')
2786                                 av_store(newpad, ix, sv = (SV*)newHV());
2787                             else
2788                                 av_store(newpad, ix, sv = NEWSV(0,0));
2789                             SvPADMY_on(sv);
2790                         }
2791                     }
2792                     else if (IS_PADGV(oldpad[ix]) || IS_PADCONST(oldpad[ix])) {
2793                         av_store(newpad, ix, sv = SvREFCNT_inc(oldpad[ix]));
2794                     }
2795                     else {
2796                         av_store(newpad, ix, sv = NEWSV(0,0));
2797                         SvPADTMP_on(sv);
2798                     }
2799                 }
2800                 av = newAV();           /* will be @_ */
2801                 av_extend(av, 0);
2802                 av_store(newpad, 0, (SV*)av);
2803                 AvFLAGS(av) = AVf_REIFY;
2804                 av_store(padlist, CvDEPTH(cv), (SV*)newpad);
2805                 AvFILLp(padlist) = CvDEPTH(cv);
2806                 svp = AvARRAY(padlist);
2807             }
2808         }
2809 #ifdef USE_5005THREADS
2810         if (!hasargs) {
2811             AV* av = (AV*)PL_curpad[0];
2812
2813             items = AvFILLp(av) + 1;
2814             if (items) {
2815                 /* Mark is at the end of the stack. */
2816                 EXTEND(SP, items);
2817                 Copy(AvARRAY(av), SP + 1, items, SV*);
2818                 SP += items;
2819                 PUTBACK ;
2820             }
2821         }
2822 #endif /* USE_5005THREADS */
2823         SAVEVPTR(PL_curpad);
2824         PL_curpad = AvARRAY((AV*)svp[CvDEPTH(cv)]);
2825 #ifndef USE_5005THREADS
2826         if (hasargs)
2827 #endif /* USE_5005THREADS */
2828         {
2829             AV* av;
2830             SV** ary;
2831
2832 #if 0
2833             DEBUG_S(PerlIO_printf(Perl_debug_log,
2834                                   "%p entersub preparing @_\n", thr));
2835 #endif
2836             av = (AV*)PL_curpad[0];
2837             if (AvREAL(av)) {
2838                 /* @_ is normally not REAL--this should only ever
2839                  * happen when DB::sub() calls things that modify @_ */
2840                 av_clear(av);
2841                 AvREAL_off(av);
2842                 AvREIFY_on(av);
2843             }
2844 #ifndef USE_5005THREADS
2845             cx->blk_sub.savearray = GvAV(PL_defgv);
2846             GvAV(PL_defgv) = (AV*)SvREFCNT_inc(av);
2847 #endif /* USE_5005THREADS */
2848             cx->blk_sub.oldcurpad = PL_curpad;
2849             cx->blk_sub.argarray = av;
2850             ++MARK;
2851
2852             if (items > AvMAX(av) + 1) {
2853                 ary = AvALLOC(av);
2854                 if (AvARRAY(av) != ary) {
2855                     AvMAX(av) += AvARRAY(av) - AvALLOC(av);
2856                     SvPVX(av) = (char*)ary;
2857                 }
2858                 if (items > AvMAX(av) + 1) {
2859                     AvMAX(av) = items - 1;
2860                     Renew(ary,items,SV*);
2861                     AvALLOC(av) = ary;
2862                     SvPVX(av) = (char*)ary;
2863                 }
2864             }
2865             Copy(MARK,AvARRAY(av),items,SV*);
2866             AvFILLp(av) = items - 1;
2867
2868             while (items--) {
2869                 if (*MARK)
2870                     SvTEMP_off(*MARK);
2871                 MARK++;
2872             }
2873         }
2874         /* warning must come *after* we fully set up the context
2875          * stuff so that __WARN__ handlers can safely dounwind()
2876          * if they want to
2877          */
2878         if (CvDEPTH(cv) == 100 && ckWARN(WARN_RECURSION)
2879             && !(PERLDB_SUB && cv == GvCV(PL_DBsub)))
2880             sub_crush_depth(cv);
2881 #if 0
2882         DEBUG_S(PerlIO_printf(Perl_debug_log,
2883                               "%p entersub returning %p\n", thr, CvSTART(cv)));
2884 #endif
2885         RETURNOP(CvSTART(cv));
2886     }
2887 }
2888
2889 void
2890 Perl_sub_crush_depth(pTHX_ CV *cv)
2891 {
2892     if (CvANON(cv))
2893         Perl_warner(aTHX_ WARN_RECURSION, "Deep recursion on anonymous subroutine");
2894     else {
2895         SV* tmpstr = sv_newmortal();
2896         gv_efullname3(tmpstr, CvGV(cv), Nullch);
2897         Perl_warner(aTHX_ WARN_RECURSION, "Deep recursion on subroutine \"%s\"",
2898                 SvPVX(tmpstr));
2899     }
2900 }
2901
2902 PP(pp_aelem)
2903 {
2904     dSP;
2905     SV** svp;
2906     SV* elemsv = POPs;
2907     IV elem = SvIV(elemsv);
2908     AV* av = (AV*)POPs;
2909     U32 lval = PL_op->op_flags & OPf_MOD || LVRET;
2910     U32 defer = (PL_op->op_private & OPpLVAL_DEFER) && (elem > AvFILL(av));
2911     SV *sv;
2912
2913     if (SvROK(elemsv) && !SvGAMAGIC(elemsv) && ckWARN(WARN_MISC))
2914         Perl_warner(aTHX_ WARN_MISC, "Use of reference \"%s\" as array index", SvPV_nolen(elemsv));
2915     if (elem > 0)
2916         elem -= PL_curcop->cop_arybase;
2917     if (SvTYPE(av) != SVt_PVAV)
2918         RETPUSHUNDEF;
2919     svp = av_fetch(av, elem, lval && !defer);
2920     if (lval) {
2921         if (!svp || *svp == &PL_sv_undef) {
2922             SV* lv;
2923             if (!defer)
2924                 DIE(aTHX_ PL_no_aelem, elem);
2925             lv = sv_newmortal();
2926             sv_upgrade(lv, SVt_PVLV);
2927             LvTYPE(lv) = 'y';
2928             sv_magic(lv, Nullsv, PERL_MAGIC_defelem, Nullch, 0);
2929             LvTARG(lv) = SvREFCNT_inc(av);
2930             LvTARGOFF(lv) = elem;
2931             LvTARGLEN(lv) = 1;
2932             PUSHs(lv);
2933             RETURN;
2934         }
2935         if (PL_op->op_private & OPpLVAL_INTRO)
2936             save_aelem(av, elem, svp);
2937         else if (PL_op->op_private & OPpDEREF)
2938             vivify_ref(*svp, PL_op->op_private & OPpDEREF);
2939     }
2940     sv = (svp ? *svp : &PL_sv_undef);
2941     if (!lval && SvGMAGICAL(sv))        /* see note in pp_helem() */
2942         sv = sv_mortalcopy(sv);
2943     PUSHs(sv);
2944     RETURN;
2945 }
2946
2947 void
2948 Perl_vivify_ref(pTHX_ SV *sv, U32 to_what)
2949 {
2950     if (SvGMAGICAL(sv))
2951         mg_get(sv);
2952     if (!SvOK(sv)) {
2953         if (SvREADONLY(sv))
2954             Perl_croak(aTHX_ PL_no_modify);
2955         if (SvTYPE(sv) < SVt_RV)
2956             sv_upgrade(sv, SVt_RV);
2957         else if (SvTYPE(sv) >= SVt_PV) {
2958             (void)SvOOK_off(sv);
2959             Safefree(SvPVX(sv));
2960             SvLEN(sv) = SvCUR(sv) = 0;
2961         }
2962         switch (to_what) {
2963         case OPpDEREF_SV:
2964             SvRV(sv) = NEWSV(355,0);
2965             break;
2966         case OPpDEREF_AV:
2967             SvRV(sv) = (SV*)newAV();
2968             break;
2969         case OPpDEREF_HV:
2970             SvRV(sv) = (SV*)newHV();
2971             break;
2972         }
2973         SvROK_on(sv);
2974         SvSETMAGIC(sv);
2975     }
2976 }
2977
2978 PP(pp_method)
2979 {
2980     dSP;
2981     SV* sv = TOPs;
2982
2983     if (SvROK(sv)) {
2984         SV* rsv = SvRV(sv);
2985         if (SvTYPE(rsv) == SVt_PVCV) {
2986             SETs(rsv);
2987             RETURN;
2988         }
2989     }
2990
2991     SETs(method_common(sv, Null(U32*)));
2992     RETURN;
2993 }
2994
2995 PP(pp_method_named)
2996 {
2997     dSP;
2998     SV* sv = cSVOP->op_sv;
2999     U32 hash = SvUVX(sv);
3000
3001     XPUSHs(method_common(sv, &hash));
3002     RETURN;
3003 }
3004
3005 STATIC SV *
3006 S_method_common(pTHX_ SV* meth, U32* hashp)
3007 {
3008     SV* sv;
3009     SV* ob;
3010     GV* gv;
3011     HV* stash;
3012     char* name;
3013     STRLEN namelen;
3014     char* packname = 0;
3015     STRLEN packlen;
3016
3017     name = SvPV(meth, namelen);
3018     sv = *(PL_stack_base + TOPMARK + 1);
3019
3020     if (!sv)
3021         Perl_croak(aTHX_ "Can't call method \"%s\" on an undefined value", name);
3022
3023     if (SvGMAGICAL(sv))
3024         mg_get(sv);
3025     if (SvROK(sv))
3026         ob = (SV*)SvRV(sv);
3027     else {
3028         GV* iogv;
3029
3030         /* this isn't a reference */
3031         packname = Nullch;
3032         if (!SvOK(sv) ||
3033             !(packname = SvPV(sv, packlen)) ||
3034             !(iogv = gv_fetchpv(packname, FALSE, SVt_PVIO)) ||
3035             !(ob=(SV*)GvIO(iogv)))
3036         {
3037             /* this isn't the name of a filehandle either */
3038             if (!packname ||
3039                 ((UTF8_IS_START(*packname) && DO_UTF8(sv))
3040                     ? !isIDFIRST_utf8((U8*)packname)
3041                     : !isIDFIRST(*packname)
3042                 ))
3043             {
3044                 Perl_croak(aTHX_ "Can't call method \"%s\" %s", name,
3045                            SvOK(sv) ? "without a package or object reference"
3046                                     : "on an undefined value");
3047             }
3048             /* assume it's a package name */
3049             stash = gv_stashpvn(packname, packlen, FALSE);
3050             goto fetch;
3051         }
3052         /* it _is_ a filehandle name -- replace with a reference */
3053         *(PL_stack_base + TOPMARK + 1) = sv_2mortal(newRV((SV*)iogv));
3054     }
3055
3056     /* if we got here, ob should be a reference or a glob */
3057     if (!ob || !(SvOBJECT(ob)
3058                  || (SvTYPE(ob) == SVt_PVGV && (ob = (SV*)GvIO((GV*)ob))
3059                      && SvOBJECT(ob))))
3060     {
3061         Perl_croak(aTHX_ "Can't call method \"%s\" on unblessed reference",
3062                    name);
3063     }
3064
3065     stash = SvSTASH(ob);
3066
3067   fetch:
3068     /* NOTE: stash may be null, hope hv_fetch_ent and
3069        gv_fetchmethod can cope (it seems they can) */
3070
3071     /* shortcut for simple names */
3072     if (hashp) {
3073         HE* he = hv_fetch_ent(stash, meth, 0, *hashp);
3074         if (he) {
3075             gv = (GV*)HeVAL(he);
3076             if (isGV(gv) && GvCV(gv) &&
3077                 (!GvCVGEN(gv) || GvCVGEN(gv) == PL_sub_generation))
3078                 return (SV*)GvCV(gv);
3079         }
3080     }
3081
3082     gv = gv_fetchmethod(stash, name);
3083
3084     if (!gv) {
3085         /* This code tries to figure out just what went wrong with
3086            gv_fetchmethod.  It therefore needs to duplicate a lot of
3087            the internals of that function.  We can't move it inside
3088            Perl_gv_fetchmethod_autoload(), however, since that would
3089            cause UNIVERSAL->can("NoSuchPackage::foo") to croak, and we
3090            don't want that.
3091         */
3092         char* leaf = name;
3093         char* sep = Nullch;
3094         char* p;
3095
3096         for (p = name; *p; p++) {
3097             if (*p == '\'')
3098                 sep = p, leaf = p + 1;
3099             else if (*p == ':' && *(p + 1) == ':')
3100                 sep = p, leaf = p + 2;
3101         }
3102         if (!sep || ((sep - name) == 5 && strnEQ(name, "SUPER", 5))) {
3103             /* the method name is unqualified or starts with SUPER:: */
3104             packname = sep ? CopSTASHPV(PL_curcop) :
3105                 stash ? HvNAME(stash) : packname;
3106             packlen = strlen(packname);
3107         }
3108         else {
3109             /* the method name is qualified */
3110             packname = name;
3111             packlen = sep - name;
3112         }
3113
3114         /* we're relying on gv_fetchmethod not autovivifying the stash */
3115         if (gv_stashpvn(packname, packlen, FALSE)) {
3116             Perl_croak(aTHX_
3117                        "Can't locate object method \"%s\" via package \"%.*s\"",
3118                        leaf, (int)packlen, packname);
3119         }
3120         else {
3121             Perl_croak(aTHX_
3122                        "Can't locate object method \"%s\" via package \"%.*s\""
3123                        " (perhaps you forgot to load \"%.*s\"?)",
3124                        leaf, (int)packlen, packname, (int)packlen, packname);
3125         }
3126     }
3127     return isGV(gv) ? (SV*)GvCV(gv) : (SV*)gv;
3128 }
3129
3130 #ifdef USE_5005THREADS
3131 static void
3132 unset_cvowner(pTHX_ void *cvarg)
3133 {
3134     register CV* cv = (CV *) cvarg;
3135
3136     DEBUG_S((PerlIO_printf(Perl_debug_log, "%p unsetting CvOWNER of %p:%s\n",
3137                            thr, cv, SvPEEK((SV*)cv))));
3138     MUTEX_LOCK(CvMUTEXP(cv));
3139     DEBUG_S(if (CvDEPTH(cv) != 0)
3140                 PerlIO_printf(Perl_debug_log, "depth %ld != 0\n",
3141                              CvDEPTH(cv)));
3142     assert(thr == CvOWNER(cv));
3143     CvOWNER(cv) = 0;
3144     MUTEX_UNLOCK(CvMUTEXP(cv));
3145     SvREFCNT_dec(cv);
3146 }
3147 #endif /* USE_5005THREADS */