pp_hot.c

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