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