pp_hot.c

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