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