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