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(GvSVn(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_const(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_const(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_const(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_const(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_const(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             if ((sv = *relem)) {
 975                 TAINT_NOT;      /* Each item is independent */
 976                 *relem = sv_mortalcopy(sv);
 977             }
 978         }
 979     }
 980
 981     relem = firstrelem;
 982     lelem = firstlelem;
 983     ary = Null(AV*);
 984     hash = Null(HV*);
 985
 986     while (lelem <= lastlelem) {
 987         TAINT_NOT;              /* Each item stands on its own, taintwise. */
 988         sv = *lelem++;
 989         switch (SvTYPE(sv)) {
 990         case SVt_PVAV:
 991             ary = (AV*)sv;
 992             magic = SvMAGICAL(ary) != 0;
 993             av_clear(ary);
 994             av_extend(ary, lastrelem - relem);
 995             i = 0;
 996             while (relem <= lastrelem) {        /* gobble up all the rest */
 997                 SV **didstore;
 998                 assert(*relem);
 999                 sv = newSVsv(*relem);
1000                 *(relem++) = sv;
1001                 didstore = av_store(ary,i++,sv);
1002                 if (magic) {
1003                     if (SvSMAGICAL(sv))
1004                         mg_set(sv);
1005                     if (!didstore)
1006                         sv_2mortal(sv);
1007                 }
1008                 TAINT_NOT;
1009             }
1010             break;
1011         case SVt_PVHV: {                                /* normal hash */
1012                 SV *tmpstr;
1013
1014                 hash = (HV*)sv;
1015                 magic = SvMAGICAL(hash) != 0;
1016                 hv_clear(hash);
1017                 firsthashrelem = relem;
1018
1019                 while (relem < lastrelem) {     /* gobble up all the rest */
1020                     HE *didstore;
1021                     if (*relem)
1022                         sv = *(relem++);
1023                     else
1024                         sv = &PL_sv_no, relem++;
1025                     tmpstr = NEWSV(29,0);
1026                     if (*relem)
1027                         sv_setsv(tmpstr,*relem);        /* value */
1028                     *(relem++) = tmpstr;
1029                     if (gimme != G_VOID && hv_exists_ent(hash, sv, 0))
1030                         /* key overwrites an existing entry */
1031                         duplicates += 2;
1032                     didstore = hv_store_ent(hash,sv,tmpstr,0);
1033                     if (magic) {
1034                         if (SvSMAGICAL(tmpstr))
1035                             mg_set(tmpstr);
1036                         if (!didstore)
1037                             sv_2mortal(tmpstr);
1038                     }
1039                     TAINT_NOT;
1040                 }
1041                 if (relem == lastrelem) {
1042                     do_oddball(hash, relem, firstrelem);
1043                     relem++;
1044                 }
1045             }
1046             break;
1047         default:
1048             if (SvIMMORTAL(sv)) {
1049                 if (relem <= lastrelem)
1050                     relem++;
1051                 break;
1052             }
1053             if (relem <= lastrelem) {
1054                 sv_setsv(sv, *relem);
1055                 *(relem++) = sv;
1056             }
1057             else
1058                 sv_setsv(sv, &PL_sv_undef);
1059             SvSETMAGIC(sv);
1060             break;
1061         }
1062     }
1063     if (PL_delaymagic & ~DM_DELAY) {
1064         if (PL_delaymagic & DM_UID) {
1065 #ifdef HAS_SETRESUID
1066             (void)setresuid((PL_delaymagic & DM_RUID) ? PL_uid  : (Uid_t)-1,
1067                             (PL_delaymagic & DM_EUID) ? PL_euid : (Uid_t)-1,
1068                             (Uid_t)-1);
1069 #else
1070 #  ifdef HAS_SETREUID
1071             (void)setreuid((PL_delaymagic & DM_RUID) ? PL_uid  : (Uid_t)-1,
1072                            (PL_delaymagic & DM_EUID) ? PL_euid : (Uid_t)-1);
1073 #  else
1074 #    ifdef HAS_SETRUID
1075             if ((PL_delaymagic & DM_UID) == DM_RUID) {
1076                 (void)setruid(PL_uid);
1077                 PL_delaymagic &= ~DM_RUID;
1078             }
1079 #    endif /* HAS_SETRUID */
1080 #    ifdef HAS_SETEUID
1081             if ((PL_delaymagic & DM_UID) == DM_EUID) {
1082                 (void)seteuid(PL_euid);
1083                 PL_delaymagic &= ~DM_EUID;
1084             }
1085 #    endif /* HAS_SETEUID */
1086             if (PL_delaymagic & DM_UID) {
1087                 if (PL_uid != PL_euid)
1088                     DIE(aTHX_ "No setreuid available");
1089                 (void)PerlProc_setuid(PL_uid);
1090             }
1091 #  endif /* HAS_SETREUID */
1092 #endif /* HAS_SETRESUID */
1093             PL_uid = PerlProc_getuid();
1094             PL_euid = PerlProc_geteuid();
1095         }
1096         if (PL_delaymagic & DM_GID) {
1097 #ifdef HAS_SETRESGID
1098             (void)setresgid((PL_delaymagic & DM_RGID) ? PL_gid  : (Gid_t)-1,
1099                             (PL_delaymagic & DM_EGID) ? PL_egid : (Gid_t)-1,
1100                             (Gid_t)-1);
1101 #else
1102 #  ifdef HAS_SETREGID
1103             (void)setregid((PL_delaymagic & DM_RGID) ? PL_gid  : (Gid_t)-1,
1104                            (PL_delaymagic & DM_EGID) ? PL_egid : (Gid_t)-1);
1105 #  else
1106 #    ifdef HAS_SETRGID
1107             if ((PL_delaymagic & DM_GID) == DM_RGID) {
1108                 (void)setrgid(PL_gid);
1109                 PL_delaymagic &= ~DM_RGID;
1110             }
1111 #    endif /* HAS_SETRGID */
1112 #    ifdef HAS_SETEGID
1113             if ((PL_delaymagic & DM_GID) == DM_EGID) {
1114                 (void)setegid(PL_egid);
1115                 PL_delaymagic &= ~DM_EGID;
1116             }
1117 #    endif /* HAS_SETEGID */
1118             if (PL_delaymagic & DM_GID) {
1119                 if (PL_gid != PL_egid)
1120                     DIE(aTHX_ "No setregid available");
1121                 (void)PerlProc_setgid(PL_gid);
1122             }
1123 #  endif /* HAS_SETREGID */
1124 #endif /* HAS_SETRESGID */
1125             PL_gid = PerlProc_getgid();
1126             PL_egid = PerlProc_getegid();
1127         }
1128         PL_tainting |= (PL_uid && (PL_euid != PL_uid || PL_egid != PL_gid));
1129     }
1130     PL_delaymagic = 0;
1131
1132     if (gimme == G_VOID)
1133         SP = firstrelem - 1;
1134     else if (gimme == G_SCALAR) {
1135         dTARGET;
1136         SP = firstrelem;
1137         SETi(lastrelem - firstrelem + 1 - duplicates);
1138     }
1139     else {
1140         if (ary)
1141             SP = lastrelem;
1142         else if (hash) {
1143             if (duplicates) {
1144                 /* Removes from the stack the entries which ended up as
1145                  * duplicated keys in the hash (fix for [perl #24380]) */
1146                 Move(firsthashrelem + duplicates,
1147                         firsthashrelem, duplicates, SV**);
1148                 lastrelem -= duplicates;
1149             }
1150             SP = lastrelem;
1151         }
1152         else
1153             SP = firstrelem + (lastlelem - firstlelem);
1154         lelem = firstlelem + (relem - firstrelem);
1155         while (relem <= SP)
1156             *relem++ = (lelem <= lastlelem) ? *lelem++ : &PL_sv_undef;
1157     }
1158     RETURN;
1159 }
1160
1161 PP(pp_qr)
1162 {
1163     dSP;
1164     register PMOP *pm = cPMOP;
1165     SV *rv = sv_newmortal();
1166     SV *sv = newSVrv(rv, "Regexp");
1167     if (pm->op_pmdynflags & PMdf_TAINTED)
1168         SvTAINTED_on(rv);
1169     sv_magic(sv,(SV*)ReREFCNT_inc(PM_GETRE(pm)), PERL_MAGIC_qr,0,0);
1170     RETURNX(PUSHs(rv));
1171 }
1172
1173 PP(pp_match)
1174 {
1175     dSP; dTARG;
1176     register PMOP *pm = cPMOP;
1177     PMOP *dynpm = pm;
1178     const register char *t;
1179     const register char *s;
1180     const char *strend;
1181     I32 global;
1182     I32 r_flags = REXEC_CHECKED;
1183     const char *truebase;                       /* Start of string  */
1184     register REGEXP *rx = PM_GETRE(pm);
1185     bool rxtainted;
1186     const I32 gimme = GIMME;
1187     STRLEN len;
1188     I32 minmatch = 0;
1189     const I32 oldsave = PL_savestack_ix;
1190     I32 update_minmatch = 1;
1191     I32 had_zerolen = 0;
1192
1193     if (PL_op->op_flags & OPf_STACKED)
1194         TARG = POPs;
1195     else if (PL_op->op_private & OPpTARGET_MY)
1196         GETTARGET;
1197     else {
1198         TARG = DEFSV;
1199         EXTEND(SP,1);
1200     }
1201
1202     PUTBACK;                            /* EVAL blocks need stack_sp. */
1203     s = SvPV_const(TARG, len);
1204     strend = s + len;
1205     if (!s)
1206         DIE(aTHX_ "panic: pp_match");
1207     rxtainted = ((pm->op_pmdynflags & PMdf_TAINTED) ||
1208                  (PL_tainted && (pm->op_pmflags & PMf_RETAINT)));
1209     TAINT_NOT;
1210
1211     RX_MATCH_UTF8_set(rx, DO_UTF8(TARG));
1212
1213     /* PMdf_USED is set after a ?? matches once */
1214     if (pm->op_pmdynflags & PMdf_USED) {
1215       failure:
1216         if (gimme == G_ARRAY)
1217             RETURN;
1218         RETPUSHNO;
1219     }
1220
1221     /* empty pattern special-cased to use last successful pattern if possible */
1222     if (!rx->prelen && PL_curpm) {
1223         pm = PL_curpm;
1224         rx = PM_GETRE(pm);
1225     }
1226
1227     if (rx->minlen > (I32)len)
1228         goto failure;
1229
1230     truebase = t = s;
1231
1232     /* XXXX What part of this is needed with true \G-support? */
1233     if ((global = dynpm->op_pmflags & PMf_GLOBAL)) {
1234         rx->startp[0] = -1;
1235         if (SvTYPE(TARG) >= SVt_PVMG && SvMAGIC(TARG)) {
1236             MAGIC* mg = mg_find(TARG, PERL_MAGIC_regex_global);
1237             if (mg && mg->mg_len >= 0) {
1238                 if (!(rx->reganch & ROPT_GPOS_SEEN))
1239                     rx->endp[0] = rx->startp[0] = mg->mg_len;
1240                 else if (rx->reganch & ROPT_ANCH_GPOS) {
1241                     r_flags |= REXEC_IGNOREPOS;
1242                     rx->endp[0] = rx->startp[0] = mg->mg_len;
1243                 }
1244                 minmatch = (mg->mg_flags & MGf_MINMATCH);
1245                 update_minmatch = 0;
1246             }
1247         }
1248     }
1249     if ((!global && rx->nparens)
1250             || SvTEMP(TARG) || PL_sawampersand)
1251         r_flags |= REXEC_COPY_STR;
1252     if (SvSCREAM(TARG))
1253         r_flags |= REXEC_SCREAM;
1254
1255 play_it_again:
1256     if (global && rx->startp[0] != -1) {
1257         t = s = rx->endp[0] + truebase;
1258         if ((s + rx->minlen) > strend)
1259             goto nope;
1260         if (update_minmatch++)
1261             minmatch = had_zerolen;
1262     }
1263     if (rx->reganch & RE_USE_INTUIT &&
1264         DO_UTF8(TARG) == ((rx->reganch & ROPT_UTF8) != 0)) {
1265         /* FIXME - can PL_bostr be made const char *?  */
1266         PL_bostr = (char *)truebase;
1267         s = CALLREG_INTUIT_START(aTHX_ rx, TARG, (char *)s, (char *)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, (char*)s, (char *)strend, (char*)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             if ((rx->startp[i] != -1) && rx->endp[i] != -1 ) {
1304                 const I32 len = rx->endp[i] - rx->startp[i];
1305                 s = rx->startp[i] + truebase;
1306                 if (rx->endp[i] < 0 || rx->startp[i] < 0 ||
1307                     len < 0 || len > strend - s)
1308                     DIE(aTHX_ "panic: pp_match start/end pointers");
1309                 sv_setpvn(*SP, s, len);
1310                 if (DO_UTF8(TARG) && is_utf8_string((U8*)s, len))
1311                     SvUTF8_on(*SP);
1312             }
1313         }
1314         if (global) {
1315             if (dynpm->op_pmflags & PMf_CONTINUE) {
1316                 MAGIC* mg = 0;
1317                 if (SvTYPE(TARG) >= SVt_PVMG && SvMAGIC(TARG))
1318                     mg = mg_find(TARG, PERL_MAGIC_regex_global);
1319                 if (!mg) {
1320                     sv_magic(TARG, (SV*)0, PERL_MAGIC_regex_global, Nullch, 0);
1321                     mg = mg_find(TARG, PERL_MAGIC_regex_global);
1322                 }
1323                 if (rx->startp[0] != -1) {
1324                     mg->mg_len = rx->endp[0];
1325                     if (rx->startp[0] == rx->endp[0])
1326                         mg->mg_flags |= MGf_MINMATCH;
1327                     else
1328                         mg->mg_flags &= ~MGf_MINMATCH;
1329                 }
1330             }
1331             had_zerolen = (rx->startp[0] != -1
1332                            && rx->startp[0] == rx->endp[0]);
1333             PUTBACK;                    /* EVAL blocks may use stack */
1334             r_flags |= REXEC_IGNOREPOS | REXEC_NOT_FIRST;
1335             goto play_it_again;
1336         }
1337         else if (!nparens)
1338             XPUSHs(&PL_sv_yes);
1339         LEAVE_SCOPE(oldsave);
1340         RETURN;
1341     }
1342     else {
1343         if (global) {
1344             MAGIC* mg = 0;
1345             if (SvTYPE(TARG) >= SVt_PVMG && SvMAGIC(TARG))
1346                 mg = mg_find(TARG, PERL_MAGIC_regex_global);
1347             if (!mg) {
1348                 sv_magic(TARG, (SV*)0, PERL_MAGIC_regex_global, Nullch, 0);
1349                 mg = mg_find(TARG, PERL_MAGIC_regex_global);
1350             }
1351             if (rx->startp[0] != -1) {
1352                 mg->mg_len = rx->endp[0];
1353                 if (rx->startp[0] == rx->endp[0])
1354                     mg->mg_flags |= MGf_MINMATCH;
1355                 else
1356                     mg->mg_flags &= ~MGf_MINMATCH;
1357             }
1358         }
1359         LEAVE_SCOPE(oldsave);
1360         RETPUSHYES;
1361     }
1362
1363 yup:                                    /* Confirmed by INTUIT */
1364     if (rxtainted)
1365         RX_MATCH_TAINTED_on(rx);
1366     TAINT_IF(RX_MATCH_TAINTED(rx));
1367     PL_curpm = pm;
1368     if (dynpm->op_pmflags & PMf_ONCE)
1369         dynpm->op_pmdynflags |= PMdf_USED;
1370     if (RX_MATCH_COPIED(rx))
1371         Safefree(rx->subbeg);
1372     RX_MATCH_COPIED_off(rx);
1373     rx->subbeg = Nullch;
1374     if (global) {
1375         /* FIXME - should rx->subbeg be const char *?  */
1376         rx->subbeg = (char *) 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_OLD_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 = (char *) 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_OLD_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(GvSVn(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         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                 SvPV_force_nolen(sv);
1529             }
1530             offset = SvCUR(sv);
1531         }
1532     }
1533     else {
1534         sv = sv_2mortal(NEWSV(57, 80));
1535         offset = 0;
1536     }
1537
1538     /* This should not be marked tainted if the fp is marked clean */
1539 #define MAYBE_TAINT_LINE(io, sv) \
1540     if (!(IoFLAGS(io) & IOf_UNTAINT)) { \
1541         TAINT;                          \
1542         SvTAINTED_on(sv);               \
1543     }
1544
1545 /* delay EOF state for a snarfed empty file */
1546 #define SNARF_EOF(gimme,rs,io,sv) \
1547     (gimme != G_SCALAR || SvCUR(sv)                                     \
1548      || (IoFLAGS(io) & IOf_NOLINE) || !RsSNARF(rs))
1549
1550     for (;;) {
1551         PUTBACK;
1552         if (!sv_gets(sv, fp, offset)
1553             && (type == OP_GLOB
1554                 || SNARF_EOF(gimme, PL_rs, io, sv)
1555                 || PerlIO_error(fp)))
1556         {
1557             PerlIO_clearerr(fp);
1558             if (IoFLAGS(io) & IOf_ARGV) {
1559                 fp = nextargv(PL_last_in_gv);
1560                 if (fp)
1561                     continue;
1562                 (void)do_close(PL_last_in_gv, FALSE);
1563             }
1564             else if (type == OP_GLOB) {
1565                 if (!do_close(PL_last_in_gv, FALSE) && ckWARN(WARN_GLOB)) {
1566                     Perl_warner(aTHX_ packWARN(WARN_GLOB),
1567                            "glob failed (child exited with status %d%s)",
1568                            (int)(STATUS_CURRENT >> 8),
1569                            (STATUS_CURRENT & 0x80) ? ", core dumped" : "");
1570                 }
1571             }
1572             if (gimme == G_SCALAR) {
1573                 if (type != OP_RCATLINE) {
1574                     SV_CHECK_THINKFIRST_COW_DROP(TARG);
1575                     SvOK_off(TARG);
1576                 }
1577                 SPAGAIN;
1578                 PUSHTARG;
1579             }
1580             MAYBE_TAINT_LINE(io, sv);
1581             RETURN;
1582         }
1583         MAYBE_TAINT_LINE(io, sv);
1584         IoLINES(io)++;
1585         IoFLAGS(io) |= IOf_NOLINE;
1586         SvSETMAGIC(sv);
1587         SPAGAIN;
1588         XPUSHs(sv);
1589         if (type == OP_GLOB) {
1590             char *tmps;
1591             const char *t1;
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 (t1 = SvPVX_const(sv); *t1; t1++)
1601                 if (!isALPHA(*t1) && !isDIGIT(*t1) &&
1602                     strchr("$&*(){}[]'\";\\|?<>~`", *t1))
1603                         break;
1604             if (*t1 && 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 = (const U8*)SvPVX_const(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)) ? SvSHARED_HASH(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_const(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_const((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     const 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_OLD_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_OLD_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_OLD_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_mutable(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_const(nsv, clen);
2054              doutf8 = TRUE;
2055         }
2056         else {
2057             c = SvPV_const(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_OLD_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_OLD_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             else if ((i = m - s)) {     /* faster from front */
2115                 d -= clen;
2116                 m = d;
2117                 sv_chop(TARG, d-i);
2118                 s += i;
2119                 while (i--)
2120                     *--d = *--s;
2121                 if (clen)
2122                     Copy(c, m, clen, char);
2123             }
2124             else if (clen) {
2125                 d -= clen;
2126                 sv_chop(TARG, d);
2127                 Copy(c, d, clen, char);
2128             }
2129             else {
2130                 sv_chop(TARG, d);
2131             }
2132             TAINT_IF(rxtainted & 1);
2133             SPAGAIN;
2134             PUSHs(&PL_sv_yes);
2135         }
2136         else {
2137             do {
2138                 if (iters++ > maxiters)
2139                     DIE(aTHX_ "Substitution loop");
2140                 rxtainted |= RX_MATCH_TAINTED(rx);
2141                 m = rx->startp[0] + orig;
2142                 if ((i = m - s)) {
2143                     if (s != d)
2144                         Move(s, d, i, char);
2145                     d += i;
2146                 }
2147                 if (clen) {
2148                     Copy(c, d, clen, char);
2149                     d += clen;
2150                 }
2151                 s = rx->endp[0] + orig;
2152             } while (CALLREGEXEC(aTHX_ rx, s, strend, orig, s == m,
2153                                  TARG, NULL,
2154                                  /* don't match same null twice */
2155                                  REXEC_NOT_FIRST|REXEC_IGNOREPOS));
2156             if (s != d) {
2157                 i = strend - s;
2158                 SvCUR_set(TARG, d - SvPVX_const(TARG) + i);
2159                 Move(s, d, i+1, char);          /* include the NUL */
2160             }
2161             TAINT_IF(rxtainted & 1);
2162             SPAGAIN;
2163             PUSHs(sv_2mortal(newSViv((I32)iters)));
2164         }
2165         (void)SvPOK_only_UTF8(TARG);
2166         TAINT_IF(rxtainted);
2167         if (SvSMAGICAL(TARG)) {
2168             PUTBACK;
2169             mg_set(TARG);
2170             SPAGAIN;
2171         }
2172         SvTAINT(TARG);
2173         if (doutf8)
2174             SvUTF8_on(TARG);
2175         LEAVE_SCOPE(oldsave);
2176         RETURN;
2177     }
2178
2179     if (CALLREGEXEC(aTHX_ rx, s, strend, orig, 0, TARG, NULL,
2180                     r_flags | REXEC_CHECKED))
2181     {
2182         if (force_on_match) {
2183             force_on_match = 0;
2184             s = SvPV_force(TARG, len);
2185             goto force_it;
2186         }
2187 #ifdef PERL_OLD_COPY_ON_WRITE
2188       have_a_cow:
2189 #endif
2190         rxtainted |= RX_MATCH_TAINTED(rx);
2191         dstr = newSVpvn(m, s-m);
2192         if (DO_UTF8(TARG))
2193             SvUTF8_on(dstr);
2194         PL_curpm = pm;
2195         if (!c) {
2196             register PERL_CONTEXT *cx;
2197             SPAGAIN;
2198             (void)ReREFCNT_inc(rx);
2199             PUSHSUBST(cx);
2200             RETURNOP(cPMOP->op_pmreplroot);
2201         }
2202         r_flags |= REXEC_IGNOREPOS | REXEC_NOT_FIRST;
2203         do {
2204             if (iters++ > maxiters)
2205                 DIE(aTHX_ "Substitution loop");
2206             rxtainted |= RX_MATCH_TAINTED(rx);
2207             if (RX_MATCH_COPIED(rx) && rx->subbeg != orig) {
2208                 m = s;
2209                 s = orig;
2210                 orig = rx->subbeg;
2211                 s = orig + (m - s);
2212                 strend = s + (strend - m);
2213             }
2214             m = rx->startp[0] + orig;
2215             if (doutf8 && !SvUTF8(dstr))
2216                 sv_catpvn_utf8_upgrade(dstr, s, m - s, nsv);
2217             else
2218                 sv_catpvn(dstr, s, m-s);
2219             s = rx->endp[0] + orig;
2220             if (clen)
2221                 sv_catpvn(dstr, c, clen);
2222             if (once)
2223                 break;
2224         } while (CALLREGEXEC(aTHX_ rx, s, strend, orig, s == m,
2225                              TARG, NULL, r_flags));
2226         if (doutf8 && !DO_UTF8(TARG))
2227             sv_catpvn_utf8_upgrade(dstr, s, strend - s, nsv);
2228         else
2229             sv_catpvn(dstr, s, strend - s);
2230
2231 #ifdef PERL_OLD_COPY_ON_WRITE
2232         /* The match may make the string COW. If so, brilliant, because that's
2233            just saved us one malloc, copy and free - the regexp has donated
2234            the old buffer, and we malloc an entirely new one, rather than the
2235            regexp malloc()ing a buffer and copying our original, only for
2236            us to throw it away here during the substitution.  */
2237         if (SvIsCOW(TARG)) {
2238             sv_force_normal_flags(TARG, SV_COW_DROP_PV);
2239         } else
2240 #endif
2241         {
2242             SvPV_free(TARG);
2243         }
2244         SvPV_set(TARG, SvPVX(dstr));
2245         SvCUR_set(TARG, SvCUR(dstr));
2246         SvLEN_set(TARG, SvLEN(dstr));
2247         doutf8 |= DO_UTF8(dstr);
2248         SvPV_set(dstr, (char*)0);
2249         sv_free(dstr);
2250
2251         TAINT_IF(rxtainted & 1);
2252         SPAGAIN;
2253         PUSHs(sv_2mortal(newSViv((I32)iters)));
2254
2255         (void)SvPOK_only(TARG);
2256         if (doutf8)
2257             SvUTF8_on(TARG);
2258         TAINT_IF(rxtainted);
2259         SvSETMAGIC(TARG);
2260         SvTAINT(TARG);
2261         LEAVE_SCOPE(oldsave);
2262         RETURN;
2263     }
2264     goto ret_no;
2265
2266 nope:
2267 ret_no:
2268     SPAGAIN;
2269     PUSHs(&PL_sv_no);
2270     LEAVE_SCOPE(oldsave);
2271     RETURN;
2272 }
2273
2274 PP(pp_grepwhile)
2275 {
2276     dVAR; dSP;
2277
2278     if (SvTRUEx(POPs))
2279         PL_stack_base[PL_markstack_ptr[-1]++] = PL_stack_base[*PL_markstack_ptr];
2280     ++*PL_markstack_ptr;
2281     LEAVE;                                      /* exit inner scope */
2282
2283     /* All done yet? */
2284     if (PL_stack_base + *PL_markstack_ptr > SP) {
2285         I32 items;
2286         I32 gimme = GIMME_V;
2287
2288         LEAVE;                                  /* exit outer scope */
2289         (void)POPMARK;                          /* pop src */
2290         items = --*PL_markstack_ptr - PL_markstack_ptr[-1];
2291         (void)POPMARK;                          /* pop dst */
2292         SP = PL_stack_base + POPMARK;           /* pop original mark */
2293         if (gimme == G_SCALAR) {
2294             if (PL_op->op_private & OPpGREP_LEX) {
2295                 SV* sv = sv_newmortal();
2296                 sv_setiv(sv, items);
2297                 PUSHs(sv);
2298             }
2299             else {
2300                 dTARGET;
2301                 XPUSHi(items);
2302             }
2303         }
2304         else if (gimme == G_ARRAY)
2305             SP += items;
2306         RETURN;
2307     }
2308     else {
2309         SV *src;
2310
2311         ENTER;                                  /* enter inner scope */
2312         SAVEVPTR(PL_curpm);
2313
2314         src = PL_stack_base[*PL_markstack_ptr];
2315         SvTEMP_off(src);
2316         if (PL_op->op_private & OPpGREP_LEX)
2317             PAD_SVl(PL_op->op_targ) = src;
2318         else
2319             DEFSV = src;
2320
2321         RETURNOP(cLOGOP->op_other);
2322     }
2323 }
2324
2325 PP(pp_leavesub)
2326 {
2327     dVAR; dSP;
2328     SV **mark;
2329     SV **newsp;
2330     PMOP *newpm;
2331     I32 gimme;
2332     register PERL_CONTEXT *cx;
2333     SV *sv;
2334
2335     POPBLOCK(cx,newpm);
2336     cxstack_ix++; /* temporarily protect top context */
2337
2338     TAINT_NOT;
2339     if (gimme == G_SCALAR) {
2340         MARK = newsp + 1;
2341         if (MARK <= SP) {
2342             if (cx->blk_sub.cv && CvDEPTH(cx->blk_sub.cv) > 1) {
2343                 if (SvTEMP(TOPs)) {
2344                     *MARK = SvREFCNT_inc(TOPs);
2345                     FREETMPS;
2346                     sv_2mortal(*MARK);
2347                 }
2348                 else {
2349                     sv = SvREFCNT_inc(TOPs);    /* FREETMPS could clobber it */
2350                     FREETMPS;
2351                     *MARK = sv_mortalcopy(sv);
2352                     SvREFCNT_dec(sv);
2353                 }
2354             }
2355             else
2356                 *MARK = SvTEMP(TOPs) ? TOPs : sv_mortalcopy(TOPs);
2357         }
2358         else {
2359             MEXTEND(MARK, 0);
2360             *MARK = &PL_sv_undef;
2361         }
2362         SP = MARK;
2363     }
2364     else if (gimme == G_ARRAY) {
2365         for (MARK = newsp + 1; MARK <= SP; MARK++) {
2366             if (!SvTEMP(*MARK)) {
2367                 *MARK = sv_mortalcopy(*MARK);
2368                 TAINT_NOT;      /* Each item is independent */
2369             }
2370         }
2371     }
2372     PUTBACK;
2373
2374     LEAVE;
2375     cxstack_ix--;
2376     POPSUB(cx,sv);      /* Stack values are safe: release CV and @_ ... */
2377     PL_curpm = newpm;   /* ... and pop $1 et al */
2378
2379     LEAVESUB(sv);
2380     return cx->blk_sub.retop;
2381 }
2382
2383 /* This duplicates the above code because the above code must not
2384  * get any slower by more conditions */
2385 PP(pp_leavesublv)
2386 {
2387     dVAR; dSP;
2388     SV **mark;
2389     SV **newsp;
2390     PMOP *newpm;
2391     I32 gimme;
2392     register PERL_CONTEXT *cx;
2393     SV *sv;
2394
2395     POPBLOCK(cx,newpm);
2396     cxstack_ix++; /* temporarily protect top context */
2397
2398     TAINT_NOT;
2399
2400     if (cx->blk_sub.lval & OPpENTERSUB_INARGS) {
2401         /* We are an argument to a function or grep().
2402          * This kind of lvalueness was legal before lvalue
2403          * subroutines too, so be backward compatible:
2404          * cannot report errors.  */
2405
2406         /* Scalar context *is* possible, on the LHS of -> only,
2407          * as in f()->meth().  But this is not an lvalue. */
2408         if (gimme == G_SCALAR)
2409             goto temporise;
2410         if (gimme == G_ARRAY) {
2411             if (!CvLVALUE(cx->blk_sub.cv))
2412                 goto temporise_array;
2413             EXTEND_MORTAL(SP - newsp);
2414             for (mark = newsp + 1; mark <= SP; mark++) {
2415                 if (SvTEMP(*mark))
2416                     /* empty */ ;
2417                 else if (SvFLAGS(*mark) & (SVs_PADTMP | SVf_READONLY))
2418                     *mark = sv_mortalcopy(*mark);
2419                 else {
2420                     /* Can be a localized value subject to deletion. */
2421                     PL_tmps_stack[++PL_tmps_ix] = *mark;
2422                     (void)SvREFCNT_inc(*mark);
2423                 }
2424             }
2425         }
2426     }
2427     else if (cx->blk_sub.lval) {     /* Leave it as it is if we can. */
2428         /* Here we go for robustness, not for speed, so we change all
2429          * the refcounts so the caller gets a live guy. Cannot set
2430          * TEMP, so sv_2mortal is out of question. */
2431         if (!CvLVALUE(cx->blk_sub.cv)) {
2432             LEAVE;
2433             cxstack_ix--;
2434             POPSUB(cx,sv);
2435             PL_curpm = newpm;
2436             LEAVESUB(sv);
2437             DIE(aTHX_ "Can't modify non-lvalue subroutine call");
2438         }
2439         if (gimme == G_SCALAR) {
2440             MARK = newsp + 1;
2441             EXTEND_MORTAL(1);
2442             if (MARK == SP) {
2443                 if (SvFLAGS(TOPs) & (SVs_TEMP | SVs_PADTMP | SVf_READONLY)) {
2444                     LEAVE;
2445                     cxstack_ix--;
2446                     POPSUB(cx,sv);
2447                     PL_curpm = newpm;
2448                     LEAVESUB(sv);
2449                     DIE(aTHX_ "Can't return %s from lvalue subroutine",
2450                         SvREADONLY(TOPs) ? (TOPs == &PL_sv_undef) ? "undef"
2451                         : "a readonly value" : "a temporary");
2452                 }
2453                 else {                  /* Can be a localized value
2454                                          * subject to deletion. */
2455                     PL_tmps_stack[++PL_tmps_ix] = *mark;
2456                     (void)SvREFCNT_inc(*mark);
2457                 }
2458             }
2459             else {                      /* Should not happen? */
2460                 LEAVE;
2461                 cxstack_ix--;
2462                 POPSUB(cx,sv);
2463                 PL_curpm = newpm;
2464                 LEAVESUB(sv);
2465                 DIE(aTHX_ "%s returned from lvalue subroutine in scalar context",
2466                     (MARK > SP ? "Empty array" : "Array"));
2467             }
2468             SP = MARK;
2469         }
2470         else if (gimme == G_ARRAY) {
2471             EXTEND_MORTAL(SP - newsp);
2472             for (mark = newsp + 1; mark <= SP; mark++) {
2473                 if (*mark != &PL_sv_undef
2474                     && SvFLAGS(*mark) & (SVs_TEMP | SVs_PADTMP | SVf_READONLY)) {
2475                     /* Might be flattened array after $#array =  */
2476                     PUTBACK;
2477                     LEAVE;
2478                     cxstack_ix--;
2479                     POPSUB(cx,sv);
2480                     PL_curpm = newpm;
2481                     LEAVESUB(sv);
2482                     DIE(aTHX_ "Can't return a %s from lvalue subroutine",
2483                         SvREADONLY(TOPs) ? "readonly value" : "temporary");
2484                 }
2485                 else {
2486                     /* Can be a localized value subject to deletion. */
2487                     PL_tmps_stack[++PL_tmps_ix] = *mark;
2488                     (void)SvREFCNT_inc(*mark);
2489                 }
2490             }
2491         }
2492     }
2493     else {
2494         if (gimme == G_SCALAR) {
2495           temporise:
2496             MARK = newsp + 1;
2497             if (MARK <= SP) {
2498                 if (cx->blk_sub.cv && CvDEPTH(cx->blk_sub.cv) > 1) {
2499                     if (SvTEMP(TOPs)) {
2500                         *MARK = SvREFCNT_inc(TOPs);
2501                         FREETMPS;
2502                         sv_2mortal(*MARK);
2503                     }
2504                     else {
2505                         sv = SvREFCNT_inc(TOPs); /* FREETMPS could clobber it */
2506                         FREETMPS;
2507                         *MARK = sv_mortalcopy(sv);
2508                         SvREFCNT_dec(sv);
2509                     }
2510                 }
2511                 else
2512                     *MARK = SvTEMP(TOPs) ? TOPs : sv_mortalcopy(TOPs);
2513             }
2514             else {
2515                 MEXTEND(MARK, 0);
2516                 *MARK = &PL_sv_undef;
2517             }
2518             SP = MARK;
2519         }
2520         else if (gimme == G_ARRAY) {
2521           temporise_array:
2522             for (MARK = newsp + 1; MARK <= SP; MARK++) {
2523                 if (!SvTEMP(*MARK)) {
2524                     *MARK = sv_mortalcopy(*MARK);
2525                     TAINT_NOT;  /* Each item is independent */
2526                 }
2527             }
2528         }
2529     }
2530     PUTBACK;
2531
2532     LEAVE;
2533     cxstack_ix--;
2534     POPSUB(cx,sv);      /* Stack values are safe: release CV and @_ ... */
2535     PL_curpm = newpm;   /* ... and pop $1 et al */
2536
2537     LEAVESUB(sv);
2538     return cx->blk_sub.retop;
2539 }
2540
2541
2542 STATIC CV *
2543 S_get_db_sub(pTHX_ SV **svp, CV *cv)
2544 {
2545     SV *dbsv = GvSVn(PL_DBsub);
2546
2547     save_item(dbsv);
2548     if (!PERLDB_SUB_NN) {
2549         GV *gv = CvGV(cv);
2550
2551         if ( (CvFLAGS(cv) & (CVf_ANON | CVf_CLONED))
2552              || strEQ(GvNAME(gv), "END")
2553              || ((GvCV(gv) != cv) && /* Could be imported, and old sub redefined. */
2554                  !( (SvTYPE(*svp) == SVt_PVGV) && (GvCV((GV*)*svp) == cv)
2555                     && (gv = (GV*)*svp) ))) {
2556             /* Use GV from the stack as a fallback. */
2557             /* GV is potentially non-unique, or contain different CV. */
2558             SV *tmp = newRV((SV*)cv);
2559             sv_setsv(dbsv, tmp);
2560             SvREFCNT_dec(tmp);
2561         }
2562         else {
2563             gv_efullname3(dbsv, gv, Nullch);
2564         }
2565     }
2566     else {
2567         const int type = SvTYPE(dbsv);
2568         if (type < SVt_PVIV && type != SVt_IV)
2569             sv_upgrade(dbsv, SVt_PVIV);
2570         (void)SvIOK_on(dbsv);
2571         SvIV_set(dbsv, PTR2IV(cv));     /* Do it the quickest way  */
2572     }
2573
2574     if (CvXSUB(cv))
2575         PL_curcopdb = PL_curcop;
2576     cv = GvCV(PL_DBsub);
2577     return cv;
2578 }
2579
2580 PP(pp_entersub)
2581 {
2582     dVAR; dSP; dPOPss;
2583     GV *gv;
2584     HV *stash;
2585     register CV *cv;
2586     register PERL_CONTEXT *cx;
2587     I32 gimme;
2588     const bool hasargs = (PL_op->op_flags & OPf_STACKED) != 0;
2589
2590     if (!sv)
2591         DIE(aTHX_ "Not a CODE reference");
2592     switch (SvTYPE(sv)) {
2593         /* This is overwhelming the most common case:  */
2594     case SVt_PVGV:
2595         if (!(cv = GvCVu((GV*)sv)))
2596             cv = sv_2cv(sv, &stash, &gv, FALSE);
2597         if (!cv) {
2598             ENTER;
2599             SAVETMPS;
2600             goto try_autoload;
2601         }
2602         break;
2603     default:
2604         if (!SvROK(sv)) {
2605             const char *sym;
2606             if (sv == &PL_sv_yes) {             /* unfound import, ignore */
2607                 if (hasargs)
2608                     SP = PL_stack_base + POPMARK;
2609                 RETURN;
2610             }
2611             if (SvGMAGICAL(sv)) {
2612                 mg_get(sv);
2613                 if (SvROK(sv))
2614                     goto got_rv;
2615                 sym = SvPOKp(sv) ? SvPVX_const(sv) : Nullch;
2616             }
2617             else {
2618                 sym = SvPV_nolen_const(sv);
2619             }
2620             if (!sym)
2621                 DIE(aTHX_ PL_no_usym, "a subroutine");
2622             if (PL_op->op_private & HINT_STRICT_REFS)
2623                 DIE(aTHX_ PL_no_symref, sym, "a subroutine");
2624             cv = get_cv(sym, TRUE);
2625             break;
2626         }
2627   got_rv:
2628         {
2629             SV **sp = &sv;              /* Used in tryAMAGICunDEREF macro. */
2630             tryAMAGICunDEREF(to_cv);
2631         }
2632         cv = (CV*)SvRV(sv);
2633         if (SvTYPE(cv) == SVt_PVCV)
2634             break;
2635         /* FALL THROUGH */
2636     case SVt_PVHV:
2637     case SVt_PVAV:
2638         DIE(aTHX_ "Not a CODE reference");
2639         /* This is the second most common case:  */
2640     case SVt_PVCV:
2641         cv = (CV*)sv;
2642         break;
2643     }
2644
2645     ENTER;
2646     SAVETMPS;
2647
2648   retry:
2649     if (!CvROOT(cv) && !CvXSUB(cv)) {
2650         goto fooey;
2651     }
2652
2653     gimme = GIMME_V;
2654     if ((PL_op->op_private & OPpENTERSUB_DB) && GvCV(PL_DBsub) && !CvNODEBUG(cv)) {
2655         if (CvASSERTION(cv) && PL_DBassertion)
2656             sv_setiv(PL_DBassertion, 1);
2657
2658         cv = get_db_sub(&sv, cv);
2659         if (!cv || (!CvXSUB(cv) && !CvSTART(cv)))
2660             DIE(aTHX_ "No DB::sub routine defined");
2661     }
2662
2663     if (!(CvXSUB(cv))) {
2664         /* This path taken at least 75% of the time   */
2665         dMARK;
2666         register I32 items = SP - MARK;
2667         AV* padlist = CvPADLIST(cv);
2668         PUSHBLOCK(cx, CXt_SUB, MARK);
2669         PUSHSUB(cx);
2670         cx->blk_sub.retop = PL_op->op_next;
2671         CvDEPTH(cv)++;
2672         /* XXX This would be a natural place to set C<PL_compcv = cv> so
2673          * that eval'' ops within this sub know the correct lexical space.
2674          * Owing the speed considerations, we choose instead to search for
2675          * the cv using find_runcv() when calling doeval().
2676          */
2677         if (CvDEPTH(cv) >= 2) {
2678             PERL_STACK_OVERFLOW_CHECK();
2679             pad_push(padlist, CvDEPTH(cv));
2680         }
2681         SAVECOMPPAD();
2682         PAD_SET_CUR_NOSAVE(padlist, CvDEPTH(cv));
2683         if (hasargs)
2684         {
2685             AV* av;
2686 #if 0
2687             DEBUG_S(PerlIO_printf(Perl_debug_log,
2688                                   "%p entersub preparing @_\n", thr));
2689 #endif
2690             av = (AV*)PAD_SVl(0);
2691             if (AvREAL(av)) {
2692                 /* @_ is normally not REAL--this should only ever
2693                  * happen when DB::sub() calls things that modify @_ */
2694                 av_clear(av);
2695                 AvREAL_off(av);
2696                 AvREIFY_on(av);
2697             }
2698             cx->blk_sub.savearray = GvAV(PL_defgv);
2699             GvAV(PL_defgv) = (AV*)SvREFCNT_inc(av);
2700             CX_CURPAD_SAVE(cx->blk_sub);
2701             cx->blk_sub.argarray = av;
2702             ++MARK;
2703
2704             if (items > AvMAX(av) + 1) {
2705                 SV **ary = AvALLOC(av);
2706                 if (AvARRAY(av) != ary) {
2707                     AvMAX(av) += AvARRAY(av) - AvALLOC(av);
2708                     SvPV_set(av, (char*)ary);
2709                 }
2710                 if (items > AvMAX(av) + 1) {
2711                     AvMAX(av) = items - 1;
2712                     Renew(ary,items,SV*);
2713                     AvALLOC(av) = ary;
2714                     SvPV_set(av, (char*)ary);
2715                 }
2716             }
2717             Copy(MARK,AvARRAY(av),items,SV*);
2718             AvFILLp(av) = items - 1;
2719
2720             while (items--) {
2721                 if (*MARK)
2722                     SvTEMP_off(*MARK);
2723                 MARK++;
2724             }
2725         }
2726         /* warning must come *after* we fully set up the context
2727          * stuff so that __WARN__ handlers can safely dounwind()
2728          * if they want to
2729          */
2730         if (CvDEPTH(cv) == 100 && ckWARN(WARN_RECURSION)
2731             && !(PERLDB_SUB && cv == GvCV(PL_DBsub)))
2732             sub_crush_depth(cv);
2733 #if 0
2734         DEBUG_S(PerlIO_printf(Perl_debug_log,
2735                               "%p entersub returning %p\n", thr, CvSTART(cv)));
2736 #endif
2737         RETURNOP(CvSTART(cv));
2738     }
2739     else {
2740 #ifdef PERL_XSUB_OLDSTYLE
2741         if (CvOLDSTYLE(cv)) {
2742             I32 (*fp3)(int,int,int);
2743             dMARK;
2744             register I32 items = SP - MARK;
2745                                         /* We dont worry to copy from @_. */
2746             while (SP > mark) {
2747                 SP[1] = SP[0];
2748                 SP--;
2749             }
2750             PL_stack_sp = mark + 1;
2751             fp3 = (I32(*)(int,int,int))CvXSUB(cv);
2752             items = (*fp3)(CvXSUBANY(cv).any_i32,
2753                            MARK - PL_stack_base + 1,
2754                            items);
2755             PL_stack_sp = PL_stack_base + items;
2756         }
2757         else
2758 #endif /* PERL_XSUB_OLDSTYLE */
2759         {
2760             I32 markix = TOPMARK;
2761
2762             PUTBACK;
2763
2764             if (!hasargs) {
2765                 /* Need to copy @_ to stack. Alternative may be to
2766                  * switch stack to @_, and copy return values
2767                  * back. This would allow popping @_ in XSUB, e.g.. XXXX */
2768                 AV * const av = GvAV(PL_defgv);
2769                 const I32 items = AvFILLp(av) + 1;   /* @_ is not tieable */
2770
2771                 if (items) {
2772                     /* Mark is at the end of the stack. */
2773                     EXTEND(SP, items);
2774                     Copy(AvARRAY(av), SP + 1, items, SV*);
2775                     SP += items;
2776                     PUTBACK ;
2777                 }
2778             }
2779             /* We assume first XSUB in &DB::sub is the called one. */
2780             if (PL_curcopdb) {
2781                 SAVEVPTR(PL_curcop);
2782                 PL_curcop = PL_curcopdb;
2783                 PL_curcopdb = NULL;
2784             }
2785             /* Do we need to open block here? XXXX */
2786             (void)(*CvXSUB(cv))(aTHX_ cv);
2787
2788             /* Enforce some sanity in scalar context. */
2789             if (gimme == G_SCALAR && ++markix != PL_stack_sp - PL_stack_base ) {
2790                 if (markix > PL_stack_sp - PL_stack_base)
2791                     *(PL_stack_base + markix) = &PL_sv_undef;
2792                 else
2793                     *(PL_stack_base + markix) = *PL_stack_sp;
2794                 PL_stack_sp = PL_stack_base + markix;
2795             }
2796         }
2797         LEAVE;
2798         return NORMAL;
2799     }
2800
2801     /*NOTREACHED*/
2802     assert (0); /* Cannot get here.  */
2803     /* This is deliberately moved here as spaghetti code to keep it out of the
2804        hot path.  */
2805     {
2806         GV* autogv;
2807         SV* sub_name;
2808
2809       fooey:
2810         /* anonymous or undef'd function leaves us no recourse */
2811         if (CvANON(cv) || !(gv = CvGV(cv)))
2812             DIE(aTHX_ "Undefined subroutine called");
2813
2814         /* autoloaded stub? */
2815         if (cv != GvCV(gv)) {
2816             cv = GvCV(gv);
2817         }
2818         /* should call AUTOLOAD now? */
2819         else {
2820 try_autoload:
2821             if ((autogv = gv_autoload4(GvSTASH(gv), GvNAME(gv), GvNAMELEN(gv),
2822                                    FALSE)))
2823             {
2824                 cv = GvCV(autogv);
2825             }
2826             /* sorry */
2827             else {
2828                 sub_name = sv_newmortal();
2829                 gv_efullname3(sub_name, gv, Nullch);
2830                 DIE(aTHX_ "Undefined subroutine &%"SVf" called", sub_name);
2831             }
2832         }
2833         if (!cv)
2834             DIE(aTHX_ "Not a CODE reference");
2835         goto retry;
2836     }
2837 }
2838
2839 void
2840 Perl_sub_crush_depth(pTHX_ CV *cv)
2841 {
2842     if (CvANON(cv))
2843         Perl_warner(aTHX_ packWARN(WARN_RECURSION), "Deep recursion on anonymous subroutine");
2844     else {
2845         SV* tmpstr = sv_newmortal();
2846         gv_efullname3(tmpstr, CvGV(cv), Nullch);
2847         Perl_warner(aTHX_ packWARN(WARN_RECURSION), "Deep recursion on subroutine \"%"SVf"\"",
2848                 tmpstr);
2849     }
2850 }
2851
2852 PP(pp_aelem)
2853 {
2854     dSP;
2855     SV** svp;
2856     SV* const elemsv = POPs;
2857     IV elem = SvIV(elemsv);
2858     AV* av = (AV*)POPs;
2859     const U32 lval = PL_op->op_flags & OPf_MOD || LVRET;
2860     const U32 defer = (PL_op->op_private & OPpLVAL_DEFER) && (elem > av_len(av));
2861     SV *sv;
2862
2863     if (SvROK(elemsv) && !SvGAMAGIC(elemsv) && ckWARN(WARN_MISC))
2864         Perl_warner(aTHX_ packWARN(WARN_MISC), "Use of reference \"%"SVf"\" as array index", elemsv);
2865     if (elem > 0)
2866         elem -= PL_curcop->cop_arybase;
2867     if (SvTYPE(av) != SVt_PVAV)
2868         RETPUSHUNDEF;
2869     svp = av_fetch(av, elem, lval && !defer);
2870     if (lval) {
2871 #ifdef PERL_MALLOC_WRAP
2872          if (SvUOK(elemsv)) {
2873               const UV uv = SvUV(elemsv);
2874               elem = uv > IV_MAX ? IV_MAX : uv;
2875          }
2876          else if (SvNOK(elemsv))
2877               elem = (IV)SvNV(elemsv);
2878          if (elem > 0) {
2879               static const char oom_array_extend[] =
2880                 "Out of memory during array extend"; /* Duplicated in av.c */
2881               MEM_WRAP_CHECK_1(elem,SV*,oom_array_extend);
2882          }
2883 #endif
2884         if (!svp || *svp == &PL_sv_undef) {
2885             SV* lv;
2886             if (!defer)
2887                 DIE(aTHX_ PL_no_aelem, elem);
2888             lv = sv_newmortal();
2889             sv_upgrade(lv, SVt_PVLV);
2890             LvTYPE(lv) = 'y';
2891             sv_magic(lv, Nullsv, PERL_MAGIC_defelem, Nullch, 0);
2892             LvTARG(lv) = SvREFCNT_inc(av);
2893             LvTARGOFF(lv) = elem;
2894             LvTARGLEN(lv) = 1;
2895             PUSHs(lv);
2896             RETURN;
2897         }
2898         if (PL_op->op_private & OPpLVAL_INTRO)
2899             save_aelem(av, elem, svp);
2900         else if (PL_op->op_private & OPpDEREF)
2901             vivify_ref(*svp, PL_op->op_private & OPpDEREF);
2902     }
2903     sv = (svp ? *svp : &PL_sv_undef);
2904     if (!lval && SvGMAGICAL(sv))        /* see note in pp_helem() */
2905         sv = sv_mortalcopy(sv);
2906     PUSHs(sv);
2907     RETURN;
2908 }
2909
2910 void
2911 Perl_vivify_ref(pTHX_ SV *sv, U32 to_what)
2912 {
2913     if (SvGMAGICAL(sv))
2914         mg_get(sv);
2915     if (!SvOK(sv)) {
2916         if (SvREADONLY(sv))
2917             Perl_croak(aTHX_ PL_no_modify);
2918         if (SvTYPE(sv) < SVt_RV)
2919             sv_upgrade(sv, SVt_RV);
2920         else if (SvTYPE(sv) >= SVt_PV) {
2921             SvPV_free(sv);
2922             SvLEN_set(sv, 0);
2923             SvCUR_set(sv, 0);
2924         }
2925         switch (to_what) {
2926         case OPpDEREF_SV:
2927             SvRV_set(sv, NEWSV(355,0));
2928             break;
2929         case OPpDEREF_AV:
2930             SvRV_set(sv, (SV*)newAV());
2931             break;
2932         case OPpDEREF_HV:
2933             SvRV_set(sv, (SV*)newHV());
2934             break;
2935         }
2936         SvROK_on(sv);
2937         SvSETMAGIC(sv);
2938     }
2939 }
2940
2941 PP(pp_method)
2942 {
2943     dSP;
2944     SV* sv = TOPs;
2945
2946     if (SvROK(sv)) {
2947         SV* rsv = SvRV(sv);
2948         if (SvTYPE(rsv) == SVt_PVCV) {
2949             SETs(rsv);
2950             RETURN;
2951         }
2952     }
2953
2954     SETs(method_common(sv, Null(U32*)));
2955     RETURN;
2956 }
2957
2958 PP(pp_method_named)
2959 {
2960     dSP;
2961     SV* sv = cSVOP_sv;
2962     U32 hash = SvSHARED_HASH(sv);
2963
2964     XPUSHs(method_common(sv, &hash));
2965     RETURN;
2966 }
2967
2968 STATIC SV *
2969 S_method_common(pTHX_ SV* meth, U32* hashp)
2970 {
2971     SV* sv;
2972     SV* ob;
2973     GV* gv;
2974     HV* stash;
2975     STRLEN namelen;
2976     const char* packname = 0;
2977     SV *packsv = Nullsv;
2978     STRLEN packlen;
2979     const char *name = SvPV_const(meth, namelen);
2980
2981     sv = *(PL_stack_base + TOPMARK + 1);
2982
2983     if (!sv)
2984         Perl_croak(aTHX_ "Can't call method \"%s\" on an undefined value", name);
2985
2986     if (SvGMAGICAL(sv))
2987         mg_get(sv);
2988     if (SvROK(sv))
2989         ob = (SV*)SvRV(sv);
2990     else {
2991         GV* iogv;
2992
2993         /* this isn't a reference */
2994         packname = Nullch;
2995
2996         if(SvOK(sv) && (packname = SvPV_const(sv, packlen))) {
2997           const HE* const he = hv_fetch_ent(PL_stashcache, sv, 0, 0);
2998           if (he) {
2999             stash = INT2PTR(HV*,SvIV(HeVAL(he)));
3000             goto fetch;
3001           }
3002         }
3003
3004         if (!SvOK(sv) ||
3005             !(packname) ||
3006             !(iogv = gv_fetchsv(sv, FALSE, SVt_PVIO)) ||
3007             !(ob=(SV*)GvIO(iogv)))
3008         {
3009             /* this isn't the name of a filehandle either */
3010             if (!packname ||
3011                 ((UTF8_IS_START(*packname) && DO_UTF8(sv))
3012                     ? !isIDFIRST_utf8((U8*)packname)
3013                     : !isIDFIRST(*packname)
3014                 ))
3015             {
3016                 Perl_croak(aTHX_ "Can't call method \"%s\" %s", name,
3017                            SvOK(sv) ? "without a package or object reference"
3018                                     : "on an undefined value");
3019             }
3020             /* assume it's a package name */
3021             stash = gv_stashpvn(packname, packlen, FALSE);
3022             if (!stash)
3023                 packsv = sv;
3024             else {
3025                 SV* ref = newSViv(PTR2IV(stash));
3026                 hv_store(PL_stashcache, packname, packlen, ref, 0);
3027             }
3028             goto fetch;
3029         }
3030         /* it _is_ a filehandle name -- replace with a reference */
3031         *(PL_stack_base + TOPMARK + 1) = sv_2mortal(newRV((SV*)iogv));
3032     }
3033
3034     /* if we got here, ob should be a reference or a glob */
3035     if (!ob || !(SvOBJECT(ob)
3036                  || (SvTYPE(ob) == SVt_PVGV && (ob = (SV*)GvIO((GV*)ob))
3037                      && SvOBJECT(ob))))
3038     {
3039         Perl_croak(aTHX_ "Can't call method \"%s\" on unblessed reference",
3040                    name);
3041     }
3042
3043     stash = SvSTASH(ob);
3044
3045   fetch:
3046     /* NOTE: stash may be null, hope hv_fetch_ent and
3047        gv_fetchmethod can cope (it seems they can) */
3048
3049     /* shortcut for simple names */
3050     if (hashp) {
3051         const HE* const he = hv_fetch_ent(stash, meth, 0, *hashp);
3052         if (he) {
3053             gv = (GV*)HeVAL(he);
3054             if (isGV(gv) && GvCV(gv) &&
3055                 (!GvCVGEN(gv) || GvCVGEN(gv) == PL_sub_generation))
3056                 return (SV*)GvCV(gv);
3057         }
3058     }
3059
3060     gv = gv_fetchmethod(stash ? stash : (HV*)packsv, name);
3061
3062     if (!gv) {
3063         /* This code tries to figure out just what went wrong with
3064            gv_fetchmethod.  It therefore needs to duplicate a lot of
3065            the internals of that function.  We can't move it inside
3066            Perl_gv_fetchmethod_autoload(), however, since that would
3067            cause UNIVERSAL->can("NoSuchPackage::foo") to croak, and we
3068            don't want that.
3069         */
3070         const char* leaf = name;
3071         const char* sep = Nullch;
3072         const char* p;
3073
3074         for (p = name; *p; p++) {
3075             if (*p == '\'')
3076                 sep = p, leaf = p + 1;
3077             else if (*p == ':' && *(p + 1) == ':')
3078                 sep = p, leaf = p + 2;
3079         }
3080         if (!sep || ((sep - name) == 5 && strnEQ(name, "SUPER", 5))) {
3081             /* the method name is unqualified or starts with SUPER:: */
3082             bool need_strlen = 1;
3083             if (sep) {
3084                 packname = CopSTASHPV(PL_curcop);
3085             }
3086             else if (stash) {
3087                 HEK *packhek = HvNAME_HEK(stash);
3088                 if (packhek) {
3089                     packname = HEK_KEY(packhek);
3090                     packlen = HEK_LEN(packhek);
3091                     need_strlen = 0;
3092                 } else {
3093                     goto croak;
3094                 }
3095             }
3096
3097             if (!packname) {
3098             croak:
3099                 Perl_croak(aTHX_
3100                            "Can't use anonymous symbol table for method lookup");
3101             }
3102             else if (need_strlen)
3103                 packlen = strlen(packname);
3104
3105         }
3106         else {
3107             /* the method name is qualified */
3108             packname = name;
3109             packlen = sep - name;
3110         }
3111
3112         /* we're relying on gv_fetchmethod not autovivifying the stash */
3113         if (gv_stashpvn(packname, packlen, FALSE)) {
3114             Perl_croak(aTHX_
3115                        "Can't locate object method \"%s\" via package \"%.*s\"",
3116                        leaf, (int)packlen, packname);
3117         }
3118         else {
3119             Perl_croak(aTHX_
3120                        "Can't locate object method \"%s\" via package \"%.*s\""
3121                        " (perhaps you forgot to load \"%.*s\"?)",
3122                        leaf, (int)packlen, packname, (int)packlen, packname);
3123         }
3124     }
3125     return isGV(gv) ? (SV*)GvCV(gv) : (SV*)gv;
3126 }
3127
3128 /*
3129  * Local variables:
3130  * c-indentation-style: bsd
3131  * c-basic-offset: 4
3132  * indent-tabs-mode: t
3133  * End:
3134  *
3135  * ex: set ts=8 sts=4 sw=4 noet:
3136  */