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