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_PVGV && 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 = PL_op->op_flags & OPf_SPECIAL ?
 525                 (AV*)PAD_SV(PL_op->op_targ) : GvAV(cGVOP_gv);
 526     U32 lval = PL_op->op_flags & OPf_MOD;
 527     SV** svp = av_fetch(av, PL_op->op_private, lval);
 528     SV *sv = (svp ? *svp : &PL_sv_undef);
 529     EXTEND(SP, 1);
 530     if (!lval && SvGMAGICAL(sv))        /* see note in pp_helem() */
 531         sv = sv_mortalcopy(sv);
 532     PUSHs(sv);
 533     RETURN;
 534 }
 535
 536 PP(pp_join)
 537 {
 538     dSP; dMARK; dTARGET;
 539     MARK++;
 540     do_join(TARG, *MARK, MARK, SP);
 541     SP = MARK;
 542     SETs(TARG);
 543     RETURN;
 544 }
 545
 546 PP(pp_pushre)
 547 {
 548     dSP;
 549 #ifdef DEBUGGING
 550     /*
 551      * We ass_u_me that LvTARGOFF() comes first, and that two STRLENs
 552      * will be enough to hold an OP*.
 553      */
 554     SV* sv = sv_newmortal();
 555     sv_upgrade(sv, SVt_PVLV);
 556     LvTYPE(sv) = '/';
 557     Copy(&PL_op, &LvTARGOFF(sv), 1, OP*);
 558     XPUSHs(sv);
 559 #else
 560     XPUSHs((SV*)PL_op);
 561 #endif
 562     RETURN;
 563 }
 564
 565 /* Oversized hot code. */
 566
 567 PP(pp_print)
 568 {
 569     dSP; dMARK; dORIGMARK;
 570     GV *gv;
 571     IO *io;
 572     register PerlIO *fp;
 573     MAGIC *mg;
 574
 575     if (PL_op->op_flags & OPf_STACKED)
 576         gv = (GV*)*++MARK;
 577     else
 578         gv = PL_defoutgv;
 579
 580     if (gv && (io = GvIO(gv))
 581         && (mg = SvTIED_mg((SV*)io, PERL_MAGIC_tiedscalar)))
 582     {
 583       had_magic:
 584         if (MARK == ORIGMARK) {
 585             /* If using default handle then we need to make space to
 586              * pass object as 1st arg, so move other args up ...
 587              */
 588             MEXTEND(SP, 1);
 589             ++MARK;
 590             Move(MARK, MARK + 1, (SP - MARK) + 1, SV*);
 591             ++SP;
 592         }
 593         PUSHMARK(MARK - 1);
 594         *MARK = SvTIED_obj((SV*)io, mg);
 595         PUTBACK;
 596         ENTER;
 597         call_method("PRINT", G_SCALAR);
 598         LEAVE;
 599         SPAGAIN;
 600         MARK = ORIGMARK + 1;
 601         *MARK = *SP;
 602         SP = MARK;
 603         RETURN;
 604     }
 605     if (!(io = GvIO(gv))) {
 606         if ((GvEGV(gv)) && (io = GvIO(GvEGV(gv)))
 607             && (mg = SvTIED_mg((SV*)io, PERL_MAGIC_tiedscalar)))
 608             goto had_magic;
 609         if (ckWARN2(WARN_UNOPENED,WARN_CLOSED))
 610             report_evil_fh(gv, io, PL_op->op_type);
 611         SETERRNO(EBADF,RMS_IFI);
 612         goto just_say_no;
 613     }
 614     else if (!(fp = IoOFP(io))) {
 615         if (ckWARN2(WARN_CLOSED, WARN_IO))  {
 616             if (IoIFP(io))
 617                 report_evil_fh(gv, io, OP_phoney_INPUT_ONLY);
 618             else if (ckWARN2(WARN_UNOPENED,WARN_CLOSED))
 619                 report_evil_fh(gv, io, PL_op->op_type);
 620         }
 621         SETERRNO(EBADF,IoIFP(io)?RMS_FAC:RMS_IFI);
 622         goto just_say_no;
 623     }
 624     else {
 625         MARK++;
 626         if (PL_ofs_sv && SvOK(PL_ofs_sv)) {
 627             while (MARK <= SP) {
 628                 if (!do_print(*MARK, fp))
 629                     break;
 630                 MARK++;
 631                 if (MARK <= SP) {
 632                     if (!do_print(PL_ofs_sv, fp)) { /* $, */
 633                         MARK--;
 634                         break;
 635                     }
 636                 }
 637             }
 638         }
 639         else {
 640             while (MARK <= SP) {
 641                 if (!do_print(*MARK, fp))
 642                     break;
 643                 MARK++;
 644             }
 645         }
 646         if (MARK <= SP)
 647             goto just_say_no;
 648         else {
 649             if (PL_ors_sv && SvOK(PL_ors_sv))
 650                 if (!do_print(PL_ors_sv, fp)) /* $\ */
 651                     goto just_say_no;
 652
 653             if (IoFLAGS(io) & IOf_FLUSH)
 654                 if (PerlIO_flush(fp) == EOF)
 655                     goto just_say_no;
 656         }
 657     }
 658     SP = ORIGMARK;
 659     PUSHs(&PL_sv_yes);
 660     RETURN;
 661
 662   just_say_no:
 663     SP = ORIGMARK;
 664     PUSHs(&PL_sv_undef);
 665     RETURN;
 666 }
 667
 668 PP(pp_rv2av)
 669 {
 670     dSP; dTOPss;
 671     AV *av;
 672
 673     if (SvROK(sv)) {
 674       wasref:
 675         tryAMAGICunDEREF(to_av);
 676
 677         av = (AV*)SvRV(sv);
 678         if (SvTYPE(av) != SVt_PVAV)
 679             DIE(aTHX_ "Not an ARRAY reference");
 680         if (PL_op->op_flags & OPf_REF) {
 681             SETs((SV*)av);
 682             RETURN;
 683         }
 684         else if (LVRET) {
 685             if (GIMME == G_SCALAR)
 686                 Perl_croak(aTHX_ "Can't return array to lvalue scalar context");
 687             SETs((SV*)av);
 688             RETURN;
 689         }
 690         else if (PL_op->op_flags & OPf_MOD
 691                 && PL_op->op_private & OPpLVAL_INTRO)
 692             Perl_croak(aTHX_ PL_no_localize_ref);
 693     }
 694     else {
 695         if (SvTYPE(sv) == SVt_PVAV) {
 696             av = (AV*)sv;
 697             if (PL_op->op_flags & OPf_REF) {
 698                 SETs((SV*)av);
 699                 RETURN;
 700             }
 701             else if (LVRET) {
 702                 if (GIMME == G_SCALAR)
 703                     Perl_croak(aTHX_ "Can't return array to lvalue"
 704                                " scalar context");
 705                 SETs((SV*)av);
 706                 RETURN;
 707             }
 708         }
 709         else {
 710             GV *gv;
 711
 712             if (SvTYPE(sv) != SVt_PVGV) {
 713                 char *sym;
 714                 STRLEN len;
 715
 716                 if (SvGMAGICAL(sv)) {
 717                     mg_get(sv);
 718                     if (SvROK(sv))
 719                         goto wasref;
 720                 }
 721                 if (!SvOK(sv)) {
 722                     if (PL_op->op_flags & OPf_REF ||
 723                       PL_op->op_private & HINT_STRICT_REFS)
 724                         DIE(aTHX_ PL_no_usym, "an ARRAY");
 725                     if (ckWARN(WARN_UNINITIALIZED))
 726                         report_uninit();
 727                     if (GIMME == G_ARRAY) {
 728                         (void)POPs;
 729                         RETURN;
 730                     }
 731                     RETSETUNDEF;
 732                 }
 733                 sym = SvPV(sv,len);
 734                 if ((PL_op->op_flags & OPf_SPECIAL) &&
 735                     !(PL_op->op_flags & OPf_MOD))
 736                 {
 737                     gv = (GV*)gv_fetchpv(sym, FALSE, SVt_PVAV);
 738                     if (!gv
 739                         && (!is_gv_magical(sym,len,0)
 740                             || !(gv = (GV*)gv_fetchpv(sym, TRUE, SVt_PVAV))))
 741                     {
 742                         RETSETUNDEF;
 743                     }
 744                 }
 745                 else {
 746                     if (PL_op->op_private & HINT_STRICT_REFS)
 747                         DIE(aTHX_ PL_no_symref, sym, "an ARRAY");
 748                     gv = (GV*)gv_fetchpv(sym, TRUE, SVt_PVAV);
 749                 }
 750             }
 751             else {
 752                 gv = (GV*)sv;
 753             }
 754             av = GvAVn(gv);
 755             if (PL_op->op_private & OPpLVAL_INTRO)
 756                 av = save_ary(gv);
 757             if (PL_op->op_flags & OPf_REF) {
 758                 SETs((SV*)av);
 759                 RETURN;
 760             }
 761             else if (LVRET) {
 762                 if (GIMME == G_SCALAR)
 763                     Perl_croak(aTHX_ "Can't return array to lvalue"
 764                                " scalar context");
 765                 SETs((SV*)av);
 766                 RETURN;
 767             }
 768         }
 769     }
 770
 771     if (GIMME == G_ARRAY) {
 772         I32 maxarg = AvFILL(av) + 1;
 773         (void)POPs;                     /* XXXX May be optimized away? */
 774         EXTEND(SP, maxarg);
 775         if (SvRMAGICAL(av)) {
 776             U32 i;
 777             for (i=0; i < (U32)maxarg; i++) {
 778                 SV **svp = av_fetch(av, i, FALSE);
 779                 SP[i+1] = (svp) ? *svp : &PL_sv_undef;
 780             }
 781         }
 782         else {
 783             Copy(AvARRAY(av), SP+1, maxarg, SV*);
 784         }
 785         SP += maxarg;
 786     }
 787     else if (GIMME_V == G_SCALAR) {
 788         dTARGET;
 789         I32 maxarg = AvFILL(av) + 1;
 790         SETi(maxarg);
 791     }
 792     RETURN;
 793 }
 794
 795 PP(pp_rv2hv)
 796 {
 797     dSP; dTOPss;
 798     HV *hv;
 799     I32 gimme = GIMME_V;
 800
 801     if (SvROK(sv)) {
 802       wasref:
 803         tryAMAGICunDEREF(to_hv);
 804
 805         hv = (HV*)SvRV(sv);
 806         if (SvTYPE(hv) != SVt_PVHV)
 807             DIE(aTHX_ "Not a HASH reference");
 808         if (PL_op->op_flags & OPf_REF) {
 809             SETs((SV*)hv);
 810             RETURN;
 811         }
 812         else if (LVRET) {
 813             if (gimme != G_ARRAY)
 814                 Perl_croak(aTHX_ "Can't return hash to lvalue scalar context");
 815             SETs((SV*)hv);
 816             RETURN;
 817         }
 818         else if (PL_op->op_flags & OPf_MOD
 819                 && PL_op->op_private & OPpLVAL_INTRO)
 820             Perl_croak(aTHX_ PL_no_localize_ref);
 821     }
 822     else {
 823         if (SvTYPE(sv) == SVt_PVHV) {
 824             hv = (HV*)sv;
 825             if (PL_op->op_flags & OPf_REF) {
 826                 SETs((SV*)hv);
 827                 RETURN;
 828             }
 829             else if (LVRET) {
 830                 if (gimme != G_ARRAY)
 831                     Perl_croak(aTHX_ "Can't return hash to lvalue"
 832                                " scalar context");
 833                 SETs((SV*)hv);
 834                 RETURN;
 835             }
 836         }
 837         else {
 838             GV *gv;
 839
 840             if (SvTYPE(sv) != SVt_PVGV) {
 841                 char *sym;
 842                 STRLEN len;
 843
 844                 if (SvGMAGICAL(sv)) {
 845                     mg_get(sv);
 846                     if (SvROK(sv))
 847                         goto wasref;
 848                 }
 849                 if (!SvOK(sv)) {
 850                     if (PL_op->op_flags & OPf_REF ||
 851                       PL_op->op_private & HINT_STRICT_REFS)
 852                         DIE(aTHX_ PL_no_usym, "a HASH");
 853                     if (ckWARN(WARN_UNINITIALIZED))
 854                         report_uninit();
 855                     if (gimme == G_ARRAY) {
 856                         SP--;
 857                         RETURN;
 858                     }
 859                     RETSETUNDEF;
 860                 }
 861                 sym = SvPV(sv,len);
 862                 if ((PL_op->op_flags & OPf_SPECIAL) &&
 863                     !(PL_op->op_flags & OPf_MOD))
 864                 {
 865                     gv = (GV*)gv_fetchpv(sym, FALSE, SVt_PVHV);
 866                     if (!gv
 867                         && (!is_gv_magical(sym,len,0)
 868                             || !(gv = (GV*)gv_fetchpv(sym, TRUE, SVt_PVHV))))
 869                     {
 870                         RETSETUNDEF;
 871                     }
 872                 }
 873                 else {
 874                     if (PL_op->op_private & HINT_STRICT_REFS)
 875                         DIE(aTHX_ PL_no_symref, sym, "a HASH");
 876                     gv = (GV*)gv_fetchpv(sym, TRUE, SVt_PVHV);
 877                 }
 878             }
 879             else {
 880                 gv = (GV*)sv;
 881             }
 882             hv = GvHVn(gv);
 883             if (PL_op->op_private & OPpLVAL_INTRO)
 884                 hv = save_hash(gv);
 885             if (PL_op->op_flags & OPf_REF) {
 886                 SETs((SV*)hv);
 887                 RETURN;
 888             }
 889             else if (LVRET) {
 890                 if (gimme != G_ARRAY)
 891                     Perl_croak(aTHX_ "Can't return hash to lvalue"
 892                                " scalar context");
 893                 SETs((SV*)hv);
 894                 RETURN;
 895             }
 896         }
 897     }
 898
 899     if (gimme == G_ARRAY) { /* array wanted */
 900         *PL_stack_sp = (SV*)hv;
 901         return do_kv();
 902     }
 903     else if (gimme == G_SCALAR) {
 904         dTARGET;
 905     TARG = Perl_hv_scalar(aTHX_ hv);
 906         SETTARG;
 907     }
 908     RETURN;
 909 }
 910
 911 STATIC void
 912 S_do_oddball(pTHX_ HV *hash, SV **relem, SV **firstrelem)
 913 {
 914     if (*relem) {
 915         SV *tmpstr;
 916         HE *didstore;
 917
 918         if (ckWARN(WARN_MISC)) {
 919             if (relem == firstrelem &&
 920                 SvROK(*relem) &&
 921                 (SvTYPE(SvRV(*relem)) == SVt_PVAV ||
 922                  SvTYPE(SvRV(*relem)) == SVt_PVHV))
 923             {
 924                 Perl_warner(aTHX_ packWARN(WARN_MISC),
 925                             "Reference found where even-sized list expected");
 926             }
 927             else
 928                 Perl_warner(aTHX_ packWARN(WARN_MISC),
 929                             "Odd number of elements in hash assignment");
 930         }
 931
 932         tmpstr = NEWSV(29,0);
 933         didstore = hv_store_ent(hash,*relem,tmpstr,0);
 934         if (SvMAGICAL(hash)) {
 935             if (SvSMAGICAL(tmpstr))
 936                 mg_set(tmpstr);
 937             if (!didstore)
 938                 sv_2mortal(tmpstr);
 939         }
 940         TAINT_NOT;
 941     }
 942 }
 943
 944 PP(pp_aassign)
 945 {
 946     dSP;
 947     SV **lastlelem = PL_stack_sp;
 948     SV **lastrelem = PL_stack_base + POPMARK;
 949     SV **firstrelem = PL_stack_base + POPMARK + 1;
 950     SV **firstlelem = lastrelem + 1;
 951
 952     register SV **relem;
 953     register SV **lelem;
 954
 955     register SV *sv;
 956     register AV *ary;
 957
 958     I32 gimme;
 959     HV *hash;
 960     I32 i;
 961     int magic;
 962     int duplicates = 0;
 963     SV **firsthashrelem = 0;    /* "= 0" keeps gcc 2.95 quiet  */
 964
 965
 966     PL_delaymagic = DM_DELAY;           /* catch simultaneous items */
 967     gimme = GIMME_V;
 968
 969     /* If there's a common identifier on both sides we have to take
 970      * special care that assigning the identifier on the left doesn't
 971      * clobber a value on the right that's used later in the list.
 972      */
 973     if (PL_op->op_private & (OPpASSIGN_COMMON)) {
 974         EXTEND_MORTAL(lastrelem - firstrelem + 1);
 975         for (relem = firstrelem; relem <= lastrelem; relem++) {
 976             /*SUPPRESS 560*/
 977             if ((sv = *relem)) {
 978                 TAINT_NOT;      /* Each item is independent */
 979                 *relem = sv_mortalcopy(sv);
 980             }
 981         }
 982     }
 983
 984     relem = firstrelem;
 985     lelem = firstlelem;
 986     ary = Null(AV*);
 987     hash = Null(HV*);
 988
 989     while (lelem <= lastlelem) {
 990         TAINT_NOT;              /* Each item stands on its own, taintwise. */
 991         sv = *lelem++;
 992         switch (SvTYPE(sv)) {
 993         case SVt_PVAV:
 994             ary = (AV*)sv;
 995             magic = SvMAGICAL(ary) != 0;
 996             av_clear(ary);
 997             av_extend(ary, lastrelem - relem);
 998             i = 0;
 999             while (relem <= lastrelem) {        /* gobble up all the rest */
1000                 SV **didstore;
1001                 sv = NEWSV(28,0);
1002                 assert(*relem);
1003                 sv_setsv(sv,*relem);
1004                 *(relem++) = sv;
1005                 didstore = av_store(ary,i++,sv);
1006                 if (magic) {
1007                     if (SvSMAGICAL(sv))
1008                         mg_set(sv);
1009                     if (!didstore)
1010                         sv_2mortal(sv);
1011                 }
1012                 TAINT_NOT;
1013             }
1014             break;
1015         case SVt_PVHV: {                                /* normal hash */
1016                 SV *tmpstr;
1017
1018                 hash = (HV*)sv;
1019                 magic = SvMAGICAL(hash) != 0;
1020                 hv_clear(hash);
1021                 firsthashrelem = relem;
1022
1023                 while (relem < lastrelem) {     /* gobble up all the rest */
1024                     HE *didstore;
1025                     if (*relem)
1026                         sv = *(relem++);
1027                     else
1028                         sv = &PL_sv_no, relem++;
1029                     tmpstr = NEWSV(29,0);
1030                     if (*relem)
1031                         sv_setsv(tmpstr,*relem);        /* value */
1032                     *(relem++) = tmpstr;
1033                     if (gimme != G_VOID && hv_exists_ent(hash, sv, 0))
1034                         /* key overwrites an existing entry */
1035                         duplicates += 2;
1036                     didstore = hv_store_ent(hash,sv,tmpstr,0);
1037                     if (magic) {
1038                         if (SvSMAGICAL(tmpstr))
1039                             mg_set(tmpstr);
1040                         if (!didstore)
1041                             sv_2mortal(tmpstr);
1042                     }
1043                     TAINT_NOT;
1044                 }
1045                 if (relem == lastrelem) {
1046                     do_oddball(hash, relem, firstrelem);
1047                     relem++;
1048                 }
1049             }
1050             break;
1051         default:
1052             if (SvIMMORTAL(sv)) {
1053                 if (relem <= lastrelem)
1054                     relem++;
1055                 break;
1056             }
1057             if (relem <= lastrelem) {
1058                 sv_setsv(sv, *relem);
1059                 *(relem++) = sv;
1060             }
1061             else
1062                 sv_setsv(sv, &PL_sv_undef);
1063             SvSETMAGIC(sv);
1064             break;
1065         }
1066     }
1067     if (PL_delaymagic & ~DM_DELAY) {
1068         if (PL_delaymagic & DM_UID) {
1069 #ifdef HAS_SETRESUID
1070             (void)setresuid((PL_delaymagic & DM_RUID) ? PL_uid  : (Uid_t)-1,
1071                             (PL_delaymagic & DM_EUID) ? PL_euid : (Uid_t)-1,
1072                             (Uid_t)-1);
1073 #else
1074 #  ifdef HAS_SETREUID
1075             (void)setreuid((PL_delaymagic & DM_RUID) ? PL_uid  : (Uid_t)-1,
1076                            (PL_delaymagic & DM_EUID) ? PL_euid : (Uid_t)-1);
1077 #  else
1078 #    ifdef HAS_SETRUID
1079             if ((PL_delaymagic & DM_UID) == DM_RUID) {
1080                 (void)setruid(PL_uid);
1081                 PL_delaymagic &= ~DM_RUID;
1082             }
1083 #    endif /* HAS_SETRUID */
1084 #    ifdef HAS_SETEUID
1085             if ((PL_delaymagic & DM_UID) == DM_EUID) {
1086                 (void)seteuid(PL_euid);
1087                 PL_delaymagic &= ~DM_EUID;
1088             }
1089 #    endif /* HAS_SETEUID */
1090             if (PL_delaymagic & DM_UID) {
1091                 if (PL_uid != PL_euid)
1092                     DIE(aTHX_ "No setreuid available");
1093                 (void)PerlProc_setuid(PL_uid);
1094             }
1095 #  endif /* HAS_SETREUID */
1096 #endif /* HAS_SETRESUID */
1097             PL_uid = PerlProc_getuid();
1098             PL_euid = PerlProc_geteuid();
1099         }
1100         if (PL_delaymagic & DM_GID) {
1101 #ifdef HAS_SETRESGID
1102             (void)setresgid((PL_delaymagic & DM_RGID) ? PL_gid  : (Gid_t)-1,
1103                             (PL_delaymagic & DM_EGID) ? PL_egid : (Gid_t)-1,
1104                             (Gid_t)-1);
1105 #else
1106 #  ifdef HAS_SETREGID
1107             (void)setregid((PL_delaymagic & DM_RGID) ? PL_gid  : (Gid_t)-1,
1108                            (PL_delaymagic & DM_EGID) ? PL_egid : (Gid_t)-1);
1109 #  else
1110 #    ifdef HAS_SETRGID
1111             if ((PL_delaymagic & DM_GID) == DM_RGID) {
1112                 (void)setrgid(PL_gid);
1113                 PL_delaymagic &= ~DM_RGID;
1114             }
1115 #    endif /* HAS_SETRGID */
1116 #    ifdef HAS_SETEGID
1117             if ((PL_delaymagic & DM_GID) == DM_EGID) {
1118                 (void)setegid(PL_egid);
1119                 PL_delaymagic &= ~DM_EGID;
1120             }
1121 #    endif /* HAS_SETEGID */
1122             if (PL_delaymagic & DM_GID) {
1123                 if (PL_gid != PL_egid)
1124                     DIE(aTHX_ "No setregid available");
1125                 (void)PerlProc_setgid(PL_gid);
1126             }
1127 #  endif /* HAS_SETREGID */
1128 #endif /* HAS_SETRESGID */
1129             PL_gid = PerlProc_getgid();
1130             PL_egid = PerlProc_getegid();
1131         }
1132         PL_tainting |= (PL_uid && (PL_euid != PL_uid || PL_egid != PL_gid));
1133     }
1134     PL_delaymagic = 0;
1135
1136     if (gimme == G_VOID)
1137         SP = firstrelem - 1;
1138     else if (gimme == G_SCALAR) {
1139         dTARGET;
1140         SP = firstrelem;
1141         SETi(lastrelem - firstrelem + 1 - duplicates);
1142     }
1143     else {
1144         if (ary)
1145             SP = lastrelem;
1146         else if (hash) {
1147             if (duplicates) {
1148                 /* Removes from the stack the entries which ended up as
1149                  * duplicated keys in the hash (fix for [perl #24380]) */
1150                 Move(firsthashrelem + duplicates,
1151                         firsthashrelem, duplicates, SV**);
1152                 lastrelem -= duplicates;
1153             }
1154             SP = lastrelem;
1155         }
1156         else
1157             SP = firstrelem + (lastlelem - firstlelem);
1158         lelem = firstlelem + (relem - firstrelem);
1159         while (relem <= SP)
1160             *relem++ = (lelem <= lastlelem) ? *lelem++ : &PL_sv_undef;
1161     }
1162     RETURN;
1163 }
1164
1165 PP(pp_qr)
1166 {
1167     dSP;
1168     register PMOP *pm = cPMOP;
1169     SV *rv = sv_newmortal();
1170     SV *sv = newSVrv(rv, "Regexp");
1171     if (pm->op_pmdynflags & PMdf_TAINTED)
1172         SvTAINTED_on(rv);
1173     sv_magic(sv,(SV*)ReREFCNT_inc(PM_GETRE(pm)), PERL_MAGIC_qr,0,0);
1174     RETURNX(PUSHs(rv));
1175 }
1176
1177 PP(pp_match)
1178 {
1179     dSP; dTARG;
1180     register PMOP *pm = cPMOP;
1181     PMOP *dynpm = pm;
1182     register char *t;
1183     register char *s;
1184     char *strend;
1185     I32 global;
1186     I32 r_flags = REXEC_CHECKED;
1187     char *truebase;                     /* Start of string  */
1188     register REGEXP *rx = PM_GETRE(pm);
1189     bool rxtainted;
1190     I32 gimme = GIMME;
1191     STRLEN len;
1192     I32 minmatch = 0;
1193     I32 oldsave = PL_savestack_ix;
1194     I32 update_minmatch = 1;
1195     I32 had_zerolen = 0;
1196
1197     if (PL_op->op_flags & OPf_STACKED)
1198         TARG = POPs;
1199     else if (PL_op->op_private & OPpTARGET_MY)
1200         GETTARGET;
1201     else {
1202         TARG = DEFSV;
1203         EXTEND(SP,1);
1204     }
1205
1206     PUTBACK;                            /* EVAL blocks need stack_sp. */
1207     s = SvPV(TARG, len);
1208     strend = s + len;
1209     if (!s)
1210         DIE(aTHX_ "panic: pp_match");
1211     rxtainted = ((pm->op_pmdynflags & PMdf_TAINTED) ||
1212                  (PL_tainted && (pm->op_pmflags & PMf_RETAINT)));
1213     TAINT_NOT;
1214
1215     RX_MATCH_UTF8_set(rx, DO_UTF8(TARG));
1216
1217     /* PMdf_USED is set after a ?? matches once */
1218     if (pm->op_pmdynflags & PMdf_USED) {
1219       failure:
1220         if (gimme == G_ARRAY)
1221             RETURN;
1222         RETPUSHNO;
1223     }
1224
1225     /* empty pattern special-cased to use last successful pattern if possible */
1226     if (!rx->prelen && PL_curpm) {
1227         pm = PL_curpm;
1228         rx = PM_GETRE(pm);
1229     }
1230
1231     if (rx->minlen > (I32)len)
1232         goto failure;
1233
1234     truebase = t = s;
1235
1236     /* XXXX What part of this is needed with true \G-support? */
1237     if ((global = dynpm->op_pmflags & PMf_GLOBAL)) {
1238         rx->startp[0] = -1;
1239         if (SvTYPE(TARG) >= SVt_PVMG && SvMAGIC(TARG)) {
1240             MAGIC* mg = mg_find(TARG, PERL_MAGIC_regex_global);
1241             if (mg && mg->mg_len >= 0) {
1242                 if (!(rx->reganch & ROPT_GPOS_SEEN))
1243                     rx->endp[0] = rx->startp[0] = mg->mg_len;
1244                 else if (rx->reganch & ROPT_ANCH_GPOS) {
1245                     r_flags |= REXEC_IGNOREPOS;
1246                     rx->endp[0] = rx->startp[0] = mg->mg_len;
1247                 }
1248                 minmatch = (mg->mg_flags & MGf_MINMATCH);
1249                 update_minmatch = 0;
1250             }
1251         }
1252     }
1253     if ((!global && rx->nparens)
1254             || SvTEMP(TARG) || PL_sawampersand)
1255         r_flags |= REXEC_COPY_STR;
1256     if (SvSCREAM(TARG))
1257         r_flags |= REXEC_SCREAM;
1258
1259     if ((int)(pm->op_pmflags & PMf_MULTILINE) != PL_multiline) {
1260         SAVEINT(PL_multiline);
1261         PL_multiline = pm->op_pmflags & PMf_MULTILINE;
1262     }
1263
1264 play_it_again:
1265     if (global && rx->startp[0] != -1) {
1266         t = s = rx->endp[0] + truebase;
1267         if ((s + rx->minlen) > strend)
1268             goto nope;
1269         if (update_minmatch++)
1270             minmatch = had_zerolen;
1271     }
1272     if (rx->reganch & RE_USE_INTUIT &&
1273         DO_UTF8(TARG) == ((rx->reganch & ROPT_UTF8) != 0)) {
1274         PL_bostr = truebase;
1275         s = CALLREG_INTUIT_START(aTHX_ rx, TARG, s, strend, r_flags, NULL);
1276
1277         if (!s)
1278             goto nope;
1279         if ( (rx->reganch & ROPT_CHECK_ALL)
1280              && !PL_sawampersand
1281              && ((rx->reganch & ROPT_NOSCAN)
1282                  || !((rx->reganch & RE_INTUIT_TAIL)
1283                       && (r_flags & REXEC_SCREAM)))
1284              && !SvROK(TARG))   /* Cannot trust since INTUIT cannot guess ^ */
1285             goto yup;
1286     }
1287     if (CALLREGEXEC(aTHX_ rx, s, strend, truebase, minmatch, TARG, NULL, r_flags))
1288     {
1289         PL_curpm = pm;
1290         if (dynpm->op_pmflags & PMf_ONCE)
1291             dynpm->op_pmdynflags |= PMdf_USED;
1292         goto gotcha;
1293     }
1294     else
1295         goto ret_no;
1296     /*NOTREACHED*/
1297
1298   gotcha:
1299     if (rxtainted)
1300         RX_MATCH_TAINTED_on(rx);
1301     TAINT_IF(RX_MATCH_TAINTED(rx));
1302     if (gimme == G_ARRAY) {
1303         I32 nparens, i, len;
1304
1305         nparens = rx->nparens;
1306         if (global && !nparens)
1307             i = 1;
1308         else
1309             i = 0;
1310         SPAGAIN;                        /* EVAL blocks could move the stack. */
1311         EXTEND(SP, nparens + i);
1312         EXTEND_MORTAL(nparens + i);
1313         for (i = !i; i <= nparens; i++) {
1314             PUSHs(sv_newmortal());
1315             /*SUPPRESS 560*/
1316             if ((rx->startp[i] != -1) && rx->endp[i] != -1 ) {
1317                 len = rx->endp[i] - rx->startp[i];
1318                 s = rx->startp[i] + truebase;
1319                 if (rx->endp[i] < 0 || rx->startp[i] < 0 ||
1320                     len < 0 || len > strend - s)
1321                     DIE(aTHX_ "panic: pp_match start/end pointers");
1322                 sv_setpvn(*SP, s, len);
1323                 if (DO_UTF8(TARG) && is_utf8_string((U8*)s, len))
1324                     SvUTF8_on(*SP);
1325             }
1326         }
1327         if (global) {
1328             if (dynpm->op_pmflags & PMf_CONTINUE) {
1329                 MAGIC* mg = 0;
1330                 if (SvTYPE(TARG) >= SVt_PVMG && SvMAGIC(TARG))
1331                     mg = mg_find(TARG, PERL_MAGIC_regex_global);
1332                 if (!mg) {
1333                     sv_magic(TARG, (SV*)0, PERL_MAGIC_regex_global, Nullch, 0);
1334                     mg = mg_find(TARG, PERL_MAGIC_regex_global);
1335                 }
1336                 if (rx->startp[0] != -1) {
1337                     mg->mg_len = rx->endp[0];
1338                     if (rx->startp[0] == rx->endp[0])
1339                         mg->mg_flags |= MGf_MINMATCH;
1340                     else
1341                         mg->mg_flags &= ~MGf_MINMATCH;
1342                 }
1343             }
1344             had_zerolen = (rx->startp[0] != -1
1345                            && rx->startp[0] == rx->endp[0]);
1346             PUTBACK;                    /* EVAL blocks may use stack */
1347             r_flags |= REXEC_IGNOREPOS | REXEC_NOT_FIRST;
1348             goto play_it_again;
1349         }
1350         else if (!nparens)
1351             XPUSHs(&PL_sv_yes);
1352         LEAVE_SCOPE(oldsave);
1353         RETURN;
1354     }
1355     else {
1356         if (global) {
1357             MAGIC* mg = 0;
1358             if (SvTYPE(TARG) >= SVt_PVMG && SvMAGIC(TARG))
1359                 mg = mg_find(TARG, PERL_MAGIC_regex_global);
1360             if (!mg) {
1361                 sv_magic(TARG, (SV*)0, PERL_MAGIC_regex_global, Nullch, 0);
1362                 mg = mg_find(TARG, PERL_MAGIC_regex_global);
1363             }
1364             if (rx->startp[0] != -1) {
1365                 mg->mg_len = rx->endp[0];
1366                 if (rx->startp[0] == rx->endp[0])
1367                     mg->mg_flags |= MGf_MINMATCH;
1368                 else
1369                     mg->mg_flags &= ~MGf_MINMATCH;
1370             }
1371         }
1372         LEAVE_SCOPE(oldsave);
1373         RETPUSHYES;
1374     }
1375
1376 yup:                                    /* Confirmed by INTUIT */
1377     if (rxtainted)
1378         RX_MATCH_TAINTED_on(rx);
1379     TAINT_IF(RX_MATCH_TAINTED(rx));
1380     PL_curpm = pm;
1381     if (dynpm->op_pmflags & PMf_ONCE)
1382         dynpm->op_pmdynflags |= PMdf_USED;
1383     if (RX_MATCH_COPIED(rx))
1384         Safefree(rx->subbeg);
1385     RX_MATCH_COPIED_off(rx);
1386     rx->subbeg = Nullch;
1387     if (global) {
1388         rx->subbeg = truebase;
1389         rx->startp[0] = s - truebase;
1390         if (RX_MATCH_UTF8(rx)) {
1391             char *t = (char*)utf8_hop((U8*)s, rx->minlen);
1392             rx->endp[0] = t - truebase;
1393         }
1394         else {
1395             rx->endp[0] = s - truebase + rx->minlen;
1396         }
1397         rx->sublen = strend - truebase;
1398         goto gotcha;
1399     }
1400     if (PL_sawampersand) {
1401         I32 off;
1402 #ifdef PERL_COPY_ON_WRITE
1403         if (SvIsCOW(TARG) || (SvFLAGS(TARG) & CAN_COW_MASK) == CAN_COW_FLAGS) {
1404             if (DEBUG_C_TEST) {
1405                 PerlIO_printf(Perl_debug_log,
1406                               "Copy on write: pp_match $& capture, type %d, truebase=%p, t=%p, difference %d\n",
1407                               (int) SvTYPE(TARG), truebase, t,
1408                               (int)(t-truebase));
1409             }
1410             rx->saved_copy = sv_setsv_cow(rx->saved_copy, TARG);
1411             rx->subbeg = SvPVX(rx->saved_copy) + (t - truebase);
1412             assert (SvPOKp(rx->saved_copy));
1413         } else
1414 #endif
1415         {
1416
1417             rx->subbeg = savepvn(t, strend - t);
1418 #ifdef PERL_COPY_ON_WRITE
1419             rx->saved_copy = Nullsv;
1420 #endif
1421         }
1422         rx->sublen = strend - t;
1423         RX_MATCH_COPIED_on(rx);
1424         off = rx->startp[0] = s - t;
1425         rx->endp[0] = off + rx->minlen;
1426     }
1427     else {                      /* startp/endp are used by @- @+. */
1428         rx->startp[0] = s - truebase;
1429         rx->endp[0] = s - truebase + rx->minlen;
1430     }
1431     rx->nparens = rx->lastparen = rx->lastcloseparen = 0;       /* used by @-, @+, and $^N */
1432     LEAVE_SCOPE(oldsave);
1433     RETPUSHYES;
1434
1435 nope:
1436 ret_no:
1437     if (global && !(dynpm->op_pmflags & PMf_CONTINUE)) {
1438         if (SvTYPE(TARG) >= SVt_PVMG && SvMAGIC(TARG)) {
1439             MAGIC* mg = mg_find(TARG, PERL_MAGIC_regex_global);
1440             if (mg)
1441                 mg->mg_len = -1;
1442         }
1443     }
1444     LEAVE_SCOPE(oldsave);
1445     if (gimme == G_ARRAY)
1446         RETURN;
1447     RETPUSHNO;
1448 }
1449
1450 OP *
1451 Perl_do_readline(pTHX)
1452 {
1453     dSP; dTARGETSTACKED;
1454     register SV *sv;
1455     STRLEN tmplen = 0;
1456     STRLEN offset;
1457     PerlIO *fp;
1458     register IO *io = GvIO(PL_last_in_gv);
1459     register I32 type = PL_op->op_type;
1460     I32 gimme = GIMME_V;
1461     MAGIC *mg;
1462
1463     if (io && (mg = SvTIED_mg((SV*)io, PERL_MAGIC_tiedscalar))) {
1464         PUSHMARK(SP);
1465         XPUSHs(SvTIED_obj((SV*)io, mg));
1466         PUTBACK;
1467         ENTER;
1468         call_method("READLINE", gimme);
1469         LEAVE;
1470         SPAGAIN;
1471         if (gimme == G_SCALAR) {
1472             SV* result = POPs;
1473             SvSetSV_nosteal(TARG, result);
1474             PUSHTARG;
1475         }
1476         RETURN;
1477     }
1478     fp = Nullfp;
1479     if (io) {
1480         fp = IoIFP(io);
1481         if (!fp) {
1482             if (IoFLAGS(io) & IOf_ARGV) {
1483                 if (IoFLAGS(io) & IOf_START) {
1484                     IoLINES(io) = 0;
1485                     if (av_len(GvAVn(PL_last_in_gv)) < 0) {
1486                         IoFLAGS(io) &= ~IOf_START;
1487                         do_open(PL_last_in_gv,"-",1,FALSE,O_RDONLY,0,Nullfp);
1488                         sv_setpvn(GvSV(PL_last_in_gv), "-", 1);
1489                         SvSETMAGIC(GvSV(PL_last_in_gv));
1490                         fp = IoIFP(io);
1491                         goto have_fp;
1492                     }
1493                 }
1494                 fp = nextargv(PL_last_in_gv);
1495                 if (!fp) { /* Note: fp != IoIFP(io) */
1496                     (void)do_close(PL_last_in_gv, FALSE); /* now it does*/
1497                 }
1498             }
1499             else if (type == OP_GLOB)
1500                 fp = Perl_start_glob(aTHX_ POPs, io);
1501         }
1502         else if (type == OP_GLOB)
1503             SP--;
1504         else if (ckWARN(WARN_IO) && IoTYPE(io) == IoTYPE_WRONLY) {
1505             report_evil_fh(PL_last_in_gv, io, OP_phoney_OUTPUT_ONLY);
1506         }
1507     }
1508     if (!fp) {
1509         if (ckWARN2(WARN_GLOB, WARN_CLOSED)
1510                 && (!io || !(IoFLAGS(io) & IOf_START))) {
1511             if (type == OP_GLOB)
1512                 Perl_warner(aTHX_ packWARN(WARN_GLOB),
1513                             "glob failed (can't start child: %s)",
1514                             Strerror(errno));
1515             else
1516                 report_evil_fh(PL_last_in_gv, io, PL_op->op_type);
1517         }
1518         if (gimme == G_SCALAR) {
1519             /* undef TARG, and push that undefined value */
1520             if (type != OP_RCATLINE) {
1521                 SV_CHECK_THINKFIRST_COW_DROP(TARG);
1522                 (void)SvOK_off(TARG);
1523             }
1524             PUSHTARG;
1525         }
1526         RETURN;
1527     }
1528   have_fp:
1529     if (gimme == G_SCALAR) {
1530         sv = TARG;
1531         if (SvROK(sv))
1532             sv_unref(sv);
1533         (void)SvUPGRADE(sv, SVt_PV);
1534         tmplen = SvLEN(sv);     /* remember if already alloced */
1535         if (!tmplen && !SvREADONLY(sv))
1536             Sv_Grow(sv, 80);    /* try short-buffering it */
1537         offset = 0;
1538         if (type == OP_RCATLINE && SvOK(sv)) {
1539             if (!SvPOK(sv)) {
1540                 STRLEN n_a;
1541                 (void)SvPV_force(sv, n_a);
1542             }
1543             offset = SvCUR(sv);
1544         }
1545     }
1546     else {
1547         sv = sv_2mortal(NEWSV(57, 80));
1548         offset = 0;
1549     }
1550
1551     /* This should not be marked tainted if the fp is marked clean */
1552 #define MAYBE_TAINT_LINE(io, sv) \
1553     if (!(IoFLAGS(io) & IOf_UNTAINT)) { \
1554         TAINT;                          \
1555         SvTAINTED_on(sv);               \
1556     }
1557
1558 /* delay EOF state for a snarfed empty file */
1559 #define SNARF_EOF(gimme,rs,io,sv) \
1560     (gimme != G_SCALAR || SvCUR(sv)                                     \
1561      || (IoFLAGS(io) & IOf_NOLINE) || !RsSNARF(rs))
1562
1563     for (;;) {
1564         PUTBACK;
1565         if (!sv_gets(sv, fp, offset)
1566             && (type == OP_GLOB
1567                 || SNARF_EOF(gimme, PL_rs, io, sv)
1568                 || PerlIO_error(fp)))
1569         {
1570             PerlIO_clearerr(fp);
1571             if (IoFLAGS(io) & IOf_ARGV) {
1572                 fp = nextargv(PL_last_in_gv);
1573                 if (fp)
1574                     continue;
1575                 (void)do_close(PL_last_in_gv, FALSE);
1576             }
1577             else if (type == OP_GLOB) {
1578                 if (!do_close(PL_last_in_gv, FALSE) && ckWARN(WARN_GLOB)) {
1579                     Perl_warner(aTHX_ packWARN(WARN_GLOB),
1580                            "glob failed (child exited with status %d%s)",
1581                            (int)(STATUS_CURRENT >> 8),
1582                            (STATUS_CURRENT & 0x80) ? ", core dumped" : "");
1583                 }
1584             }
1585             if (gimme == G_SCALAR) {
1586                 if (type != OP_RCATLINE) {
1587                     SV_CHECK_THINKFIRST_COW_DROP(TARG);
1588                     (void)SvOK_off(TARG);
1589                 }
1590                 SPAGAIN;
1591                 PUSHTARG;
1592             }
1593             MAYBE_TAINT_LINE(io, sv);
1594             RETURN;
1595         }
1596         MAYBE_TAINT_LINE(io, sv);
1597         IoLINES(io)++;
1598         IoFLAGS(io) |= IOf_NOLINE;
1599         SvSETMAGIC(sv);
1600         SPAGAIN;
1601         XPUSHs(sv);
1602         if (type == OP_GLOB) {
1603             char *tmps;
1604
1605             if (SvCUR(sv) > 0 && SvCUR(PL_rs) > 0) {
1606                 tmps = SvEND(sv) - 1;
1607                 if (*tmps == *SvPVX(PL_rs)) {
1608                     *tmps = '\0';
1609                     SvCUR(sv)--;
1610                 }
1611             }
1612             for (tmps = SvPVX(sv); *tmps; tmps++)
1613                 if (!isALPHA(*tmps) && !isDIGIT(*tmps) &&
1614                     strchr("$&*(){}[]'\";\\|?<>~`", *tmps))
1615                         break;
1616             if (*tmps && PerlLIO_lstat(SvPVX(sv), &PL_statbuf) < 0) {
1617                 (void)POPs;             /* Unmatched wildcard?  Chuck it... */
1618                 continue;
1619             }
1620         } else if (SvUTF8(sv)) { /* OP_READLINE, OP_RCATLINE */
1621              U8 *s = (U8*)SvPVX(sv) + offset;
1622              STRLEN len = SvCUR(sv) - offset;
1623              U8 *f;
1624
1625              if (ckWARN(WARN_UTF8) &&
1626                  !Perl_is_utf8_string_loc(aTHX_ s, len, &f))
1627                   /* Emulate :encoding(utf8) warning in the same case. */
1628                   Perl_warner(aTHX_ packWARN(WARN_UTF8),
1629                               "utf8 \"\\x%02X\" does not map to Unicode",
1630                               f < (U8*)SvEND(sv) ? *f : 0);
1631         }
1632         if (gimme == G_ARRAY) {
1633             if (SvLEN(sv) - SvCUR(sv) > 20) {
1634                 SvLEN_set(sv, SvCUR(sv)+1);
1635                 Renew(SvPVX(sv), SvLEN(sv), char);
1636             }
1637             sv = sv_2mortal(NEWSV(58, 80));
1638             continue;
1639         }
1640         else if (gimme == G_SCALAR && !tmplen && SvLEN(sv) - SvCUR(sv) > 80) {
1641             /* try to reclaim a bit of scalar space (only on 1st alloc) */
1642             if (SvCUR(sv) < 60)
1643                 SvLEN_set(sv, 80);
1644             else
1645                 SvLEN_set(sv, SvCUR(sv)+40);    /* allow some slop */
1646             Renew(SvPVX(sv), SvLEN(sv), char);
1647         }
1648         RETURN;
1649     }
1650 }
1651
1652 PP(pp_enter)
1653 {
1654     dSP;
1655     register PERL_CONTEXT *cx;
1656     I32 gimme = OP_GIMME(PL_op, -1);
1657
1658     if (gimme == -1) {
1659         if (cxstack_ix >= 0)
1660             gimme = cxstack[cxstack_ix].blk_gimme;
1661         else
1662             gimme = G_SCALAR;
1663     }
1664
1665     ENTER;
1666
1667     SAVETMPS;
1668     PUSHBLOCK(cx, CXt_BLOCK, SP);
1669
1670     RETURN;
1671 }
1672
1673 PP(pp_helem)
1674 {
1675     dSP;
1676     HE* he;
1677     SV **svp;
1678     SV *keysv = POPs;
1679     HV *hv = (HV*)POPs;
1680     U32 lval = PL_op->op_flags & OPf_MOD || LVRET;
1681     U32 defer = PL_op->op_private & OPpLVAL_DEFER;
1682     SV *sv;
1683 #ifdef PERL_COPY_ON_WRITE
1684     U32 hash = (SvIsCOW_shared_hash(keysv)) ? SvUVX(keysv) : 0;
1685 #else
1686     U32 hash = (SvFAKE(keysv) && SvREADONLY(keysv)) ? SvUVX(keysv) : 0;
1687 #endif
1688     I32 preeminent = 0;
1689
1690     if (SvTYPE(hv) == SVt_PVHV) {
1691         if (PL_op->op_private & OPpLVAL_INTRO) {
1692             MAGIC *mg;
1693             HV *stash;
1694             /* does the element we're localizing already exist? */
1695             preeminent =
1696                 /* can we determine whether it exists? */
1697                 (    !SvRMAGICAL(hv)
1698                   || mg_find((SV*)hv, PERL_MAGIC_env)
1699                   || (     (mg = mg_find((SV*)hv, PERL_MAGIC_tied))
1700                         /* Try to preserve the existenceness of a tied hash
1701                          * element by using EXISTS and DELETE if possible.
1702                          * Fallback to FETCH and STORE otherwise */
1703                         && (stash = SvSTASH(SvRV(SvTIED_obj((SV*)hv, mg))))
1704                         && gv_fetchmethod_autoload(stash, "EXISTS", TRUE)
1705                         && gv_fetchmethod_autoload(stash, "DELETE", TRUE)
1706                     )
1707                 ) ? hv_exists_ent(hv, keysv, 0) : 1;
1708
1709         }
1710         he = hv_fetch_ent(hv, keysv, lval && !defer, hash);
1711         svp = he ? &HeVAL(he) : 0;
1712     }
1713     else {
1714         RETPUSHUNDEF;
1715     }
1716     if (lval) {
1717         if (!svp || *svp == &PL_sv_undef) {
1718             SV* lv;
1719             SV* key2;
1720             if (!defer) {
1721                 STRLEN n_a;
1722                 DIE(aTHX_ PL_no_helem, SvPV(keysv, n_a));
1723             }
1724             lv = sv_newmortal();
1725             sv_upgrade(lv, SVt_PVLV);
1726             LvTYPE(lv) = 'y';
1727             sv_magic(lv, key2 = newSVsv(keysv), PERL_MAGIC_defelem, Nullch, 0);
1728             SvREFCNT_dec(key2); /* sv_magic() increments refcount */
1729             LvTARG(lv) = SvREFCNT_inc(hv);
1730             LvTARGLEN(lv) = 1;
1731             PUSHs(lv);
1732             RETURN;
1733         }
1734         if (PL_op->op_private & OPpLVAL_INTRO) {
1735             if (HvNAME(hv) && isGV(*svp))
1736                 save_gp((GV*)*svp, !(PL_op->op_flags & OPf_SPECIAL));
1737             else {
1738                 if (!preeminent) {
1739                     STRLEN keylen;
1740                     char *key = SvPV(keysv, keylen);
1741                     SAVEDELETE(hv, savepvn(key,keylen), keylen);
1742                 } else
1743                     save_helem(hv, keysv, svp);
1744             }
1745         }
1746         else if (PL_op->op_private & OPpDEREF)
1747             vivify_ref(*svp, PL_op->op_private & OPpDEREF);
1748     }
1749     sv = (svp ? *svp : &PL_sv_undef);
1750     /* This makes C<local $tied{foo} = $tied{foo}> possible.
1751      * Pushing the magical RHS on to the stack is useless, since
1752      * that magic is soon destined to be misled by the local(),
1753      * and thus the later pp_sassign() will fail to mg_get() the
1754      * old value.  This should also cure problems with delayed
1755      * mg_get()s.  GSAR 98-07-03 */
1756     if (!lval && SvGMAGICAL(sv))
1757         sv = sv_mortalcopy(sv);
1758     PUSHs(sv);
1759     RETURN;
1760 }
1761
1762 PP(pp_leave)
1763 {
1764     dSP;
1765     register PERL_CONTEXT *cx;
1766     register SV **mark;
1767     SV **newsp;
1768     PMOP *newpm;
1769     I32 gimme;
1770
1771     if (PL_op->op_flags & OPf_SPECIAL) {
1772         cx = &cxstack[cxstack_ix];
1773         cx->blk_oldpm = PL_curpm;       /* fake block should preserve $1 et al */
1774     }
1775
1776     POPBLOCK(cx,newpm);
1777
1778     gimme = OP_GIMME(PL_op, -1);
1779     if (gimme == -1) {
1780         if (cxstack_ix >= 0)
1781             gimme = cxstack[cxstack_ix].blk_gimme;
1782         else
1783             gimme = G_SCALAR;
1784     }
1785
1786     TAINT_NOT;
1787     if (gimme == G_VOID)
1788         SP = newsp;
1789     else if (gimme == G_SCALAR) {
1790         MARK = newsp + 1;
1791         if (MARK <= SP) {
1792             if (SvFLAGS(TOPs) & (SVs_PADTMP|SVs_TEMP))
1793                 *MARK = TOPs;
1794             else
1795                 *MARK = sv_mortalcopy(TOPs);
1796         } else {
1797             MEXTEND(mark,0);
1798             *MARK = &PL_sv_undef;
1799         }
1800         SP = MARK;
1801     }
1802     else if (gimme == G_ARRAY) {
1803         /* in case LEAVE wipes old return values */
1804         for (mark = newsp + 1; mark <= SP; mark++) {
1805             if (!(SvFLAGS(*mark) & (SVs_PADTMP|SVs_TEMP))) {
1806                 *mark = sv_mortalcopy(*mark);
1807                 TAINT_NOT;      /* Each item is independent */
1808             }
1809         }
1810     }
1811     PL_curpm = newpm;   /* Don't pop $1 et al till now */
1812
1813     LEAVE;
1814
1815     RETURN;
1816 }
1817
1818 PP(pp_iter)
1819 {
1820     dSP;
1821     register PERL_CONTEXT *cx;
1822     SV* sv;
1823     AV* av;
1824     SV **itersvp;
1825
1826     EXTEND(SP, 1);
1827     cx = &cxstack[cxstack_ix];
1828     if (CxTYPE(cx) != CXt_LOOP)
1829         DIE(aTHX_ "panic: pp_iter");
1830
1831     itersvp = CxITERVAR(cx);
1832     av = cx->blk_loop.iterary;
1833     if (SvTYPE(av) != SVt_PVAV) {
1834         /* iterate ($min .. $max) */
1835         if (cx->blk_loop.iterlval) {
1836             /* string increment */
1837             register SV* cur = cx->blk_loop.iterlval;
1838             STRLEN maxlen;
1839             char *max = SvPV((SV*)av, maxlen);
1840             if (!SvNIOK(cur) && SvCUR(cur) <= maxlen) {
1841                 if (SvREFCNT(*itersvp) == 1 && !SvMAGICAL(*itersvp)) {
1842                     /* safe to reuse old SV */
1843                     sv_setsv(*itersvp, cur);
1844                 }
1845                 else
1846                 {
1847                     /* we need a fresh SV every time so that loop body sees a
1848                      * completely new SV for closures/references to work as
1849                      * they used to */
1850                     SvREFCNT_dec(*itersvp);
1851                     *itersvp = newSVsv(cur);
1852                 }
1853                 if (strEQ(SvPVX(cur), max))
1854                     sv_setiv(cur, 0); /* terminate next time */
1855                 else
1856                     sv_inc(cur);
1857                 RETPUSHYES;
1858             }
1859             RETPUSHNO;
1860         }
1861         /* integer increment */
1862         if (cx->blk_loop.iterix > cx->blk_loop.itermax)
1863             RETPUSHNO;
1864
1865         /* don't risk potential race */
1866         if (SvREFCNT(*itersvp) == 1 && !SvMAGICAL(*itersvp)) {
1867             /* safe to reuse old SV */
1868             sv_setiv(*itersvp, cx->blk_loop.iterix++);
1869         }
1870         else
1871         {
1872             /* we need a fresh SV every time so that loop body sees a
1873              * completely new SV for closures/references to work as they
1874              * used to */
1875             SvREFCNT_dec(*itersvp);
1876             *itersvp = newSViv(cx->blk_loop.iterix++);
1877         }
1878         RETPUSHYES;
1879     }
1880
1881     /* iterate array */
1882     if (cx->blk_loop.iterix >= (av == PL_curstack ? cx->blk_oldsp : AvFILL(av)))
1883         RETPUSHNO;
1884
1885     SvREFCNT_dec(*itersvp);
1886
1887     if (SvMAGICAL(av) || AvREIFY(av)) {
1888         SV **svp = av_fetch(av, ++cx->blk_loop.iterix, FALSE);
1889         if (svp)
1890             sv = *svp;
1891         else
1892             sv = Nullsv;
1893     }
1894     else {
1895         sv = AvARRAY(av)[++cx->blk_loop.iterix];
1896     }
1897     if (sv && SvREFCNT(sv) == 0) {
1898         *itersvp = Nullsv;
1899         Perl_croak(aTHX_ "Use of freed value in iteration");
1900     }
1901
1902     if (sv)
1903         SvTEMP_off(sv);
1904     else
1905         sv = &PL_sv_undef;
1906     if (av != PL_curstack && sv == &PL_sv_undef) {
1907         SV *lv = cx->blk_loop.iterlval;
1908         if (lv && SvREFCNT(lv) > 1) {
1909             SvREFCNT_dec(lv);
1910             lv = Nullsv;
1911         }
1912         if (lv)
1913             SvREFCNT_dec(LvTARG(lv));
1914         else {
1915             lv = cx->blk_loop.iterlval = NEWSV(26, 0);
1916             sv_upgrade(lv, SVt_PVLV);
1917             LvTYPE(lv) = 'y';
1918             sv_magic(lv, Nullsv, PERL_MAGIC_defelem, Nullch, 0);
1919         }
1920         LvTARG(lv) = SvREFCNT_inc(av);
1921         LvTARGOFF(lv) = cx->blk_loop.iterix;
1922         LvTARGLEN(lv) = (STRLEN)UV_MAX;
1923         sv = (SV*)lv;
1924     }
1925
1926     *itersvp = SvREFCNT_inc(sv);
1927     RETPUSHYES;
1928 }
1929
1930 PP(pp_subst)
1931 {
1932     dSP; dTARG;
1933     register PMOP *pm = cPMOP;
1934     PMOP *rpm = pm;
1935     register SV *dstr;
1936     register char *s;
1937     char *strend;
1938     register char *m;
1939     char *c;
1940     register char *d;
1941     STRLEN clen;
1942     I32 iters = 0;
1943     I32 maxiters;
1944     register I32 i;
1945     bool once;
1946     bool rxtainted;
1947     char *orig;
1948     I32 r_flags;
1949     register REGEXP *rx = PM_GETRE(pm);
1950     STRLEN len;
1951     int force_on_match = 0;
1952     I32 oldsave = PL_savestack_ix;
1953     STRLEN slen;
1954     bool doutf8 = FALSE;
1955 #ifdef PERL_COPY_ON_WRITE
1956     bool is_cow;
1957 #endif
1958     SV *nsv = Nullsv;
1959
1960     /* known replacement string? */
1961     dstr = (pm->op_pmflags & PMf_CONST) ? POPs : Nullsv;
1962     if (PL_op->op_flags & OPf_STACKED)
1963         TARG = POPs;
1964     else if (PL_op->op_private & OPpTARGET_MY)
1965         GETTARGET;
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_PVGV || 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             if (PL_op->op_private & OPpGREP_LEX) {
2299                 SV* sv = sv_newmortal();
2300                 sv_setiv(sv, items);
2301                 PUSHs(sv);
2302             }
2303             else {
2304                 dTARGET;
2305                 XPUSHi(items);
2306             }
2307         }
2308         else if (gimme == G_ARRAY)
2309             SP += items;
2310         RETURN;
2311     }
2312     else {
2313         SV *src;
2314
2315         ENTER;                                  /* enter inner scope */
2316         SAVEVPTR(PL_curpm);
2317
2318         src = PL_stack_base[*PL_markstack_ptr];
2319         SvTEMP_off(src);
2320         if (PL_op->op_private & OPpGREP_LEX)
2321             PAD_SVl(PL_op->op_targ) = src;
2322         else
2323             DEFSV = src;
2324
2325         RETURNOP(cLOGOP->op_other);
2326     }
2327 }
2328
2329 PP(pp_leavesub)
2330 {
2331     dSP;
2332     SV **mark;
2333     SV **newsp;
2334     PMOP *newpm;
2335     I32 gimme;
2336     register PERL_CONTEXT *cx;
2337     SV *sv;
2338
2339     POPBLOCK(cx,newpm);
2340     cxstack_ix++; /* temporarily protect top context */
2341
2342     TAINT_NOT;
2343     if (gimme == G_SCALAR) {
2344         MARK = newsp + 1;
2345         if (MARK <= SP) {
2346             if (cx->blk_sub.cv && CvDEPTH(cx->blk_sub.cv) > 1) {
2347                 if (SvTEMP(TOPs)) {
2348                     *MARK = SvREFCNT_inc(TOPs);
2349                     FREETMPS;
2350                     sv_2mortal(*MARK);
2351                 }
2352                 else {
2353                     sv = SvREFCNT_inc(TOPs);    /* FREETMPS could clobber it */
2354                     FREETMPS;
2355                     *MARK = sv_mortalcopy(sv);
2356                     SvREFCNT_dec(sv);
2357                 }
2358             }
2359             else
2360                 *MARK = SvTEMP(TOPs) ? TOPs : sv_mortalcopy(TOPs);
2361         }
2362         else {
2363             MEXTEND(MARK, 0);
2364             *MARK = &PL_sv_undef;
2365         }
2366         SP = MARK;
2367     }
2368     else if (gimme == G_ARRAY) {
2369         for (MARK = newsp + 1; MARK <= SP; MARK++) {
2370             if (!SvTEMP(*MARK)) {
2371                 *MARK = sv_mortalcopy(*MARK);
2372                 TAINT_NOT;      /* Each item is independent */
2373             }
2374         }
2375     }
2376     PUTBACK;
2377
2378     LEAVE;
2379     cxstack_ix--;
2380     POPSUB(cx,sv);      /* Stack values are safe: release CV and @_ ... */
2381     PL_curpm = newpm;   /* ... and pop $1 et al */
2382
2383     LEAVESUB(sv);
2384     return pop_return();
2385 }
2386
2387 /* This duplicates the above code because the above code must not
2388  * get any slower by more conditions */
2389 PP(pp_leavesublv)
2390 {
2391     dSP;
2392     SV **mark;
2393     SV **newsp;
2394     PMOP *newpm;
2395     I32 gimme;
2396     register PERL_CONTEXT *cx;
2397     SV *sv;
2398
2399     POPBLOCK(cx,newpm);
2400     cxstack_ix++; /* temporarily protect top context */
2401
2402     TAINT_NOT;
2403
2404     if (cx->blk_sub.lval & OPpENTERSUB_INARGS) {
2405         /* We are an argument to a function or grep().
2406          * This kind of lvalueness was legal before lvalue
2407          * subroutines too, so be backward compatible:
2408          * cannot report errors.  */
2409
2410         /* Scalar context *is* possible, on the LHS of -> only,
2411          * as in f()->meth().  But this is not an lvalue. */
2412         if (gimme == G_SCALAR)
2413             goto temporise;
2414         if (gimme == G_ARRAY) {
2415             if (!CvLVALUE(cx->blk_sub.cv))
2416                 goto temporise_array;
2417             EXTEND_MORTAL(SP - newsp);
2418             for (mark = newsp + 1; mark <= SP; mark++) {
2419                 if (SvTEMP(*mark))
2420                     /* empty */ ;
2421                 else if (SvFLAGS(*mark) & (SVs_PADTMP | SVf_READONLY))
2422                     *mark = sv_mortalcopy(*mark);
2423                 else {
2424                     /* Can be a localized value subject to deletion. */
2425                     PL_tmps_stack[++PL_tmps_ix] = *mark;
2426                     (void)SvREFCNT_inc(*mark);
2427                 }
2428             }
2429         }
2430     }
2431     else if (cx->blk_sub.lval) {     /* Leave it as it is if we can. */
2432         /* Here we go for robustness, not for speed, so we change all
2433          * the refcounts so the caller gets a live guy. Cannot set
2434          * TEMP, so sv_2mortal is out of question. */
2435         if (!CvLVALUE(cx->blk_sub.cv)) {
2436             LEAVE;
2437             cxstack_ix--;
2438             POPSUB(cx,sv);
2439             PL_curpm = newpm;
2440             LEAVESUB(sv);
2441             DIE(aTHX_ "Can't modify non-lvalue subroutine call");
2442         }
2443         if (gimme == G_SCALAR) {
2444             MARK = newsp + 1;
2445             EXTEND_MORTAL(1);
2446             if (MARK == SP) {
2447                 if (SvFLAGS(TOPs) & (SVs_TEMP | SVs_PADTMP | SVf_READONLY)) {
2448                     LEAVE;
2449                     cxstack_ix--;
2450                     POPSUB(cx,sv);
2451                     PL_curpm = newpm;
2452                     LEAVESUB(sv);
2453                     DIE(aTHX_ "Can't return %s from lvalue subroutine",
2454                         SvREADONLY(TOPs) ? (TOPs == &PL_sv_undef) ? "undef"
2455                         : "a readonly value" : "a temporary");
2456                 }
2457                 else {                  /* Can be a localized value
2458                                          * subject to deletion. */
2459                     PL_tmps_stack[++PL_tmps_ix] = *mark;
2460                     (void)SvREFCNT_inc(*mark);
2461                 }
2462             }
2463             else {                      /* Should not happen? */
2464                 LEAVE;
2465                 cxstack_ix--;
2466                 POPSUB(cx,sv);
2467                 PL_curpm = newpm;
2468                 LEAVESUB(sv);
2469                 DIE(aTHX_ "%s returned from lvalue subroutine in scalar context",
2470                     (MARK > SP ? "Empty array" : "Array"));
2471             }
2472             SP = MARK;
2473         }
2474         else if (gimme == G_ARRAY) {
2475             EXTEND_MORTAL(SP - newsp);
2476             for (mark = newsp + 1; mark <= SP; mark++) {
2477                 if (*mark != &PL_sv_undef
2478                     && SvFLAGS(*mark) & (SVs_TEMP | SVs_PADTMP | SVf_READONLY)) {
2479                     /* Might be flattened array after $#array =  */
2480                     PUTBACK;
2481                     LEAVE;
2482                     cxstack_ix--;
2483                     POPSUB(cx,sv);
2484                     PL_curpm = newpm;
2485                     LEAVESUB(sv);
2486                     DIE(aTHX_ "Can't return a %s from lvalue subroutine",
2487                         SvREADONLY(TOPs) ? "readonly value" : "temporary");
2488                 }
2489                 else {
2490                     /* Can be a localized value subject to deletion. */
2491                     PL_tmps_stack[++PL_tmps_ix] = *mark;
2492                     (void)SvREFCNT_inc(*mark);
2493                 }
2494             }
2495         }
2496     }
2497     else {
2498         if (gimme == G_SCALAR) {
2499           temporise:
2500             MARK = newsp + 1;
2501             if (MARK <= SP) {
2502                 if (cx->blk_sub.cv && CvDEPTH(cx->blk_sub.cv) > 1) {
2503                     if (SvTEMP(TOPs)) {
2504                         *MARK = SvREFCNT_inc(TOPs);
2505                         FREETMPS;
2506                         sv_2mortal(*MARK);
2507                     }
2508                     else {
2509                         sv = SvREFCNT_inc(TOPs); /* FREETMPS could clobber it */
2510                         FREETMPS;
2511                         *MARK = sv_mortalcopy(sv);
2512                         SvREFCNT_dec(sv);
2513                     }
2514                 }
2515                 else
2516                     *MARK = SvTEMP(TOPs) ? TOPs : sv_mortalcopy(TOPs);
2517             }
2518             else {
2519                 MEXTEND(MARK, 0);
2520                 *MARK = &PL_sv_undef;
2521             }
2522             SP = MARK;
2523         }
2524         else if (gimme == G_ARRAY) {
2525           temporise_array:
2526             for (MARK = newsp + 1; MARK <= SP; MARK++) {
2527                 if (!SvTEMP(*MARK)) {
2528                     *MARK = sv_mortalcopy(*MARK);
2529                     TAINT_NOT;  /* Each item is independent */
2530                 }
2531             }
2532         }
2533     }
2534     PUTBACK;
2535
2536     LEAVE;
2537     cxstack_ix--;
2538     POPSUB(cx,sv);      /* Stack values are safe: release CV and @_ ... */
2539     PL_curpm = newpm;   /* ... and pop $1 et al */
2540
2541     LEAVESUB(sv);
2542     return pop_return();
2543 }
2544
2545
2546 STATIC CV *
2547 S_get_db_sub(pTHX_ SV **svp, CV *cv)
2548 {
2549     SV *dbsv = GvSV(PL_DBsub);
2550
2551     if (!PERLDB_SUB_NN) {
2552         GV *gv = CvGV(cv);
2553
2554         save_item(dbsv);
2555         if ( (CvFLAGS(cv) & (CVf_ANON | CVf_CLONED))
2556              || strEQ(GvNAME(gv), "END")
2557              || ((GvCV(gv) != cv) && /* Could be imported, and old sub redefined. */
2558                  !( (SvTYPE(*svp) == SVt_PVGV) && (GvCV((GV*)*svp) == cv)
2559                     && (gv = (GV*)*svp) ))) {
2560             /* Use GV from the stack as a fallback. */
2561             /* GV is potentially non-unique, or contain different CV. */
2562             SV *tmp = newRV((SV*)cv);
2563             sv_setsv(dbsv, tmp);
2564             SvREFCNT_dec(tmp);
2565         }
2566         else {
2567             gv_efullname3(dbsv, gv, Nullch);
2568         }
2569     }
2570     else {
2571         (void)SvUPGRADE(dbsv, SVt_PVIV);
2572         (void)SvIOK_on(dbsv);
2573         SAVEIV(SvIVX(dbsv));
2574         SvIVX(dbsv) = PTR2IV(cv);       /* Do it the quickest way  */
2575     }
2576
2577     if (CvXSUB(cv))
2578         PL_curcopdb = PL_curcop;
2579     cv = GvCV(PL_DBsub);
2580     return cv;
2581 }
2582
2583 PP(pp_entersub)
2584 {
2585     dSP; dPOPss;
2586     GV *gv;
2587     HV *stash;
2588     register CV *cv;
2589     register PERL_CONTEXT *cx;
2590     I32 gimme;
2591     bool hasargs = (PL_op->op_flags & OPf_STACKED) != 0;
2592
2593     if (!sv)
2594         DIE(aTHX_ "Not a CODE reference");
2595     switch (SvTYPE(sv)) {
2596         /* This is overwhelming the most common case:  */
2597     case SVt_PVGV:
2598         if (!(cv = GvCVu((GV*)sv)))
2599             cv = sv_2cv(sv, &stash, &gv, FALSE);
2600         if (!cv) {
2601             ENTER;
2602             SAVETMPS;
2603             goto try_autoload;
2604         }
2605         break;
2606     default:
2607         if (!SvROK(sv)) {
2608             char *sym;
2609             STRLEN n_a;
2610
2611             if (sv == &PL_sv_yes) {             /* unfound import, ignore */
2612                 if (hasargs)
2613                     SP = PL_stack_base + POPMARK;
2614                 RETURN;
2615             }
2616             if (SvGMAGICAL(sv)) {
2617                 mg_get(sv);
2618                 if (SvROK(sv))
2619                     goto got_rv;
2620                 sym = SvPOKp(sv) ? SvPVX(sv) : Nullch;
2621             }
2622             else
2623                 sym = SvPV(sv, n_a);
2624             if (!sym)
2625                 DIE(aTHX_ PL_no_usym, "a subroutine");
2626             if (PL_op->op_private & HINT_STRICT_REFS)
2627                 DIE(aTHX_ PL_no_symref, sym, "a subroutine");
2628             cv = get_cv(sym, TRUE);
2629             break;
2630         }
2631   got_rv:
2632         {
2633             SV **sp = &sv;              /* Used in tryAMAGICunDEREF macro. */
2634             tryAMAGICunDEREF(to_cv);
2635         }
2636         cv = (CV*)SvRV(sv);
2637         if (SvTYPE(cv) == SVt_PVCV)
2638             break;
2639         /* FALL THROUGH */
2640     case SVt_PVHV:
2641     case SVt_PVAV:
2642         DIE(aTHX_ "Not a CODE reference");
2643         /* This is the second most common case:  */
2644     case SVt_PVCV:
2645         cv = (CV*)sv;
2646         break;
2647     }
2648
2649     ENTER;
2650     SAVETMPS;
2651
2652   retry:
2653     if (!CvROOT(cv) && !CvXSUB(cv)) {
2654         goto fooey;
2655     }
2656
2657     gimme = GIMME_V;
2658     if ((PL_op->op_private & OPpENTERSUB_DB) && GvCV(PL_DBsub) && !CvNODEBUG(cv)) {
2659         if (CvASSERTION(cv) && PL_DBassertion)
2660             sv_setiv(PL_DBassertion, 1);
2661
2662         cv = get_db_sub(&sv, cv);
2663         if (!cv)
2664             DIE(aTHX_ "No DBsub routine");
2665     }
2666
2667     if (!(CvXSUB(cv))) {
2668         /* This path taken at least 75% of the time   */
2669         dMARK;
2670         register I32 items = SP - MARK;
2671         AV* padlist = CvPADLIST(cv);
2672         push_return(PL_op->op_next);
2673         PUSHBLOCK(cx, CXt_SUB, MARK);
2674         PUSHSUB(cx);
2675         CvDEPTH(cv)++;
2676         /* XXX This would be a natural place to set C<PL_compcv = cv> so
2677          * that eval'' ops within this sub know the correct lexical space.
2678          * Owing the speed considerations, we choose instead to search for
2679          * the cv using find_runcv() when calling doeval().
2680          */
2681         if (CvDEPTH(cv) >= 2) {
2682             PERL_STACK_OVERFLOW_CHECK();
2683             pad_push(padlist, CvDEPTH(cv), 1);
2684         }
2685         PAD_SET_CUR(padlist, CvDEPTH(cv));
2686         if (hasargs)
2687         {
2688             AV* av;
2689             SV** ary;
2690
2691 #if 0
2692             DEBUG_S(PerlIO_printf(Perl_debug_log,
2693                                   "%p entersub preparing @_\n", thr));
2694 #endif
2695             av = (AV*)PAD_SVl(0);
2696             if (AvREAL(av)) {
2697                 /* @_ is normally not REAL--this should only ever
2698                  * happen when DB::sub() calls things that modify @_ */
2699                 av_clear(av);
2700                 AvREAL_off(av);
2701                 AvREIFY_on(av);
2702             }
2703             cx->blk_sub.savearray = GvAV(PL_defgv);
2704             GvAV(PL_defgv) = (AV*)SvREFCNT_inc(av);
2705             CX_CURPAD_SAVE(cx->blk_sub);
2706             cx->blk_sub.argarray = av;
2707             ++MARK;
2708
2709             if (items > AvMAX(av) + 1) {
2710                 ary = AvALLOC(av);
2711                 if (AvARRAY(av) != ary) {
2712                     AvMAX(av) += AvARRAY(av) - AvALLOC(av);
2713                     SvPVX(av) = (char*)ary;
2714                 }
2715                 if (items > AvMAX(av) + 1) {
2716                     AvMAX(av) = items - 1;
2717                     Renew(ary,items,SV*);
2718                     AvALLOC(av) = ary;
2719                     SvPVX(av) = (char*)ary;
2720                 }
2721             }
2722             Copy(MARK,AvARRAY(av),items,SV*);
2723             AvFILLp(av) = items - 1;
2724
2725             while (items--) {
2726                 if (*MARK)
2727                     SvTEMP_off(*MARK);
2728                 MARK++;
2729             }
2730         }
2731         /* warning must come *after* we fully set up the context
2732          * stuff so that __WARN__ handlers can safely dounwind()
2733          * if they want to
2734          */
2735         if (CvDEPTH(cv) == 100 && ckWARN(WARN_RECURSION)
2736             && !(PERLDB_SUB && cv == GvCV(PL_DBsub)))
2737             sub_crush_depth(cv);
2738 #if 0
2739         DEBUG_S(PerlIO_printf(Perl_debug_log,
2740                               "%p entersub returning %p\n", thr, CvSTART(cv)));
2741 #endif
2742         RETURNOP(CvSTART(cv));
2743     }
2744     else {
2745 #ifdef PERL_XSUB_OLDSTYLE
2746         if (CvOLDSTYLE(cv)) {
2747             I32 (*fp3)(int,int,int);
2748             dMARK;
2749             register I32 items = SP - MARK;
2750                                         /* We dont worry to copy from @_. */
2751             while (SP > mark) {
2752                 SP[1] = SP[0];
2753                 SP--;
2754             }
2755             PL_stack_sp = mark + 1;
2756             fp3 = (I32(*)(int,int,int))CvXSUB(cv);
2757             items = (*fp3)(CvXSUBANY(cv).any_i32,
2758                            MARK - PL_stack_base + 1,
2759                            items);
2760             PL_stack_sp = PL_stack_base + items;
2761         }
2762         else
2763 #endif /* PERL_XSUB_OLDSTYLE */
2764         {
2765             I32 markix = TOPMARK;
2766
2767             PUTBACK;
2768
2769             if (!hasargs) {
2770                 /* Need to copy @_ to stack. Alternative may be to
2771                  * switch stack to @_, and copy return values
2772                  * back. This would allow popping @_ in XSUB, e.g.. XXXX */
2773                 AV* av;
2774                 I32 items;
2775                 av = GvAV(PL_defgv);
2776                 items = AvFILLp(av) + 1;   /* @_ is not tieable */
2777
2778                 if (items) {
2779                     /* Mark is at the end of the stack. */
2780                     EXTEND(SP, items);
2781                     Copy(AvARRAY(av), SP + 1, items, SV*);
2782                     SP += items;
2783                     PUTBACK ;
2784                 }
2785             }
2786             /* We assume first XSUB in &DB::sub is the called one. */
2787             if (PL_curcopdb) {
2788                 SAVEVPTR(PL_curcop);
2789                 PL_curcop = PL_curcopdb;
2790                 PL_curcopdb = NULL;
2791             }
2792             /* Do we need to open block here? XXXX */
2793             (void)(*CvXSUB(cv))(aTHX_ cv);
2794
2795             /* Enforce some sanity in scalar context. */
2796             if (gimme == G_SCALAR && ++markix != PL_stack_sp - PL_stack_base ) {
2797                 if (markix > PL_stack_sp - PL_stack_base)
2798                     *(PL_stack_base + markix) = &PL_sv_undef;
2799                 else
2800                     *(PL_stack_base + markix) = *PL_stack_sp;
2801                 PL_stack_sp = PL_stack_base + markix;
2802             }
2803         }
2804         LEAVE;
2805         return NORMAL;
2806     }
2807
2808     assert (0); /* Cannot get here.  */
2809     /* This is deliberately moved here as spaghetti code to keep it out of the
2810        hot path.  */
2811     {
2812         GV* autogv;
2813         SV* sub_name;
2814
2815       fooey:
2816         /* anonymous or undef'd function leaves us no recourse */
2817         if (CvANON(cv) || !(gv = CvGV(cv)))
2818             DIE(aTHX_ "Undefined subroutine called");
2819
2820         /* autoloaded stub? */
2821         if (cv != GvCV(gv)) {
2822             cv = GvCV(gv);
2823         }
2824         /* should call AUTOLOAD now? */
2825         else {
2826 try_autoload:
2827             if ((autogv = gv_autoload4(GvSTASH(gv), GvNAME(gv), GvNAMELEN(gv),
2828                                    FALSE)))
2829             {
2830                 cv = GvCV(autogv);
2831             }
2832             /* sorry */
2833             else {
2834                 sub_name = sv_newmortal();
2835                 gv_efullname3(sub_name, gv, Nullch);
2836                 DIE(aTHX_ "Undefined subroutine &%"SVf" called", sub_name);
2837             }
2838         }
2839         if (!cv)
2840             DIE(aTHX_ "Not a CODE reference");
2841         goto retry;
2842     }
2843 }
2844
2845 void
2846 Perl_sub_crush_depth(pTHX_ CV *cv)
2847 {
2848     if (CvANON(cv))
2849         Perl_warner(aTHX_ packWARN(WARN_RECURSION), "Deep recursion on anonymous subroutine");
2850     else {
2851         SV* tmpstr = sv_newmortal();
2852         gv_efullname3(tmpstr, CvGV(cv), Nullch);
2853         Perl_warner(aTHX_ packWARN(WARN_RECURSION), "Deep recursion on subroutine \"%"SVf"\"",
2854                 tmpstr);
2855     }
2856 }
2857
2858 PP(pp_aelem)
2859 {
2860     dSP;
2861     SV** svp;
2862     SV* elemsv = POPs;
2863     IV elem = SvIV(elemsv);
2864     AV* av = (AV*)POPs;
2865     U32 lval = PL_op->op_flags & OPf_MOD || LVRET;
2866     U32 defer = (PL_op->op_private & OPpLVAL_DEFER) && (elem > AvFILL(av));
2867     SV *sv;
2868
2869     if (SvROK(elemsv) && !SvGAMAGIC(elemsv) && ckWARN(WARN_MISC))
2870         Perl_warner(aTHX_ packWARN(WARN_MISC), "Use of reference \"%"SVf"\" as array index", elemsv);
2871     if (elem > 0)
2872         elem -= PL_curcop->cop_arybase;
2873     if (SvTYPE(av) != SVt_PVAV)
2874         RETPUSHUNDEF;
2875     svp = av_fetch(av, elem, lval && !defer);
2876     if (lval) {
2877         if (!svp || *svp == &PL_sv_undef) {
2878             SV* lv;
2879             if (!defer)
2880                 DIE(aTHX_ PL_no_aelem, elem);
2881             lv = sv_newmortal();
2882             sv_upgrade(lv, SVt_PVLV);
2883             LvTYPE(lv) = 'y';
2884             sv_magic(lv, Nullsv, PERL_MAGIC_defelem, Nullch, 0);
2885             LvTARG(lv) = SvREFCNT_inc(av);
2886             LvTARGOFF(lv) = elem;
2887             LvTARGLEN(lv) = 1;
2888             PUSHs(lv);
2889             RETURN;
2890         }
2891         if (PL_op->op_private & OPpLVAL_INTRO)
2892             save_aelem(av, elem, svp);
2893         else if (PL_op->op_private & OPpDEREF)
2894             vivify_ref(*svp, PL_op->op_private & OPpDEREF);
2895     }
2896     sv = (svp ? *svp : &PL_sv_undef);
2897     if (!lval && SvGMAGICAL(sv))        /* see note in pp_helem() */
2898         sv = sv_mortalcopy(sv);
2899     PUSHs(sv);
2900     RETURN;
2901 }
2902
2903 void
2904 Perl_vivify_ref(pTHX_ SV *sv, U32 to_what)
2905 {
2906     if (SvGMAGICAL(sv))
2907         mg_get(sv);
2908     if (!SvOK(sv)) {
2909         if (SvREADONLY(sv))
2910             Perl_croak(aTHX_ PL_no_modify);
2911         if (SvTYPE(sv) < SVt_RV)
2912             sv_upgrade(sv, SVt_RV);
2913         else if (SvTYPE(sv) >= SVt_PV) {
2914             (void)SvOOK_off(sv);
2915             Safefree(SvPVX(sv));
2916             SvLEN(sv) = SvCUR(sv) = 0;
2917         }
2918         switch (to_what) {
2919         case OPpDEREF_SV:
2920             SvRV(sv) = NEWSV(355,0);
2921             break;
2922         case OPpDEREF_AV:
2923             SvRV(sv) = (SV*)newAV();
2924             break;
2925         case OPpDEREF_HV:
2926             SvRV(sv) = (SV*)newHV();
2927             break;
2928         }
2929         SvROK_on(sv);
2930         SvSETMAGIC(sv);
2931     }
2932 }
2933
2934 PP(pp_method)
2935 {
2936     dSP;
2937     SV* sv = TOPs;
2938
2939     if (SvROK(sv)) {
2940         SV* rsv = SvRV(sv);
2941         if (SvTYPE(rsv) == SVt_PVCV) {
2942             SETs(rsv);
2943             RETURN;
2944         }
2945     }
2946
2947     SETs(method_common(sv, Null(U32*)));
2948     RETURN;
2949 }
2950
2951 PP(pp_method_named)
2952 {
2953     dSP;
2954     SV* sv = cSVOP_sv;
2955     U32 hash = SvUVX(sv);
2956
2957     XPUSHs(method_common(sv, &hash));
2958     RETURN;
2959 }
2960
2961 STATIC SV *
2962 S_method_common(pTHX_ SV* meth, U32* hashp)
2963 {
2964     SV* sv;
2965     SV* ob;
2966     GV* gv;
2967     HV* stash;
2968     char* name;
2969     STRLEN namelen;
2970     char* packname = 0;
2971     SV *packsv = Nullsv;
2972     STRLEN packlen;
2973
2974     name = SvPV(meth, namelen);
2975     sv = *(PL_stack_base + TOPMARK + 1);
2976
2977     if (!sv)
2978         Perl_croak(aTHX_ "Can't call method \"%s\" on an undefined value", name);
2979
2980     if (SvGMAGICAL(sv))
2981         mg_get(sv);
2982     if (SvROK(sv))
2983         ob = (SV*)SvRV(sv);
2984     else {
2985         GV* iogv;
2986
2987         /* this isn't a reference */
2988         packname = Nullch;
2989
2990         if(SvOK(sv) && (packname = SvPV(sv, packlen))) {
2991           HE* he;
2992           he = hv_fetch_ent(PL_stashcache, sv, 0, 0);
2993           if (he) {
2994             stash = INT2PTR(HV*,SvIV(HeVAL(he)));
2995             goto fetch;
2996           }
2997         }
2998
2999         if (!SvOK(sv) ||
3000             !(packname) ||
3001             !(iogv = gv_fetchpv(packname, FALSE, SVt_PVIO)) ||
3002             !(ob=(SV*)GvIO(iogv)))
3003         {
3004             /* this isn't the name of a filehandle either */
3005             if (!packname ||
3006                 ((UTF8_IS_START(*packname) && DO_UTF8(sv))
3007                     ? !isIDFIRST_utf8((U8*)packname)
3008                     : !isIDFIRST(*packname)
3009                 ))
3010             {
3011                 Perl_croak(aTHX_ "Can't call method \"%s\" %s", name,
3012                            SvOK(sv) ? "without a package or object reference"
3013                                     : "on an undefined value");
3014             }
3015             /* assume it's a package name */
3016             stash = gv_stashpvn(packname, packlen, FALSE);
3017             if (!stash)
3018                 packsv = sv;
3019             else {
3020                 SV* ref = newSViv(PTR2IV(stash));
3021                 hv_store(PL_stashcache, packname, packlen, ref, 0);
3022             }
3023             goto fetch;
3024         }
3025         /* it _is_ a filehandle name -- replace with a reference */
3026         *(PL_stack_base + TOPMARK + 1) = sv_2mortal(newRV((SV*)iogv));
3027     }
3028
3029     /* if we got here, ob should be a reference or a glob */
3030     if (!ob || !(SvOBJECT(ob)
3031                  || (SvTYPE(ob) == SVt_PVGV && (ob = (SV*)GvIO((GV*)ob))
3032                      && SvOBJECT(ob))))
3033     {
3034         Perl_croak(aTHX_ "Can't call method \"%s\" on unblessed reference",
3035                    name);
3036     }
3037
3038     stash = SvSTASH(ob);
3039
3040   fetch:
3041     /* NOTE: stash may be null, hope hv_fetch_ent and
3042        gv_fetchmethod can cope (it seems they can) */
3043
3044     /* shortcut for simple names */
3045     if (hashp) {
3046         HE* he = hv_fetch_ent(stash, meth, 0, *hashp);
3047         if (he) {
3048             gv = (GV*)HeVAL(he);
3049             if (isGV(gv) && GvCV(gv) &&
3050                 (!GvCVGEN(gv) || GvCVGEN(gv) == PL_sub_generation))
3051                 return (SV*)GvCV(gv);
3052         }
3053     }
3054
3055     gv = gv_fetchmethod(stash ? stash : (HV*)packsv, name);
3056
3057     if (!gv) {
3058         /* This code tries to figure out just what went wrong with
3059            gv_fetchmethod.  It therefore needs to duplicate a lot of
3060            the internals of that function.  We can't move it inside
3061            Perl_gv_fetchmethod_autoload(), however, since that would
3062            cause UNIVERSAL->can("NoSuchPackage::foo") to croak, and we
3063            don't want that.
3064         */
3065         char* leaf = name;
3066         char* sep = Nullch;
3067         char* p;
3068
3069         for (p = name; *p; p++) {
3070             if (*p == '\'')
3071                 sep = p, leaf = p + 1;
3072             else if (*p == ':' && *(p + 1) == ':')
3073                 sep = p, leaf = p + 2;
3074         }
3075         if (!sep || ((sep - name) == 5 && strnEQ(name, "SUPER", 5))) {
3076             /* the method name is unqualified or starts with SUPER:: */
3077             packname = sep ? CopSTASHPV(PL_curcop) :
3078                 stash ? HvNAME(stash) : packname;
3079             if (!packname)
3080                 Perl_croak(aTHX_
3081                            "Can't use anonymous symbol table for method lookup");
3082             else
3083                 packlen = strlen(packname);
3084         }
3085         else {
3086             /* the method name is qualified */
3087             packname = name;
3088             packlen = sep - name;
3089         }
3090
3091         /* we're relying on gv_fetchmethod not autovivifying the stash */
3092         if (gv_stashpvn(packname, packlen, FALSE)) {
3093             Perl_croak(aTHX_
3094                        "Can't locate object method \"%s\" via package \"%.*s\"",
3095                        leaf, (int)packlen, packname);
3096         }
3097         else {
3098             Perl_croak(aTHX_
3099                        "Can't locate object method \"%s\" via package \"%.*s\""
3100                        " (perhaps you forgot to load \"%.*s\"?)",
3101                        leaf, (int)packlen, packname, (int)packlen, packname);
3102         }
3103     }
3104     return isGV(gv) ? (SV*)GvCV(gv) : (SV*)gv;
3105 }