pp_hot.c

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