pp_hot.c

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