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_setpvn(left, "", 0);
 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                 DIE(aTHX_ PL_no_helem_sv, keysv);
1713             }
1714             lv = sv_newmortal();
1715             sv_upgrade(lv, SVt_PVLV);
1716             LvTYPE(lv) = 'y';
1717             sv_magic(lv, key2 = newSVsv(keysv), PERL_MAGIC_defelem, Nullch, 0);
1718             SvREFCNT_dec(key2); /* sv_magic() increments refcount */
1719             LvTARG(lv) = SvREFCNT_inc(hv);
1720             LvTARGLEN(lv) = 1;
1721             PUSHs(lv);
1722             RETURN;
1723         }
1724         if (PL_op->op_private & OPpLVAL_INTRO) {
1725             if (HvNAME(hv) && isGV(*svp))
1726                 save_gp((GV*)*svp, !(PL_op->op_flags & OPf_SPECIAL));
1727             else {
1728                 if (!preeminent) {
1729                     STRLEN keylen;
1730                     char *key = SvPV(keysv, keylen);
1731                     SAVEDELETE(hv, savepvn(key,keylen), keylen);
1732                 } else
1733                     save_helem(hv, keysv, svp);
1734             }
1735         }
1736         else if (PL_op->op_private & OPpDEREF)
1737             vivify_ref(*svp, PL_op->op_private & OPpDEREF);
1738     }
1739     sv = (svp ? *svp : &PL_sv_undef);
1740     /* This makes C<local $tied{foo} = $tied{foo}> possible.
1741      * Pushing the magical RHS on to the stack is useless, since
1742      * that magic is soon destined to be misled by the local(),
1743      * and thus the later pp_sassign() will fail to mg_get() the
1744      * old value.  This should also cure problems with delayed
1745      * mg_get()s.  GSAR 98-07-03 */
1746     if (!lval && SvGMAGICAL(sv))
1747         sv = sv_mortalcopy(sv);
1748     PUSHs(sv);
1749     RETURN;
1750 }
1751
1752 PP(pp_leave)
1753 {
1754     dVAR; dSP;
1755     register PERL_CONTEXT *cx;
1756     register SV **mark;
1757     SV **newsp;
1758     PMOP *newpm;
1759     I32 gimme;
1760
1761     if (PL_op->op_flags & OPf_SPECIAL) {
1762         cx = &cxstack[cxstack_ix];
1763         cx->blk_oldpm = PL_curpm;       /* fake block should preserve $1 et al */
1764     }
1765
1766     POPBLOCK(cx,newpm);
1767
1768     gimme = OP_GIMME(PL_op, -1);
1769     if (gimme == -1) {
1770         if (cxstack_ix >= 0)
1771             gimme = cxstack[cxstack_ix].blk_gimme;
1772         else
1773             gimme = G_SCALAR;
1774     }
1775
1776     TAINT_NOT;
1777     if (gimme == G_VOID)
1778         SP = newsp;
1779     else if (gimme == G_SCALAR) {
1780         MARK = newsp + 1;
1781         if (MARK <= SP) {
1782             if (SvFLAGS(TOPs) & (SVs_PADTMP|SVs_TEMP))
1783                 *MARK = TOPs;
1784             else
1785                 *MARK = sv_mortalcopy(TOPs);
1786         } else {
1787             MEXTEND(mark,0);
1788             *MARK = &PL_sv_undef;
1789         }
1790         SP = MARK;
1791     }
1792     else if (gimme == G_ARRAY) {
1793         /* in case LEAVE wipes old return values */
1794         for (mark = newsp + 1; mark <= SP; mark++) {
1795             if (!(SvFLAGS(*mark) & (SVs_PADTMP|SVs_TEMP))) {
1796                 *mark = sv_mortalcopy(*mark);
1797                 TAINT_NOT;      /* Each item is independent */
1798             }
1799         }
1800     }
1801     PL_curpm = newpm;   /* Don't pop $1 et al till now */
1802
1803     LEAVE;
1804
1805     RETURN;
1806 }
1807
1808 PP(pp_iter)
1809 {
1810     dSP;
1811     register PERL_CONTEXT *cx;
1812     SV *sv, *oldsv;
1813     AV* av;
1814     SV **itersvp;
1815
1816     EXTEND(SP, 1);
1817     cx = &cxstack[cxstack_ix];
1818     if (CxTYPE(cx) != CXt_LOOP)
1819         DIE(aTHX_ "panic: pp_iter");
1820
1821     itersvp = CxITERVAR(cx);
1822     av = cx->blk_loop.iterary;
1823     if (SvTYPE(av) != SVt_PVAV) {
1824         /* iterate ($min .. $max) */
1825         if (cx->blk_loop.iterlval) {
1826             /* string increment */
1827             register SV* cur = cx->blk_loop.iterlval;
1828             STRLEN maxlen = 0;
1829             const char *max = SvOK((SV*)av) ? SvPV((SV*)av, maxlen) : "";
1830             if (!SvNIOK(cur) && SvCUR(cur) <= maxlen) {
1831                 if (SvREFCNT(*itersvp) == 1 && !SvMAGICAL(*itersvp)) {
1832                     /* safe to reuse old SV */
1833                     sv_setsv(*itersvp, cur);
1834                 }
1835                 else
1836                 {
1837                     /* we need a fresh SV every time so that loop body sees a
1838                      * completely new SV for closures/references to work as
1839                      * they used to */
1840                     oldsv = *itersvp;
1841                     *itersvp = newSVsv(cur);
1842                     SvREFCNT_dec(oldsv);
1843                 }
1844                 if (strEQ(SvPVX(cur), max))
1845                     sv_setiv(cur, 0); /* terminate next time */
1846                 else
1847                     sv_inc(cur);
1848                 RETPUSHYES;
1849             }
1850             RETPUSHNO;
1851         }
1852         /* integer increment */
1853         if (cx->blk_loop.iterix > cx->blk_loop.itermax)
1854             RETPUSHNO;
1855
1856         /* don't risk potential race */
1857         if (SvREFCNT(*itersvp) == 1 && !SvMAGICAL(*itersvp)) {
1858             /* safe to reuse old SV */
1859             sv_setiv(*itersvp, cx->blk_loop.iterix++);
1860         }
1861         else
1862         {
1863             /* we need a fresh SV every time so that loop body sees a
1864              * completely new SV for closures/references to work as they
1865              * used to */
1866             oldsv = *itersvp;
1867             *itersvp = newSViv(cx->blk_loop.iterix++);
1868             SvREFCNT_dec(oldsv);
1869         }
1870         RETPUSHYES;
1871     }
1872
1873     /* iterate array */
1874     if (PL_op->op_private & OPpITER_REVERSED) {
1875         /* In reverse, use itermax as the min :-)  */
1876         if (cx->blk_loop.iterix <= cx->blk_loop.itermax)
1877             RETPUSHNO;
1878
1879         if (SvMAGICAL(av) || AvREIFY(av)) {
1880             SV **svp = av_fetch(av, cx->blk_loop.iterix--, FALSE);
1881             if (svp)
1882                 sv = *svp;
1883             else
1884                 sv = Nullsv;
1885         }
1886         else {
1887             sv = AvARRAY(av)[cx->blk_loop.iterix--];
1888         }
1889     }
1890     else {
1891         if (cx->blk_loop.iterix >= (av == PL_curstack ? cx->blk_oldsp :
1892                                     AvFILL(av)))
1893             RETPUSHNO;
1894
1895         if (SvMAGICAL(av) || AvREIFY(av)) {
1896             SV **svp = av_fetch(av, ++cx->blk_loop.iterix, FALSE);
1897             if (svp)
1898                 sv = *svp;
1899             else
1900                 sv = Nullsv;
1901         }
1902         else {
1903             sv = AvARRAY(av)[++cx->blk_loop.iterix];
1904         }
1905     }
1906
1907     if (sv && SvREFCNT(sv) == 0) {
1908         *itersvp = Nullsv;
1909         Perl_croak(aTHX_ "Use of freed value in iteration");
1910     }
1911
1912     if (sv)
1913         SvTEMP_off(sv);
1914     else
1915         sv = &PL_sv_undef;
1916     if (av != PL_curstack && sv == &PL_sv_undef) {
1917         SV *lv = cx->blk_loop.iterlval;
1918         if (lv && SvREFCNT(lv) > 1) {
1919             SvREFCNT_dec(lv);
1920             lv = Nullsv;
1921         }
1922         if (lv)
1923             SvREFCNT_dec(LvTARG(lv));
1924         else {
1925             lv = cx->blk_loop.iterlval = NEWSV(26, 0);
1926             sv_upgrade(lv, SVt_PVLV);
1927             LvTYPE(lv) = 'y';
1928             sv_magic(lv, Nullsv, PERL_MAGIC_defelem, Nullch, 0);
1929         }
1930         LvTARG(lv) = SvREFCNT_inc(av);
1931         LvTARGOFF(lv) = cx->blk_loop.iterix;
1932         LvTARGLEN(lv) = (STRLEN)UV_MAX;
1933         sv = (SV*)lv;
1934     }
1935
1936     oldsv = *itersvp;
1937     *itersvp = SvREFCNT_inc(sv);
1938     SvREFCNT_dec(oldsv);
1939
1940     RETPUSHYES;
1941 }
1942
1943 PP(pp_subst)
1944 {
1945     dSP; dTARG;
1946     register PMOP *pm = cPMOP;
1947     PMOP *rpm = pm;
1948     register SV *dstr;
1949     register char *s;
1950     char *strend;
1951     register char *m;
1952     char *c;
1953     register char *d;
1954     STRLEN clen;
1955     I32 iters = 0;
1956     I32 maxiters;
1957     register I32 i;
1958     bool once;
1959     bool rxtainted;
1960     char *orig;
1961     I32 r_flags;
1962     register REGEXP *rx = PM_GETRE(pm);
1963     STRLEN len;
1964     int force_on_match = 0;
1965     I32 oldsave = PL_savestack_ix;
1966     STRLEN slen;
1967     bool doutf8 = FALSE;
1968 #ifdef PERL_COPY_ON_WRITE
1969     bool is_cow;
1970 #endif
1971     SV *nsv = Nullsv;
1972
1973     /* known replacement string? */
1974     dstr = (pm->op_pmflags & PMf_CONST) ? POPs : Nullsv;
1975     if (PL_op->op_flags & OPf_STACKED)
1976         TARG = POPs;
1977     else if (PL_op->op_private & OPpTARGET_MY)
1978         GETTARGET;
1979     else {
1980         TARG = DEFSV;
1981         EXTEND(SP,1);
1982     }
1983
1984 #ifdef PERL_COPY_ON_WRITE
1985     /* Awooga. Awooga. "bool" types that are actually char are dangerous,
1986        because they make integers such as 256 "false".  */
1987     is_cow = SvIsCOW(TARG) ? TRUE : FALSE;
1988 #else
1989     if (SvIsCOW(TARG))
1990         sv_force_normal_flags(TARG,0);
1991 #endif
1992     if (
1993 #ifdef PERL_COPY_ON_WRITE
1994         !is_cow &&
1995 #endif
1996         (SvREADONLY(TARG)
1997         || ( (SvTYPE(TARG) == SVt_PVGV || SvTYPE(TARG) > SVt_PVLV)
1998              && !(SvTYPE(TARG) == SVt_PVGV && SvFAKE(TARG)))))
1999         DIE(aTHX_ PL_no_modify);
2000     PUTBACK;
2001
2002     s = SvPV(TARG, len);
2003     if (!SvPOKp(TARG) || SvTYPE(TARG) == SVt_PVGV)
2004         force_on_match = 1;
2005     rxtainted = ((pm->op_pmdynflags & PMdf_TAINTED) ||
2006                  (PL_tainted && (pm->op_pmflags & PMf_RETAINT)));
2007     if (PL_tainted)
2008         rxtainted |= 2;
2009     TAINT_NOT;
2010
2011     RX_MATCH_UTF8_set(rx, DO_UTF8(TARG));
2012
2013   force_it:
2014     if (!pm || !s)
2015         DIE(aTHX_ "panic: pp_subst");
2016
2017     strend = s + len;
2018     slen = RX_MATCH_UTF8(rx) ? utf8_length((U8*)s, (U8*)strend) : len;
2019     maxiters = 2 * slen + 10;   /* We can match twice at each
2020                                    position, once with zero-length,
2021                                    second time with non-zero. */
2022
2023     if (!rx->prelen && PL_curpm) {
2024         pm = PL_curpm;
2025         rx = PM_GETRE(pm);
2026     }
2027     r_flags = (rx->nparens || SvTEMP(TARG) || PL_sawampersand)
2028                ? REXEC_COPY_STR : 0;
2029     if (SvSCREAM(TARG))
2030         r_flags |= REXEC_SCREAM;
2031
2032     orig = m = s;
2033     if (rx->reganch & RE_USE_INTUIT) {
2034         PL_bostr = orig;
2035         s = CALLREG_INTUIT_START(aTHX_ rx, TARG, s, strend, r_flags, NULL);
2036
2037         if (!s)
2038             goto nope;
2039         /* How to do it in subst? */
2040 /*      if ( (rx->reganch & ROPT_CHECK_ALL)
2041              && !PL_sawampersand
2042              && ((rx->reganch & ROPT_NOSCAN)
2043                  || !((rx->reganch & RE_INTUIT_TAIL)
2044                       && (r_flags & REXEC_SCREAM))))
2045             goto yup;
2046 */
2047     }
2048
2049     /* only replace once? */
2050     once = !(rpm->op_pmflags & PMf_GLOBAL);
2051
2052     /* known replacement string? */
2053     if (dstr) {
2054         /* replacement needing upgrading? */
2055         if (DO_UTF8(TARG) && !doutf8) {
2056              nsv = sv_newmortal();
2057              SvSetSV(nsv, dstr);
2058              if (PL_encoding)
2059                   sv_recode_to_utf8(nsv, PL_encoding);
2060              else
2061                   sv_utf8_upgrade(nsv);
2062              c = SvPV(nsv, clen);
2063              doutf8 = TRUE;
2064         }
2065         else {
2066             c = SvPV(dstr, clen);
2067             doutf8 = DO_UTF8(dstr);
2068         }
2069     }
2070     else {
2071         c = Nullch;
2072         doutf8 = FALSE;
2073     }
2074
2075     /* can do inplace substitution? */
2076     if (c
2077 #ifdef PERL_COPY_ON_WRITE
2078         && !is_cow
2079 #endif
2080         && (I32)clen <= rx->minlen && (once || !(r_flags & REXEC_COPY_STR))
2081         && !(rx->reganch & ROPT_LOOKBEHIND_SEEN)
2082         && (!doutf8 || SvUTF8(TARG))) {
2083         if (!CALLREGEXEC(aTHX_ rx, s, strend, orig, 0, TARG, NULL,
2084                          r_flags | REXEC_CHECKED))
2085         {
2086             SPAGAIN;
2087             PUSHs(&PL_sv_no);
2088             LEAVE_SCOPE(oldsave);
2089             RETURN;
2090         }
2091 #ifdef PERL_COPY_ON_WRITE
2092         if (SvIsCOW(TARG)) {
2093             assert (!force_on_match);
2094             goto have_a_cow;
2095         }
2096 #endif
2097         if (force_on_match) {
2098             force_on_match = 0;
2099             s = SvPV_force(TARG, len);
2100             goto force_it;
2101         }
2102         d = s;
2103         PL_curpm = pm;
2104         SvSCREAM_off(TARG);     /* disable possible screamer */
2105         if (once) {
2106             rxtainted |= RX_MATCH_TAINTED(rx);
2107             m = orig + rx->startp[0];
2108             d = orig + rx->endp[0];
2109             s = orig;
2110             if (m - s > strend - d) {  /* faster to shorten from end */
2111                 if (clen) {
2112                     Copy(c, m, clen, char);
2113                     m += clen;
2114                 }
2115                 i = strend - d;
2116                 if (i > 0) {
2117                     Move(d, m, i, char);
2118                     m += i;
2119                 }
2120                 *m = '\0';
2121                 SvCUR_set(TARG, m - s);
2122             }
2123             /*SUPPRESS 560*/
2124             else if ((i = m - s)) {     /* faster from front */
2125                 d -= clen;
2126                 m = d;
2127                 sv_chop(TARG, d-i);
2128                 s += i;
2129                 while (i--)
2130                     *--d = *--s;
2131                 if (clen)
2132                     Copy(c, m, clen, char);
2133             }
2134             else if (clen) {
2135                 d -= clen;
2136                 sv_chop(TARG, d);
2137                 Copy(c, d, clen, char);
2138             }
2139             else {
2140                 sv_chop(TARG, d);
2141             }
2142             TAINT_IF(rxtainted & 1);
2143             SPAGAIN;
2144             PUSHs(&PL_sv_yes);
2145         }
2146         else {
2147             do {
2148                 if (iters++ > maxiters)
2149                     DIE(aTHX_ "Substitution loop");
2150                 rxtainted |= RX_MATCH_TAINTED(rx);
2151                 m = rx->startp[0] + orig;
2152                 /*SUPPRESS 560*/
2153                 if ((i = m - s)) {
2154                     if (s != d)
2155                         Move(s, d, i, char);
2156                     d += i;
2157                 }
2158                 if (clen) {
2159                     Copy(c, d, clen, char);
2160                     d += clen;
2161                 }
2162                 s = rx->endp[0] + orig;
2163             } while (CALLREGEXEC(aTHX_ rx, s, strend, orig, s == m,
2164                                  TARG, NULL,
2165                                  /* don't match same null twice */
2166                                  REXEC_NOT_FIRST|REXEC_IGNOREPOS));
2167             if (s != d) {
2168                 i = strend - s;
2169                 SvCUR_set(TARG, d - SvPVX(TARG) + i);
2170                 Move(s, d, i+1, char);          /* include the NUL */
2171             }
2172             TAINT_IF(rxtainted & 1);
2173             SPAGAIN;
2174             PUSHs(sv_2mortal(newSViv((I32)iters)));
2175         }
2176         (void)SvPOK_only_UTF8(TARG);
2177         TAINT_IF(rxtainted);
2178         if (SvSMAGICAL(TARG)) {
2179             PUTBACK;
2180             mg_set(TARG);
2181             SPAGAIN;
2182         }
2183         SvTAINT(TARG);
2184         if (doutf8)
2185             SvUTF8_on(TARG);
2186         LEAVE_SCOPE(oldsave);
2187         RETURN;
2188     }
2189
2190     if (CALLREGEXEC(aTHX_ rx, s, strend, orig, 0, TARG, NULL,
2191                     r_flags | REXEC_CHECKED))
2192     {
2193         if (force_on_match) {
2194             force_on_match = 0;
2195             s = SvPV_force(TARG, len);
2196             goto force_it;
2197         }
2198 #ifdef PERL_COPY_ON_WRITE
2199       have_a_cow:
2200 #endif
2201         rxtainted |= RX_MATCH_TAINTED(rx);
2202         dstr = newSVpvn(m, s-m);
2203         if (DO_UTF8(TARG))
2204             SvUTF8_on(dstr);
2205         PL_curpm = pm;
2206         if (!c) {
2207             register PERL_CONTEXT *cx;
2208             SPAGAIN;
2209             ReREFCNT_inc(rx);
2210             PUSHSUBST(cx);
2211             RETURNOP(cPMOP->op_pmreplroot);
2212         }
2213         r_flags |= REXEC_IGNOREPOS | REXEC_NOT_FIRST;
2214         do {
2215             if (iters++ > maxiters)
2216                 DIE(aTHX_ "Substitution loop");
2217             rxtainted |= RX_MATCH_TAINTED(rx);
2218             if (RX_MATCH_COPIED(rx) && rx->subbeg != orig) {
2219                 m = s;
2220                 s = orig;
2221                 orig = rx->subbeg;
2222                 s = orig + (m - s);
2223                 strend = s + (strend - m);
2224             }
2225             m = rx->startp[0] + orig;
2226             if (doutf8 && !SvUTF8(dstr))
2227                 sv_catpvn_utf8_upgrade(dstr, s, m - s, nsv);
2228             else
2229                 sv_catpvn(dstr, s, m-s);
2230             s = rx->endp[0] + orig;
2231             if (clen)
2232                 sv_catpvn(dstr, c, clen);
2233             if (once)
2234                 break;
2235         } while (CALLREGEXEC(aTHX_ rx, s, strend, orig, s == m,
2236                              TARG, NULL, r_flags));
2237         if (doutf8 && !DO_UTF8(TARG))
2238             sv_catpvn_utf8_upgrade(dstr, s, strend - s, nsv);
2239         else
2240             sv_catpvn(dstr, s, strend - s);
2241
2242 #ifdef PERL_COPY_ON_WRITE
2243         /* The match may make the string COW. If so, brilliant, because that's
2244            just saved us one malloc, copy and free - the regexp has donated
2245            the old buffer, and we malloc an entirely new one, rather than the
2246            regexp malloc()ing a buffer and copying our original, only for
2247            us to throw it away here during the substitution.  */
2248         if (SvIsCOW(TARG)) {
2249             sv_force_normal_flags(TARG, SV_COW_DROP_PV);
2250         } else
2251 #endif
2252         {
2253             SvPV_free(TARG);
2254         }
2255         SvPV_set(TARG, SvPVX(dstr));
2256         SvCUR_set(TARG, SvCUR(dstr));
2257         SvLEN_set(TARG, SvLEN(dstr));
2258         doutf8 |= DO_UTF8(dstr);
2259         SvPV_set(dstr, (char*)0);
2260         sv_free(dstr);
2261
2262         TAINT_IF(rxtainted & 1);
2263         SPAGAIN;
2264         PUSHs(sv_2mortal(newSViv((I32)iters)));
2265
2266         (void)SvPOK_only(TARG);
2267         if (doutf8)
2268             SvUTF8_on(TARG);
2269         TAINT_IF(rxtainted);
2270         SvSETMAGIC(TARG);
2271         SvTAINT(TARG);
2272         LEAVE_SCOPE(oldsave);
2273         RETURN;
2274     }
2275     goto ret_no;
2276
2277 nope:
2278 ret_no:
2279     SPAGAIN;
2280     PUSHs(&PL_sv_no);
2281     LEAVE_SCOPE(oldsave);
2282     RETURN;
2283 }
2284
2285 PP(pp_grepwhile)
2286 {
2287     dVAR; dSP;
2288
2289     if (SvTRUEx(POPs))
2290         PL_stack_base[PL_markstack_ptr[-1]++] = PL_stack_base[*PL_markstack_ptr];
2291     ++*PL_markstack_ptr;
2292     LEAVE;                                      /* exit inner scope */
2293
2294     /* All done yet? */
2295     if (PL_stack_base + *PL_markstack_ptr > SP) {
2296         I32 items;
2297         I32 gimme = GIMME_V;
2298
2299         LEAVE;                                  /* exit outer scope */
2300         (void)POPMARK;                          /* pop src */
2301         items = --*PL_markstack_ptr - PL_markstack_ptr[-1];
2302         (void)POPMARK;                          /* pop dst */
2303         SP = PL_stack_base + POPMARK;           /* pop original mark */
2304         if (gimme == G_SCALAR) {
2305             if (PL_op->op_private & OPpGREP_LEX) {
2306                 SV* sv = sv_newmortal();
2307                 sv_setiv(sv, items);
2308                 PUSHs(sv);
2309             }
2310             else {
2311                 dTARGET;
2312                 XPUSHi(items);
2313             }
2314         }
2315         else if (gimme == G_ARRAY)
2316             SP += items;
2317         RETURN;
2318     }
2319     else {
2320         SV *src;
2321
2322         ENTER;                                  /* enter inner scope */
2323         SAVEVPTR(PL_curpm);
2324
2325         src = PL_stack_base[*PL_markstack_ptr];
2326         SvTEMP_off(src);
2327         if (PL_op->op_private & OPpGREP_LEX)
2328             PAD_SVl(PL_op->op_targ) = src;
2329         else
2330             DEFSV = src;
2331
2332         RETURNOP(cLOGOP->op_other);
2333     }
2334 }
2335
2336 PP(pp_leavesub)
2337 {
2338     dVAR; dSP;
2339     SV **mark;
2340     SV **newsp;
2341     PMOP *newpm;
2342     I32 gimme;
2343     register PERL_CONTEXT *cx;
2344     SV *sv;
2345
2346     POPBLOCK(cx,newpm);
2347     cxstack_ix++; /* temporarily protect top context */
2348
2349     TAINT_NOT;
2350     if (gimme == G_SCALAR) {
2351         MARK = newsp + 1;
2352         if (MARK <= SP) {
2353             if (cx->blk_sub.cv && CvDEPTH(cx->blk_sub.cv) > 1) {
2354                 if (SvTEMP(TOPs)) {
2355                     *MARK = SvREFCNT_inc(TOPs);
2356                     FREETMPS;
2357                     sv_2mortal(*MARK);
2358                 }
2359                 else {
2360                     sv = SvREFCNT_inc(TOPs);    /* FREETMPS could clobber it */
2361                     FREETMPS;
2362                     *MARK = sv_mortalcopy(sv);
2363                     SvREFCNT_dec(sv);
2364                 }
2365             }
2366             else
2367                 *MARK = SvTEMP(TOPs) ? TOPs : sv_mortalcopy(TOPs);
2368         }
2369         else {
2370             MEXTEND(MARK, 0);
2371             *MARK = &PL_sv_undef;
2372         }
2373         SP = MARK;
2374     }
2375     else if (gimme == G_ARRAY) {
2376         for (MARK = newsp + 1; MARK <= SP; MARK++) {
2377             if (!SvTEMP(*MARK)) {
2378                 *MARK = sv_mortalcopy(*MARK);
2379                 TAINT_NOT;      /* Each item is independent */
2380             }
2381         }
2382     }
2383     PUTBACK;
2384
2385     LEAVE;
2386     cxstack_ix--;
2387     POPSUB(cx,sv);      /* Stack values are safe: release CV and @_ ... */
2388     PL_curpm = newpm;   /* ... and pop $1 et al */
2389
2390     LEAVESUB(sv);
2391     return cx->blk_sub.retop;
2392 }
2393
2394 /* This duplicates the above code because the above code must not
2395  * get any slower by more conditions */
2396 PP(pp_leavesublv)
2397 {
2398     dVAR; dSP;
2399     SV **mark;
2400     SV **newsp;
2401     PMOP *newpm;
2402     I32 gimme;
2403     register PERL_CONTEXT *cx;
2404     SV *sv;
2405
2406     POPBLOCK(cx,newpm);
2407     cxstack_ix++; /* temporarily protect top context */
2408
2409     TAINT_NOT;
2410
2411     if (cx->blk_sub.lval & OPpENTERSUB_INARGS) {
2412         /* We are an argument to a function or grep().
2413          * This kind of lvalueness was legal before lvalue
2414          * subroutines too, so be backward compatible:
2415          * cannot report errors.  */
2416
2417         /* Scalar context *is* possible, on the LHS of -> only,
2418          * as in f()->meth().  But this is not an lvalue. */
2419         if (gimme == G_SCALAR)
2420             goto temporise;
2421         if (gimme == G_ARRAY) {
2422             if (!CvLVALUE(cx->blk_sub.cv))
2423                 goto temporise_array;
2424             EXTEND_MORTAL(SP - newsp);
2425             for (mark = newsp + 1; mark <= SP; mark++) {
2426                 if (SvTEMP(*mark))
2427                     /* empty */ ;
2428                 else if (SvFLAGS(*mark) & (SVs_PADTMP | SVf_READONLY))
2429                     *mark = sv_mortalcopy(*mark);
2430                 else {
2431                     /* Can be a localized value subject to deletion. */
2432                     PL_tmps_stack[++PL_tmps_ix] = *mark;
2433                     (void)SvREFCNT_inc(*mark);
2434                 }
2435             }
2436         }
2437     }
2438     else if (cx->blk_sub.lval) {     /* Leave it as it is if we can. */
2439         /* Here we go for robustness, not for speed, so we change all
2440          * the refcounts so the caller gets a live guy. Cannot set
2441          * TEMP, so sv_2mortal is out of question. */
2442         if (!CvLVALUE(cx->blk_sub.cv)) {
2443             LEAVE;
2444             cxstack_ix--;
2445             POPSUB(cx,sv);
2446             PL_curpm = newpm;
2447             LEAVESUB(sv);
2448             DIE(aTHX_ "Can't modify non-lvalue subroutine call");
2449         }
2450         if (gimme == G_SCALAR) {
2451             MARK = newsp + 1;
2452             EXTEND_MORTAL(1);
2453             if (MARK == SP) {
2454                 if (SvFLAGS(TOPs) & (SVs_TEMP | SVs_PADTMP | SVf_READONLY)) {
2455                     LEAVE;
2456                     cxstack_ix--;
2457                     POPSUB(cx,sv);
2458                     PL_curpm = newpm;
2459                     LEAVESUB(sv);
2460                     DIE(aTHX_ "Can't return %s from lvalue subroutine",
2461                         SvREADONLY(TOPs) ? (TOPs == &PL_sv_undef) ? "undef"
2462                         : "a readonly value" : "a temporary");
2463                 }
2464                 else {                  /* Can be a localized value
2465                                          * subject to deletion. */
2466                     PL_tmps_stack[++PL_tmps_ix] = *mark;
2467                     (void)SvREFCNT_inc(*mark);
2468                 }
2469             }
2470             else {                      /* Should not happen? */
2471                 LEAVE;
2472                 cxstack_ix--;
2473                 POPSUB(cx,sv);
2474                 PL_curpm = newpm;
2475                 LEAVESUB(sv);
2476                 DIE(aTHX_ "%s returned from lvalue subroutine in scalar context",
2477                     (MARK > SP ? "Empty array" : "Array"));
2478             }
2479             SP = MARK;
2480         }
2481         else if (gimme == G_ARRAY) {
2482             EXTEND_MORTAL(SP - newsp);
2483             for (mark = newsp + 1; mark <= SP; mark++) {
2484                 if (*mark != &PL_sv_undef
2485                     && SvFLAGS(*mark) & (SVs_TEMP | SVs_PADTMP | SVf_READONLY)) {
2486                     /* Might be flattened array after $#array =  */
2487                     PUTBACK;
2488                     LEAVE;
2489                     cxstack_ix--;
2490                     POPSUB(cx,sv);
2491                     PL_curpm = newpm;
2492                     LEAVESUB(sv);
2493                     DIE(aTHX_ "Can't return a %s from lvalue subroutine",
2494                         SvREADONLY(TOPs) ? "readonly value" : "temporary");
2495                 }
2496                 else {
2497                     /* Can be a localized value subject to deletion. */
2498                     PL_tmps_stack[++PL_tmps_ix] = *mark;
2499                     (void)SvREFCNT_inc(*mark);
2500                 }
2501             }
2502         }
2503     }
2504     else {
2505         if (gimme == G_SCALAR) {
2506           temporise:
2507             MARK = newsp + 1;
2508             if (MARK <= SP) {
2509                 if (cx->blk_sub.cv && CvDEPTH(cx->blk_sub.cv) > 1) {
2510                     if (SvTEMP(TOPs)) {
2511                         *MARK = SvREFCNT_inc(TOPs);
2512                         FREETMPS;
2513                         sv_2mortal(*MARK);
2514                     }
2515                     else {
2516                         sv = SvREFCNT_inc(TOPs); /* FREETMPS could clobber it */
2517                         FREETMPS;
2518                         *MARK = sv_mortalcopy(sv);
2519                         SvREFCNT_dec(sv);
2520                     }
2521                 }
2522                 else
2523                     *MARK = SvTEMP(TOPs) ? TOPs : sv_mortalcopy(TOPs);
2524             }
2525             else {
2526                 MEXTEND(MARK, 0);
2527                 *MARK = &PL_sv_undef;
2528             }
2529             SP = MARK;
2530         }
2531         else if (gimme == G_ARRAY) {
2532           temporise_array:
2533             for (MARK = newsp + 1; MARK <= SP; MARK++) {
2534                 if (!SvTEMP(*MARK)) {
2535                     *MARK = sv_mortalcopy(*MARK);
2536                     TAINT_NOT;  /* Each item is independent */
2537                 }
2538             }
2539         }
2540     }
2541     PUTBACK;
2542
2543     LEAVE;
2544     cxstack_ix--;
2545     POPSUB(cx,sv);      /* Stack values are safe: release CV and @_ ... */
2546     PL_curpm = newpm;   /* ... and pop $1 et al */
2547
2548     LEAVESUB(sv);
2549     return cx->blk_sub.retop;
2550 }
2551
2552
2553 STATIC CV *
2554 S_get_db_sub(pTHX_ SV **svp, CV *cv)
2555 {
2556     SV *dbsv = GvSV(PL_DBsub);
2557
2558     save_item(dbsv);
2559     if (!PERLDB_SUB_NN) {
2560         GV *gv = CvGV(cv);
2561
2562         if ( (CvFLAGS(cv) & (CVf_ANON | CVf_CLONED))
2563              || strEQ(GvNAME(gv), "END")
2564              || ((GvCV(gv) != cv) && /* Could be imported, and old sub redefined. */
2565                  !( (SvTYPE(*svp) == SVt_PVGV) && (GvCV((GV*)*svp) == cv)
2566                     && (gv = (GV*)*svp) ))) {
2567             /* Use GV from the stack as a fallback. */
2568             /* GV is potentially non-unique, or contain different CV. */
2569             SV *tmp = newRV((SV*)cv);
2570             sv_setsv(dbsv, tmp);
2571             SvREFCNT_dec(tmp);
2572         }
2573         else {
2574             gv_efullname3(dbsv, gv, Nullch);
2575         }
2576     }
2577     else {
2578         const int type = SvTYPE(dbsv);
2579         if (type < SVt_PVIV && type != SVt_IV)
2580             sv_upgrade(dbsv, SVt_PVIV);
2581         (void)SvIOK_on(dbsv);
2582         SvIV_set(dbsv, PTR2IV(cv));     /* Do it the quickest way  */
2583     }
2584
2585     if (CvXSUB(cv))
2586         PL_curcopdb = PL_curcop;
2587     cv = GvCV(PL_DBsub);
2588     return cv;
2589 }
2590
2591 PP(pp_entersub)
2592 {
2593     dVAR; dSP; dPOPss;
2594     GV *gv;
2595     HV *stash;
2596     register CV *cv;
2597     register PERL_CONTEXT *cx;
2598     I32 gimme;
2599     const bool hasargs = (PL_op->op_flags & OPf_STACKED) != 0;
2600
2601     if (!sv)
2602         DIE(aTHX_ "Not a CODE reference");
2603     switch (SvTYPE(sv)) {
2604         /* This is overwhelming the most common case:  */
2605     case SVt_PVGV:
2606         if (!(cv = GvCVu((GV*)sv)))
2607             cv = sv_2cv(sv, &stash, &gv, FALSE);
2608         if (!cv) {
2609             ENTER;
2610             SAVETMPS;
2611             goto try_autoload;
2612         }
2613         break;
2614     default:
2615         if (!SvROK(sv)) {
2616             const char *sym;
2617             if (sv == &PL_sv_yes) {             /* unfound import, ignore */
2618                 if (hasargs)
2619                     SP = PL_stack_base + POPMARK;
2620                 RETURN;
2621             }
2622             if (SvGMAGICAL(sv)) {
2623                 mg_get(sv);
2624                 if (SvROK(sv))
2625                     goto got_rv;
2626                 sym = SvPOKp(sv) ? SvPVX(sv) : Nullch;
2627             }
2628             else {
2629                 STRLEN n_a;
2630                 sym = SvPV(sv, n_a);
2631             }
2632             if (!sym)
2633                 DIE(aTHX_ PL_no_usym, "a subroutine");
2634             if (PL_op->op_private & HINT_STRICT_REFS)
2635                 DIE(aTHX_ PL_no_symref, sym, "a subroutine");
2636             cv = get_cv(sym, TRUE);
2637             break;
2638         }
2639   got_rv:
2640         {
2641             SV **sp = &sv;              /* Used in tryAMAGICunDEREF macro. */
2642             tryAMAGICunDEREF(to_cv);
2643         }
2644         cv = (CV*)SvRV(sv);
2645         if (SvTYPE(cv) == SVt_PVCV)
2646             break;
2647         /* FALL THROUGH */
2648     case SVt_PVHV:
2649     case SVt_PVAV:
2650         DIE(aTHX_ "Not a CODE reference");
2651         /* This is the second most common case:  */
2652     case SVt_PVCV:
2653         cv = (CV*)sv;
2654         break;
2655     }
2656
2657     ENTER;
2658     SAVETMPS;
2659
2660   retry:
2661     if (!CvROOT(cv) && !CvXSUB(cv)) {
2662         goto fooey;
2663     }
2664
2665     gimme = GIMME_V;
2666     if ((PL_op->op_private & OPpENTERSUB_DB) && GvCV(PL_DBsub) && !CvNODEBUG(cv)) {
2667         if (CvASSERTION(cv) && PL_DBassertion)
2668             sv_setiv(PL_DBassertion, 1);
2669
2670         cv = get_db_sub(&sv, cv);
2671         if (!cv || (!CvXSUB(cv) && !CvSTART(cv)))
2672             DIE(aTHX_ "No DB::sub routine defined");
2673     }
2674
2675     if (!(CvXSUB(cv))) {
2676         /* This path taken at least 75% of the time   */
2677         dMARK;
2678         register I32 items = SP - MARK;
2679         AV* padlist = CvPADLIST(cv);
2680         PUSHBLOCK(cx, CXt_SUB, MARK);
2681         PUSHSUB(cx);
2682         cx->blk_sub.retop = PL_op->op_next;
2683         CvDEPTH(cv)++;
2684         /* XXX This would be a natural place to set C<PL_compcv = cv> so
2685          * that eval'' ops within this sub know the correct lexical space.
2686          * Owing the speed considerations, we choose instead to search for
2687          * the cv using find_runcv() when calling doeval().
2688          */
2689         if (CvDEPTH(cv) >= 2) {
2690             PERL_STACK_OVERFLOW_CHECK();
2691             pad_push(padlist, CvDEPTH(cv));
2692         }
2693         PAD_SET_CUR(padlist, CvDEPTH(cv));
2694         if (hasargs)
2695         {
2696             AV* av;
2697             SV** ary;
2698
2699 #if 0
2700             DEBUG_S(PerlIO_printf(Perl_debug_log,
2701                                   "%p entersub preparing @_\n", thr));
2702 #endif
2703             av = (AV*)PAD_SVl(0);
2704             if (AvREAL(av)) {
2705                 /* @_ is normally not REAL--this should only ever
2706                  * happen when DB::sub() calls things that modify @_ */
2707                 av_clear(av);
2708                 AvREAL_off(av);
2709                 AvREIFY_on(av);
2710             }
2711             cx->blk_sub.savearray = GvAV(PL_defgv);
2712             GvAV(PL_defgv) = (AV*)SvREFCNT_inc(av);
2713             CX_CURPAD_SAVE(cx->blk_sub);
2714             cx->blk_sub.argarray = av;
2715             ++MARK;
2716
2717             if (items > AvMAX(av) + 1) {
2718                 ary = AvALLOC(av);
2719                 if (AvARRAY(av) != ary) {
2720                     AvMAX(av) += AvARRAY(av) - AvALLOC(av);
2721                     SvPV_set(av, (char*)ary);
2722                 }
2723                 if (items > AvMAX(av) + 1) {
2724                     AvMAX(av) = items - 1;
2725                     Renew(ary,items,SV*);
2726                     AvALLOC(av) = ary;
2727                     SvPV_set(av, (char*)ary);
2728                 }
2729             }
2730             Copy(MARK,AvARRAY(av),items,SV*);
2731             AvFILLp(av) = items - 1;
2732
2733             while (items--) {
2734                 if (*MARK)
2735                     SvTEMP_off(*MARK);
2736                 MARK++;
2737             }
2738         }
2739         /* warning must come *after* we fully set up the context
2740          * stuff so that __WARN__ handlers can safely dounwind()
2741          * if they want to
2742          */
2743         if (CvDEPTH(cv) == 100 && ckWARN(WARN_RECURSION)
2744             && !(PERLDB_SUB && cv == GvCV(PL_DBsub)))
2745             sub_crush_depth(cv);
2746 #if 0
2747         DEBUG_S(PerlIO_printf(Perl_debug_log,
2748                               "%p entersub returning %p\n", thr, CvSTART(cv)));
2749 #endif
2750         RETURNOP(CvSTART(cv));
2751     }
2752     else {
2753 #ifdef PERL_XSUB_OLDSTYLE
2754         if (CvOLDSTYLE(cv)) {
2755             I32 (*fp3)(int,int,int);
2756             dMARK;
2757             register I32 items = SP - MARK;
2758                                         /* We dont worry to copy from @_. */
2759             while (SP > mark) {
2760                 SP[1] = SP[0];
2761                 SP--;
2762             }
2763             PL_stack_sp = mark + 1;
2764             fp3 = (I32(*)(int,int,int))CvXSUB(cv);
2765             items = (*fp3)(CvXSUBANY(cv).any_i32,
2766                            MARK - PL_stack_base + 1,
2767                            items);
2768             PL_stack_sp = PL_stack_base + items;
2769         }
2770         else
2771 #endif /* PERL_XSUB_OLDSTYLE */
2772         {
2773             I32 markix = TOPMARK;
2774
2775             PUTBACK;
2776
2777             if (!hasargs) {
2778                 /* Need to copy @_ to stack. Alternative may be to
2779                  * switch stack to @_, and copy return values
2780                  * back. This would allow popping @_ in XSUB, e.g.. XXXX */
2781                 AV* av;
2782                 I32 items;
2783                 av = GvAV(PL_defgv);
2784                 items = AvFILLp(av) + 1;   /* @_ is not tieable */
2785
2786                 if (items) {
2787                     /* Mark is at the end of the stack. */
2788                     EXTEND(SP, items);
2789                     Copy(AvARRAY(av), SP + 1, items, SV*);
2790                     SP += items;
2791                     PUTBACK ;
2792                 }
2793             }
2794             /* We assume first XSUB in &DB::sub is the called one. */
2795             if (PL_curcopdb) {
2796                 SAVEVPTR(PL_curcop);
2797                 PL_curcop = PL_curcopdb;
2798                 PL_curcopdb = NULL;
2799             }
2800             /* Do we need to open block here? XXXX */
2801             (void)(*CvXSUB(cv))(aTHX_ cv);
2802
2803             /* Enforce some sanity in scalar context. */
2804             if (gimme == G_SCALAR && ++markix != PL_stack_sp - PL_stack_base ) {
2805                 if (markix > PL_stack_sp - PL_stack_base)
2806                     *(PL_stack_base + markix) = &PL_sv_undef;
2807                 else
2808                     *(PL_stack_base + markix) = *PL_stack_sp;
2809                 PL_stack_sp = PL_stack_base + markix;
2810             }
2811         }
2812         LEAVE;
2813         return NORMAL;
2814     }
2815
2816     assert (0); /* Cannot get here.  */
2817     /* This is deliberately moved here as spaghetti code to keep it out of the
2818        hot path.  */
2819     {
2820         GV* autogv;
2821         SV* sub_name;
2822
2823       fooey:
2824         /* anonymous or undef'd function leaves us no recourse */
2825         if (CvANON(cv) || !(gv = CvGV(cv)))
2826             DIE(aTHX_ "Undefined subroutine called");
2827
2828         /* autoloaded stub? */
2829         if (cv != GvCV(gv)) {
2830             cv = GvCV(gv);
2831         }
2832         /* should call AUTOLOAD now? */
2833         else {
2834 try_autoload:
2835             if ((autogv = gv_autoload4(GvSTASH(gv), GvNAME(gv), GvNAMELEN(gv),
2836                                    FALSE)))
2837             {
2838                 cv = GvCV(autogv);
2839             }
2840             /* sorry */
2841             else {
2842                 sub_name = sv_newmortal();
2843                 gv_efullname3(sub_name, gv, Nullch);
2844                 DIE(aTHX_ "Undefined subroutine &%"SVf" called", sub_name);
2845             }
2846         }
2847         if (!cv)
2848             DIE(aTHX_ "Not a CODE reference");
2849         goto retry;
2850     }
2851 }
2852
2853 void
2854 Perl_sub_crush_depth(pTHX_ CV *cv)
2855 {
2856     if (CvANON(cv))
2857         Perl_warner(aTHX_ packWARN(WARN_RECURSION), "Deep recursion on anonymous subroutine");
2858     else {
2859         SV* tmpstr = sv_newmortal();
2860         gv_efullname3(tmpstr, CvGV(cv), Nullch);
2861         Perl_warner(aTHX_ packWARN(WARN_RECURSION), "Deep recursion on subroutine \"%"SVf"\"",
2862                 tmpstr);
2863     }
2864 }
2865
2866 PP(pp_aelem)
2867 {
2868     dSP;
2869     SV** svp;
2870     SV* elemsv = POPs;
2871     IV elem = SvIV(elemsv);
2872     AV* av = (AV*)POPs;
2873     const U32 lval = PL_op->op_flags & OPf_MOD || LVRET;
2874     const U32 defer = (PL_op->op_private & OPpLVAL_DEFER) && (elem > av_len(av));
2875     SV *sv;
2876
2877     if (SvROK(elemsv) && !SvGAMAGIC(elemsv) && ckWARN(WARN_MISC))
2878         Perl_warner(aTHX_ packWARN(WARN_MISC), "Use of reference \"%"SVf"\" as array index", elemsv);
2879     if (elem > 0)
2880         elem -= PL_curcop->cop_arybase;
2881     if (SvTYPE(av) != SVt_PVAV)
2882         RETPUSHUNDEF;
2883     svp = av_fetch(av, elem, lval && !defer);
2884     if (lval) {
2885 #ifdef PERL_MALLOC_WRAP
2886          static const char oom_array_extend[] =
2887               "Out of memory during array extend"; /* Duplicated in av.c */
2888          if (SvUOK(elemsv)) {
2889               const UV uv = SvUV(elemsv);
2890               elem = uv > IV_MAX ? IV_MAX : uv;
2891          }
2892          else if (SvNOK(elemsv))
2893               elem = (IV)SvNV(elemsv);
2894          if (elem > 0)
2895               MEM_WRAP_CHECK_1(elem,SV*,oom_array_extend);
2896 #endif
2897         if (!svp || *svp == &PL_sv_undef) {
2898             SV* lv;
2899             if (!defer)
2900                 DIE(aTHX_ PL_no_aelem, elem);
2901             lv = sv_newmortal();
2902             sv_upgrade(lv, SVt_PVLV);
2903             LvTYPE(lv) = 'y';
2904             sv_magic(lv, Nullsv, PERL_MAGIC_defelem, Nullch, 0);
2905             LvTARG(lv) = SvREFCNT_inc(av);
2906             LvTARGOFF(lv) = elem;
2907             LvTARGLEN(lv) = 1;
2908             PUSHs(lv);
2909             RETURN;
2910         }
2911         if (PL_op->op_private & OPpLVAL_INTRO)
2912             save_aelem(av, elem, svp);
2913         else if (PL_op->op_private & OPpDEREF)
2914             vivify_ref(*svp, PL_op->op_private & OPpDEREF);
2915     }
2916     sv = (svp ? *svp : &PL_sv_undef);
2917     if (!lval && SvGMAGICAL(sv))        /* see note in pp_helem() */
2918         sv = sv_mortalcopy(sv);
2919     PUSHs(sv);
2920     RETURN;
2921 }
2922
2923 void
2924 Perl_vivify_ref(pTHX_ SV *sv, U32 to_what)
2925 {
2926     if (SvGMAGICAL(sv))
2927         mg_get(sv);
2928     if (!SvOK(sv)) {
2929         if (SvREADONLY(sv))
2930             Perl_croak(aTHX_ PL_no_modify);
2931         if (SvTYPE(sv) < SVt_RV)
2932             sv_upgrade(sv, SVt_RV);
2933         else if (SvTYPE(sv) >= SVt_PV) {
2934             SvPV_free(sv);
2935             SvLEN_set(sv, 0);
2936             SvCUR_set(sv, 0);
2937         }
2938         switch (to_what) {
2939         case OPpDEREF_SV:
2940             SvRV_set(sv, NEWSV(355,0));
2941             break;
2942         case OPpDEREF_AV:
2943             SvRV_set(sv, (SV*)newAV());
2944             break;
2945         case OPpDEREF_HV:
2946             SvRV_set(sv, (SV*)newHV());
2947             break;
2948         }
2949         SvROK_on(sv);
2950         SvSETMAGIC(sv);
2951     }
2952 }
2953
2954 PP(pp_method)
2955 {
2956     dSP;
2957     SV* sv = TOPs;
2958
2959     if (SvROK(sv)) {
2960         SV* rsv = SvRV(sv);
2961         if (SvTYPE(rsv) == SVt_PVCV) {
2962             SETs(rsv);
2963             RETURN;
2964         }
2965     }
2966
2967     SETs(method_common(sv, Null(U32*)));
2968     RETURN;
2969 }
2970
2971 PP(pp_method_named)
2972 {
2973     dSP;
2974     SV* sv = cSVOP_sv;
2975     U32 hash = SvUVX(sv);
2976
2977     XPUSHs(method_common(sv, &hash));
2978     RETURN;
2979 }
2980
2981 STATIC SV *
2982 S_method_common(pTHX_ SV* meth, U32* hashp)
2983 {
2984     SV* sv;
2985     SV* ob;
2986     GV* gv;
2987     HV* stash;
2988     STRLEN namelen;
2989     const char* packname = 0;
2990     SV *packsv = Nullsv;
2991     STRLEN packlen;
2992     const char *name = SvPV(meth, namelen);
2993
2994     sv = *(PL_stack_base + TOPMARK + 1);
2995
2996     if (!sv)
2997         Perl_croak(aTHX_ "Can't call method \"%s\" on an undefined value", name);
2998
2999     if (SvGMAGICAL(sv))
3000         mg_get(sv);
3001     if (SvROK(sv))
3002         ob = (SV*)SvRV(sv);
3003     else {
3004         GV* iogv;
3005
3006         /* this isn't a reference */
3007         packname = Nullch;
3008
3009         if(SvOK(sv) && (packname = SvPV(sv, packlen))) {
3010           HE* he;
3011           he = hv_fetch_ent(PL_stashcache, sv, 0, 0);
3012           if (he) {
3013             stash = INT2PTR(HV*,SvIV(HeVAL(he)));
3014             goto fetch;
3015           }
3016         }
3017
3018         if (!SvOK(sv) ||
3019             !(packname) ||
3020             !(iogv = gv_fetchsv(sv, FALSE, SVt_PVIO)) ||
3021             !(ob=(SV*)GvIO(iogv)))
3022         {
3023             /* this isn't the name of a filehandle either */
3024             if (!packname ||
3025                 ((UTF8_IS_START(*packname) && DO_UTF8(sv))
3026                     ? !isIDFIRST_utf8((U8*)packname)
3027                     : !isIDFIRST(*packname)
3028                 ))
3029             {
3030                 Perl_croak(aTHX_ "Can't call method \"%s\" %s", name,
3031                            SvOK(sv) ? "without a package or object reference"
3032                                     : "on an undefined value");
3033             }
3034             /* assume it's a package name */
3035             stash = gv_stashpvn(packname, packlen, FALSE);
3036             if (!stash)
3037                 packsv = sv;
3038             else {
3039                 SV* ref = newSViv(PTR2IV(stash));
3040                 hv_store(PL_stashcache, packname, packlen, ref, 0);
3041             }
3042             goto fetch;
3043         }
3044         /* it _is_ a filehandle name -- replace with a reference */
3045         *(PL_stack_base + TOPMARK + 1) = sv_2mortal(newRV((SV*)iogv));
3046     }
3047
3048     /* if we got here, ob should be a reference or a glob */
3049     if (!ob || !(SvOBJECT(ob)
3050                  || (SvTYPE(ob) == SVt_PVGV && (ob = (SV*)GvIO((GV*)ob))
3051                      && SvOBJECT(ob))))
3052     {
3053         Perl_croak(aTHX_ "Can't call method \"%s\" on unblessed reference",
3054                    name);
3055     }
3056
3057     stash = SvSTASH(ob);
3058
3059   fetch:
3060     /* NOTE: stash may be null, hope hv_fetch_ent and
3061        gv_fetchmethod can cope (it seems they can) */
3062
3063     /* shortcut for simple names */
3064     if (hashp) {
3065         HE* he = hv_fetch_ent(stash, meth, 0, *hashp);
3066         if (he) {
3067             gv = (GV*)HeVAL(he);
3068             if (isGV(gv) && GvCV(gv) &&
3069                 (!GvCVGEN(gv) || GvCVGEN(gv) == PL_sub_generation))
3070                 return (SV*)GvCV(gv);
3071         }
3072     }
3073
3074     gv = gv_fetchmethod(stash ? stash : (HV*)packsv, name);
3075
3076     if (!gv) {
3077         /* This code tries to figure out just what went wrong with
3078            gv_fetchmethod.  It therefore needs to duplicate a lot of
3079            the internals of that function.  We can't move it inside
3080            Perl_gv_fetchmethod_autoload(), however, since that would
3081            cause UNIVERSAL->can("NoSuchPackage::foo") to croak, and we
3082            don't want that.
3083         */
3084         const char* leaf = name;
3085         const char* sep = Nullch;
3086         const char* p;
3087
3088         for (p = name; *p; p++) {
3089             if (*p == '\'')
3090                 sep = p, leaf = p + 1;
3091             else if (*p == ':' && *(p + 1) == ':')
3092                 sep = p, leaf = p + 2;
3093         }
3094         if (!sep || ((sep - name) == 5 && strnEQ(name, "SUPER", 5))) {
3095             /* the method name is unqualified or starts with SUPER:: */
3096             packname = sep ? CopSTASHPV(PL_curcop) :
3097                 stash ? HvNAME(stash) : packname;
3098             if (!packname)
3099                 Perl_croak(aTHX_
3100                            "Can't use anonymous symbol table for method lookup");
3101             else
3102                 packlen = strlen(packname);
3103         }
3104         else {
3105             /* the method name is qualified */
3106             packname = name;
3107             packlen = sep - name;
3108         }
3109
3110         /* we're relying on gv_fetchmethod not autovivifying the stash */
3111         if (gv_stashpvn(packname, packlen, FALSE)) {
3112             Perl_croak(aTHX_
3113                        "Can't locate object method \"%s\" via package \"%.*s\"",
3114                        leaf, (int)packlen, packname);
3115         }
3116         else {
3117             Perl_croak(aTHX_
3118                        "Can't locate object method \"%s\" via package \"%.*s\""
3119                        " (perhaps you forgot to load \"%.*s\"?)",
3120                        leaf, (int)packlen, packname, (int)packlen, packname);
3121         }
3122     }
3123     return isGV(gv) ? (SV*)GvCV(gv) : (SV*)gv;
3124 }
3125
3126 /*
3127  * Local variables:
3128  * c-indentation-style: bsd
3129  * c-basic-offset: 4
3130  * indent-tabs-mode: t
3131  * End:
3132  *
3133  * vim: ts=8 sts=4 sw=4 noet:
3134 */