pp_hot.c

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