pp_hot.c

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