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     if (!s)
1205         DIE(aTHX_ "panic: pp_match");
1206     strend = s + len;
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 ((!io || !(IoFLAGS(io) & IOf_START))
1498             && ckWARN2(WARN_GLOB, WARN_CLOSED))
1499         {
1500             if (type == OP_GLOB)
1501                 Perl_warner(aTHX_ packWARN(WARN_GLOB),
1502                             "glob failed (can't start child: %s)",
1503                             Strerror(errno));
1504             else
1505                 report_evil_fh(PL_last_in_gv, io, PL_op->op_type);
1506         }
1507         if (gimme == G_SCALAR) {
1508             /* undef TARG, and push that undefined value */
1509             if (type != OP_RCATLINE) {
1510                 SV_CHECK_THINKFIRST_COW_DROP(TARG);
1511                 SvOK_off(TARG);
1512             }
1513             PUSHTARG;
1514         }
1515         RETURN;
1516     }
1517   have_fp:
1518     if (gimme == G_SCALAR) {
1519         sv = TARG;
1520         if (SvROK(sv))
1521             sv_unref(sv);
1522         SvUPGRADE(sv, SVt_PV);
1523         tmplen = SvLEN(sv);     /* remember if already alloced */
1524         if (!tmplen && !SvREADONLY(sv))
1525             Sv_Grow(sv, 80);    /* try short-buffering it */
1526         offset = 0;
1527         if (type == OP_RCATLINE && SvOK(sv)) {
1528             if (!SvPOK(sv)) {
1529                 SvPV_force_nolen(sv);
1530             }
1531             offset = SvCUR(sv);
1532         }
1533     }
1534     else {
1535         sv = sv_2mortal(NEWSV(57, 80));
1536         offset = 0;
1537     }
1538
1539     /* This should not be marked tainted if the fp is marked clean */
1540 #define MAYBE_TAINT_LINE(io, sv) \
1541     if (!(IoFLAGS(io) & IOf_UNTAINT)) { \
1542         TAINT;                          \
1543         SvTAINTED_on(sv);               \
1544     }
1545
1546 /* delay EOF state for a snarfed empty file */
1547 #define SNARF_EOF(gimme,rs,io,sv) \
1548     (gimme != G_SCALAR || SvCUR(sv)                                     \
1549      || (IoFLAGS(io) & IOf_NOLINE) || !RsSNARF(rs))
1550
1551     for (;;) {
1552         PUTBACK;
1553         if (!sv_gets(sv, fp, offset)
1554             && (type == OP_GLOB
1555                 || SNARF_EOF(gimme, PL_rs, io, sv)
1556                 || PerlIO_error(fp)))
1557         {
1558             PerlIO_clearerr(fp);
1559             if (IoFLAGS(io) & IOf_ARGV) {
1560                 fp = nextargv(PL_last_in_gv);
1561                 if (fp)
1562                     continue;
1563                 (void)do_close(PL_last_in_gv, FALSE);
1564             }
1565             else if (type == OP_GLOB) {
1566                 if (!do_close(PL_last_in_gv, FALSE) && ckWARN(WARN_GLOB)) {
1567                     Perl_warner(aTHX_ packWARN(WARN_GLOB),
1568                            "glob failed (child exited with status %d%s)",
1569                            (int)(STATUS_CURRENT >> 8),
1570                            (STATUS_CURRENT & 0x80) ? ", core dumped" : "");
1571                 }
1572             }
1573             if (gimme == G_SCALAR) {
1574                 if (type != OP_RCATLINE) {
1575                     SV_CHECK_THINKFIRST_COW_DROP(TARG);
1576                     SvOK_off(TARG);
1577                 }
1578                 SPAGAIN;
1579                 PUSHTARG;
1580             }
1581             MAYBE_TAINT_LINE(io, sv);
1582             RETURN;
1583         }
1584         MAYBE_TAINT_LINE(io, sv);
1585         IoLINES(io)++;
1586         IoFLAGS(io) |= IOf_NOLINE;
1587         SvSETMAGIC(sv);
1588         SPAGAIN;
1589         XPUSHs(sv);
1590         if (type == OP_GLOB) {
1591             char *tmps;
1592             const char *t1;
1593
1594             if (SvCUR(sv) > 0 && SvCUR(PL_rs) > 0) {
1595                 tmps = SvEND(sv) - 1;
1596                 if (*tmps == *SvPVX_const(PL_rs)) {
1597                     *tmps = '\0';
1598                     SvCUR_set(sv, SvCUR(sv) - 1);
1599                 }
1600             }
1601             for (t1 = SvPVX_const(sv); *t1; t1++)
1602                 if (!isALPHA(*t1) && !isDIGIT(*t1) &&
1603                     strchr("$&*(){}[]'\";\\|?<>~`", *t1))
1604                         break;
1605             if (*t1 && PerlLIO_lstat(SvPVX_const(sv), &PL_statbuf) < 0) {
1606                 (void)POPs;             /* Unmatched wildcard?  Chuck it... */
1607                 continue;
1608             }
1609         } else if (SvUTF8(sv)) { /* OP_READLINE, OP_RCATLINE */
1610              const U8 *s = (const U8*)SvPVX_const(sv) + offset;
1611              const STRLEN len = SvCUR(sv) - offset;
1612              const U8 *f;
1613
1614              if (ckWARN(WARN_UTF8) &&
1615                     !Perl_is_utf8_string_loc(aTHX_ s, len, &f))
1616                   /* Emulate :encoding(utf8) warning in the same case. */
1617                   Perl_warner(aTHX_ packWARN(WARN_UTF8),
1618                               "utf8 \"\\x%02X\" does not map to Unicode",
1619                               f < (U8*)SvEND(sv) ? *f : 0);
1620         }
1621         if (gimme == G_ARRAY) {
1622             if (SvLEN(sv) - SvCUR(sv) > 20) {
1623                 SvPV_shrink_to_cur(sv);
1624             }
1625             sv = sv_2mortal(NEWSV(58, 80));
1626             continue;
1627         }
1628         else if (gimme == G_SCALAR && !tmplen && SvLEN(sv) - SvCUR(sv) > 80) {
1629             /* try to reclaim a bit of scalar space (only on 1st alloc) */
1630             const STRLEN new_len
1631                 = SvCUR(sv) < 60 ? 80 : SvCUR(sv)+40; /* allow some slop */
1632             SvPV_renew(sv, new_len);
1633         }
1634         RETURN;
1635     }
1636 }
1637
1638 PP(pp_enter)
1639 {
1640     dVAR; dSP;
1641     register PERL_CONTEXT *cx;
1642     I32 gimme = OP_GIMME(PL_op, -1);
1643
1644     if (gimme == -1) {
1645         if (cxstack_ix >= 0)
1646             gimme = cxstack[cxstack_ix].blk_gimme;
1647         else
1648             gimme = G_SCALAR;
1649     }
1650
1651     ENTER;
1652
1653     SAVETMPS;
1654     PUSHBLOCK(cx, CXt_BLOCK, SP);
1655
1656     RETURN;
1657 }
1658
1659 PP(pp_helem)
1660 {
1661     dSP;
1662     HE* he;
1663     SV **svp;
1664     SV *keysv = POPs;
1665     HV *hv = (HV*)POPs;
1666     const U32 lval = PL_op->op_flags & OPf_MOD || LVRET;
1667     const U32 defer = PL_op->op_private & OPpLVAL_DEFER;
1668     SV *sv;
1669     const U32 hash = (SvIsCOW_shared_hash(keysv)) ? SvSHARED_HASH(keysv) : 0;
1670     I32 preeminent = 0;
1671
1672     if (SvTYPE(hv) == SVt_PVHV) {
1673         if (PL_op->op_private & OPpLVAL_INTRO) {
1674             MAGIC *mg;
1675             HV *stash;
1676             /* does the element we're localizing already exist? */
1677             preeminent =
1678                 /* can we determine whether it exists? */
1679                 (    !SvRMAGICAL(hv)
1680                   || mg_find((SV*)hv, PERL_MAGIC_env)
1681                   || (     (mg = mg_find((SV*)hv, PERL_MAGIC_tied))
1682                         /* Try to preserve the existenceness of a tied hash
1683                          * element by using EXISTS and DELETE if possible.
1684                          * Fallback to FETCH and STORE otherwise */
1685                         && (stash = SvSTASH(SvRV(SvTIED_obj((SV*)hv, mg))))
1686                         && gv_fetchmethod_autoload(stash, "EXISTS", TRUE)
1687                         && gv_fetchmethod_autoload(stash, "DELETE", TRUE)
1688                     )
1689                 ) ? hv_exists_ent(hv, keysv, 0) : 1;
1690
1691         }
1692         he = hv_fetch_ent(hv, keysv, lval && !defer, hash);
1693         svp = he ? &HeVAL(he) : 0;
1694     }
1695     else {
1696         RETPUSHUNDEF;
1697     }
1698     if (lval) {
1699         if (!svp || *svp == &PL_sv_undef) {
1700             SV* lv;
1701             SV* key2;
1702             if (!defer) {
1703                 DIE(aTHX_ PL_no_helem_sv, keysv);
1704             }
1705             lv = sv_newmortal();
1706             sv_upgrade(lv, SVt_PVLV);
1707             LvTYPE(lv) = 'y';
1708             sv_magic(lv, key2 = newSVsv(keysv), PERL_MAGIC_defelem, Nullch, 0);
1709             SvREFCNT_dec(key2); /* sv_magic() increments refcount */
1710             LvTARG(lv) = SvREFCNT_inc(hv);
1711             LvTARGLEN(lv) = 1;
1712             PUSHs(lv);
1713             RETURN;
1714         }
1715         if (PL_op->op_private & OPpLVAL_INTRO) {
1716             if (HvNAME_get(hv) && isGV(*svp))
1717                 save_gp((GV*)*svp, !(PL_op->op_flags & OPf_SPECIAL));
1718             else {
1719                 if (!preeminent) {
1720                     STRLEN keylen;
1721                     const char * const key = SvPV_const(keysv, keylen);
1722                     SAVEDELETE(hv, savepvn(key,keylen), keylen);
1723                 } else
1724                     save_helem(hv, keysv, svp);
1725             }
1726         }
1727         else if (PL_op->op_private & OPpDEREF)
1728             vivify_ref(*svp, PL_op->op_private & OPpDEREF);
1729     }
1730     sv = (svp ? *svp : &PL_sv_undef);
1731     /* This makes C<local $tied{foo} = $tied{foo}> possible.
1732      * Pushing the magical RHS on to the stack is useless, since
1733      * that magic is soon destined to be misled by the local(),
1734      * and thus the later pp_sassign() will fail to mg_get() the
1735      * old value.  This should also cure problems with delayed
1736      * mg_get()s.  GSAR 98-07-03 */
1737     if (!lval && SvGMAGICAL(sv))
1738         sv = sv_mortalcopy(sv);
1739     PUSHs(sv);
1740     RETURN;
1741 }
1742
1743 PP(pp_leave)
1744 {
1745     dVAR; dSP;
1746     register PERL_CONTEXT *cx;
1747     SV **newsp;
1748     PMOP *newpm;
1749     I32 gimme;
1750
1751     if (PL_op->op_flags & OPf_SPECIAL) {
1752         cx = &cxstack[cxstack_ix];
1753         cx->blk_oldpm = PL_curpm;       /* fake block should preserve $1 et al */
1754     }
1755
1756     POPBLOCK(cx,newpm);
1757
1758     gimme = OP_GIMME(PL_op, -1);
1759     if (gimme == -1) {
1760         if (cxstack_ix >= 0)
1761             gimme = cxstack[cxstack_ix].blk_gimme;
1762         else
1763             gimme = G_SCALAR;
1764     }
1765
1766     TAINT_NOT;
1767     if (gimme == G_VOID)
1768         SP = newsp;
1769     else if (gimme == G_SCALAR) {
1770         register SV **mark;
1771         MARK = newsp + 1;
1772         if (MARK <= SP) {
1773             if (SvFLAGS(TOPs) & (SVs_PADTMP|SVs_TEMP))
1774                 *MARK = TOPs;
1775             else
1776                 *MARK = sv_mortalcopy(TOPs);
1777         } else {
1778             MEXTEND(mark,0);
1779             *MARK = &PL_sv_undef;
1780         }
1781         SP = MARK;
1782     }
1783     else if (gimme == G_ARRAY) {
1784         /* in case LEAVE wipes old return values */
1785         register SV **mark;
1786         for (mark = newsp + 1; mark <= SP; mark++) {
1787             if (!(SvFLAGS(*mark) & (SVs_PADTMP|SVs_TEMP))) {
1788                 *mark = sv_mortalcopy(*mark);
1789                 TAINT_NOT;      /* Each item is independent */
1790             }
1791         }
1792     }
1793     PL_curpm = newpm;   /* Don't pop $1 et al till now */
1794
1795     LEAVE;
1796
1797     RETURN;
1798 }
1799
1800 PP(pp_iter)
1801 {
1802     dSP;
1803     register PERL_CONTEXT *cx;
1804     SV *sv, *oldsv;
1805     AV* av;
1806     SV **itersvp;
1807
1808     EXTEND(SP, 1);
1809     cx = &cxstack[cxstack_ix];
1810     if (CxTYPE(cx) != CXt_LOOP)
1811         DIE(aTHX_ "panic: pp_iter");
1812
1813     itersvp = CxITERVAR(cx);
1814     av = cx->blk_loop.iterary;
1815     if (SvTYPE(av) != SVt_PVAV) {
1816         /* iterate ($min .. $max) */
1817         if (cx->blk_loop.iterlval) {
1818             /* string increment */
1819             register SV* cur = cx->blk_loop.iterlval;
1820             STRLEN maxlen = 0;
1821             const char *max = SvOK((SV*)av) ? SvPV_const((SV*)av, maxlen) : "";
1822             if (!SvNIOK(cur) && SvCUR(cur) <= maxlen) {
1823                 if (SvREFCNT(*itersvp) == 1 && !SvMAGICAL(*itersvp)) {
1824                     /* safe to reuse old SV */
1825                     sv_setsv(*itersvp, cur);
1826                 }
1827                 else
1828                 {
1829                     /* we need a fresh SV every time so that loop body sees a
1830                      * completely new SV for closures/references to work as
1831                      * they used to */
1832                     oldsv = *itersvp;
1833                     *itersvp = newSVsv(cur);
1834                     SvREFCNT_dec(oldsv);
1835                 }
1836                 if (strEQ(SvPVX_const(cur), max))
1837                     sv_setiv(cur, 0); /* terminate next time */
1838                 else
1839                     sv_inc(cur);
1840                 RETPUSHYES;
1841             }
1842             RETPUSHNO;
1843         }
1844         /* integer increment */
1845         if (cx->blk_loop.iterix > cx->blk_loop.itermax)
1846             RETPUSHNO;
1847
1848         /* don't risk potential race */
1849         if (SvREFCNT(*itersvp) == 1 && !SvMAGICAL(*itersvp)) {
1850             /* safe to reuse old SV */
1851             sv_setiv(*itersvp, cx->blk_loop.iterix++);
1852         }
1853         else
1854         {
1855             /* we need a fresh SV every time so that loop body sees a
1856              * completely new SV for closures/references to work as they
1857              * used to */
1858             oldsv = *itersvp;
1859             *itersvp = newSViv(cx->blk_loop.iterix++);
1860             SvREFCNT_dec(oldsv);
1861         }
1862         RETPUSHYES;
1863     }
1864
1865     /* iterate array */
1866     if (PL_op->op_private & OPpITER_REVERSED) {
1867         /* In reverse, use itermax as the min :-)  */
1868         if (cx->blk_loop.iterix <= cx->blk_loop.itermax)
1869             RETPUSHNO;
1870
1871         if (SvMAGICAL(av) || AvREIFY(av)) {
1872             SV **svp = av_fetch(av, cx->blk_loop.iterix--, FALSE);
1873             if (svp)
1874                 sv = *svp;
1875             else
1876                 sv = Nullsv;
1877         }
1878         else {
1879             sv = AvARRAY(av)[cx->blk_loop.iterix--];
1880         }
1881     }
1882     else {
1883         if (cx->blk_loop.iterix >= (av == PL_curstack ? cx->blk_oldsp :
1884                                     AvFILL(av)))
1885             RETPUSHNO;
1886
1887         if (SvMAGICAL(av) || AvREIFY(av)) {
1888             SV **svp = av_fetch(av, ++cx->blk_loop.iterix, FALSE);
1889             if (svp)
1890                 sv = *svp;
1891             else
1892                 sv = Nullsv;
1893         }
1894         else {
1895             sv = AvARRAY(av)[++cx->blk_loop.iterix];
1896         }
1897     }
1898
1899     if (sv && SvREFCNT(sv) == 0) {
1900         *itersvp = Nullsv;
1901         Perl_croak(aTHX_ "Use of freed value in iteration");
1902     }
1903
1904     if (sv)
1905         SvTEMP_off(sv);
1906     else
1907         sv = &PL_sv_undef;
1908     if (av != PL_curstack && sv == &PL_sv_undef) {
1909         SV *lv = cx->blk_loop.iterlval;
1910         if (lv && SvREFCNT(lv) > 1) {
1911             SvREFCNT_dec(lv);
1912             lv = Nullsv;
1913         }
1914         if (lv)
1915             SvREFCNT_dec(LvTARG(lv));
1916         else {
1917             lv = cx->blk_loop.iterlval = NEWSV(26, 0);
1918             sv_upgrade(lv, SVt_PVLV);
1919             LvTYPE(lv) = 'y';
1920             sv_magic(lv, Nullsv, PERL_MAGIC_defelem, Nullch, 0);
1921         }
1922         LvTARG(lv) = SvREFCNT_inc(av);
1923         LvTARGOFF(lv) = cx->blk_loop.iterix;
1924         LvTARGLEN(lv) = (STRLEN)UV_MAX;
1925         sv = (SV*)lv;
1926     }
1927
1928     oldsv = *itersvp;
1929     *itersvp = SvREFCNT_inc(sv);
1930     SvREFCNT_dec(oldsv);
1931
1932     RETPUSHYES;
1933 }
1934
1935 PP(pp_subst)
1936 {
1937     dSP; dTARG;
1938     register PMOP *pm = cPMOP;
1939     PMOP *rpm = pm;
1940     register SV *dstr;
1941     register char *s;
1942     char *strend;
1943     register char *m;
1944     const char *c;
1945     register char *d;
1946     STRLEN clen;
1947     I32 iters = 0;
1948     I32 maxiters;
1949     register I32 i;
1950     bool once;
1951     bool rxtainted;
1952     char *orig;
1953     I32 r_flags;
1954     register REGEXP *rx = PM_GETRE(pm);
1955     STRLEN len;
1956     int force_on_match = 0;
1957     I32 oldsave = PL_savestack_ix;
1958     STRLEN slen;
1959     bool doutf8 = FALSE;
1960 #ifdef PERL_OLD_COPY_ON_WRITE
1961     bool is_cow;
1962 #endif
1963     SV *nsv = Nullsv;
1964
1965     /* known replacement string? */
1966     dstr = (pm->op_pmflags & PMf_CONST) ? POPs : Nullsv;
1967     if (PL_op->op_flags & OPf_STACKED)
1968         TARG = POPs;
1969     else if (PL_op->op_private & OPpTARGET_MY)
1970         GETTARGET;
1971     else {
1972         TARG = DEFSV;
1973         EXTEND(SP,1);
1974     }
1975
1976 #ifdef PERL_OLD_COPY_ON_WRITE
1977     /* Awooga. Awooga. "bool" types that are actually char are dangerous,
1978        because they make integers such as 256 "false".  */
1979     is_cow = SvIsCOW(TARG) ? TRUE : FALSE;
1980 #else
1981     if (SvIsCOW(TARG))
1982         sv_force_normal_flags(TARG,0);
1983 #endif
1984     if (
1985 #ifdef PERL_OLD_COPY_ON_WRITE
1986         !is_cow &&
1987 #endif
1988         (SvREADONLY(TARG)
1989         || ( (SvTYPE(TARG) == SVt_PVGV || SvTYPE(TARG) > SVt_PVLV)
1990              && !(SvTYPE(TARG) == SVt_PVGV && SvFAKE(TARG)))))
1991         DIE(aTHX_ PL_no_modify);
1992     PUTBACK;
1993
1994     s = SvPV_mutable(TARG, len);
1995     if (!SvPOKp(TARG) || SvTYPE(TARG) == SVt_PVGV)
1996         force_on_match = 1;
1997     rxtainted = ((pm->op_pmdynflags & PMdf_TAINTED) ||
1998                  (PL_tainted && (pm->op_pmflags & PMf_RETAINT)));
1999     if (PL_tainted)
2000         rxtainted |= 2;
2001     TAINT_NOT;
2002
2003     RX_MATCH_UTF8_set(rx, DO_UTF8(TARG));
2004
2005   force_it:
2006     if (!pm || !s)
2007         DIE(aTHX_ "panic: pp_subst");
2008
2009     strend = s + len;
2010     slen = RX_MATCH_UTF8(rx) ? utf8_length((U8*)s, (U8*)strend) : len;
2011     maxiters = 2 * slen + 10;   /* We can match twice at each
2012                                    position, once with zero-length,
2013                                    second time with non-zero. */
2014
2015     if (!rx->prelen && PL_curpm) {
2016         pm = PL_curpm;
2017         rx = PM_GETRE(pm);
2018     }
2019     r_flags = (rx->nparens || SvTEMP(TARG) || PL_sawampersand)
2020                ? REXEC_COPY_STR : 0;
2021     if (SvSCREAM(TARG))
2022         r_flags |= REXEC_SCREAM;
2023
2024     orig = m = s;
2025     if (rx->reganch & RE_USE_INTUIT) {
2026         PL_bostr = orig;
2027         s = CALLREG_INTUIT_START(aTHX_ rx, TARG, s, strend, r_flags, NULL);
2028
2029         if (!s)
2030             goto nope;
2031         /* How to do it in subst? */
2032 /*      if ( (rx->reganch & ROPT_CHECK_ALL)
2033              && !PL_sawampersand
2034              && ((rx->reganch & ROPT_NOSCAN)
2035                  || !((rx->reganch & RE_INTUIT_TAIL)
2036                       && (r_flags & REXEC_SCREAM))))
2037             goto yup;
2038 */
2039     }
2040
2041     /* only replace once? */
2042     once = !(rpm->op_pmflags & PMf_GLOBAL);
2043
2044     /* known replacement string? */
2045     if (dstr) {
2046         /* replacement needing upgrading? */
2047         if (DO_UTF8(TARG) && !doutf8) {
2048              nsv = sv_newmortal();
2049              SvSetSV(nsv, dstr);
2050              if (PL_encoding)
2051                   sv_recode_to_utf8(nsv, PL_encoding);
2052              else
2053                   sv_utf8_upgrade(nsv);
2054              c = SvPV_const(nsv, clen);
2055              doutf8 = TRUE;
2056         }
2057         else {
2058             c = SvPV_const(dstr, clen);
2059             doutf8 = DO_UTF8(dstr);
2060         }
2061     }
2062     else {
2063         c = Nullch;
2064         doutf8 = FALSE;
2065     }
2066
2067     /* can do inplace substitution? */
2068     if (c
2069 #ifdef PERL_OLD_COPY_ON_WRITE
2070         && !is_cow
2071 #endif
2072         && (I32)clen <= rx->minlen && (once || !(r_flags & REXEC_COPY_STR))
2073         && !(rx->reganch & ROPT_LOOKBEHIND_SEEN)
2074         && (!doutf8 || SvUTF8(TARG))) {
2075         if (!CALLREGEXEC(aTHX_ rx, s, strend, orig, 0, TARG, NULL,
2076                          r_flags | REXEC_CHECKED))
2077         {
2078             SPAGAIN;
2079             PUSHs(&PL_sv_no);
2080             LEAVE_SCOPE(oldsave);
2081             RETURN;
2082         }
2083 #ifdef PERL_OLD_COPY_ON_WRITE
2084         if (SvIsCOW(TARG)) {
2085             assert (!force_on_match);
2086             goto have_a_cow;
2087         }
2088 #endif
2089         if (force_on_match) {
2090             force_on_match = 0;
2091             s = SvPV_force(TARG, len);
2092             goto force_it;
2093         }
2094         d = s;
2095         PL_curpm = pm;
2096         SvSCREAM_off(TARG);     /* disable possible screamer */
2097         if (once) {
2098             rxtainted |= RX_MATCH_TAINTED(rx);
2099             m = orig + rx->startp[0];
2100             d = orig + rx->endp[0];
2101             s = orig;
2102             if (m - s > strend - d) {  /* faster to shorten from end */
2103                 if (clen) {
2104                     Copy(c, m, clen, char);
2105                     m += clen;
2106                 }
2107                 i = strend - d;
2108                 if (i > 0) {
2109                     Move(d, m, i, char);
2110                     m += i;
2111                 }
2112                 *m = '\0';
2113                 SvCUR_set(TARG, m - s);
2114             }
2115             else if ((i = m - s)) {     /* faster from front */
2116                 d -= clen;
2117                 m = d;
2118                 sv_chop(TARG, d-i);
2119                 s += i;
2120                 while (i--)
2121                     *--d = *--s;
2122                 if (clen)
2123                     Copy(c, m, clen, char);
2124             }
2125             else if (clen) {
2126                 d -= clen;
2127                 sv_chop(TARG, d);
2128                 Copy(c, d, clen, char);
2129             }
2130             else {
2131                 sv_chop(TARG, d);
2132             }
2133             TAINT_IF(rxtainted & 1);
2134             SPAGAIN;
2135             PUSHs(&PL_sv_yes);
2136         }
2137         else {
2138             do {
2139                 if (iters++ > maxiters)
2140                     DIE(aTHX_ "Substitution loop");
2141                 rxtainted |= RX_MATCH_TAINTED(rx);
2142                 m = rx->startp[0] + orig;
2143                 if ((i = m - s)) {
2144                     if (s != d)
2145                         Move(s, d, i, char);
2146                     d += i;
2147                 }
2148                 if (clen) {
2149                     Copy(c, d, clen, char);
2150                     d += clen;
2151                 }
2152                 s = rx->endp[0] + orig;
2153             } while (CALLREGEXEC(aTHX_ rx, s, strend, orig, s == m,
2154                                  TARG, NULL,
2155                                  /* don't match same null twice */
2156                                  REXEC_NOT_FIRST|REXEC_IGNOREPOS));
2157             if (s != d) {
2158                 i = strend - s;
2159                 SvCUR_set(TARG, d - SvPVX_const(TARG) + i);
2160                 Move(s, d, i+1, char);          /* include the NUL */
2161             }
2162             TAINT_IF(rxtainted & 1);
2163             SPAGAIN;
2164             PUSHs(sv_2mortal(newSViv((I32)iters)));
2165         }
2166         (void)SvPOK_only_UTF8(TARG);
2167         TAINT_IF(rxtainted);
2168         if (SvSMAGICAL(TARG)) {
2169             PUTBACK;
2170             mg_set(TARG);
2171             SPAGAIN;
2172         }
2173         SvTAINT(TARG);
2174         if (doutf8)
2175             SvUTF8_on(TARG);
2176         LEAVE_SCOPE(oldsave);
2177         RETURN;
2178     }
2179
2180     if (CALLREGEXEC(aTHX_ rx, s, strend, orig, 0, TARG, NULL,
2181                     r_flags | REXEC_CHECKED))
2182     {
2183         if (force_on_match) {
2184             force_on_match = 0;
2185             s = SvPV_force(TARG, len);
2186             goto force_it;
2187         }
2188 #ifdef PERL_OLD_COPY_ON_WRITE
2189       have_a_cow:
2190 #endif
2191         rxtainted |= RX_MATCH_TAINTED(rx);
2192         dstr = newSVpvn(m, s-m);
2193         if (DO_UTF8(TARG))
2194             SvUTF8_on(dstr);
2195         PL_curpm = pm;
2196         if (!c) {
2197             register PERL_CONTEXT *cx;
2198             SPAGAIN;
2199             (void)ReREFCNT_inc(rx);
2200             PUSHSUBST(cx);
2201             RETURNOP(cPMOP->op_pmreplroot);
2202         }
2203         r_flags |= REXEC_IGNOREPOS | REXEC_NOT_FIRST;
2204         do {
2205             if (iters++ > maxiters)
2206                 DIE(aTHX_ "Substitution loop");
2207             rxtainted |= RX_MATCH_TAINTED(rx);
2208             if (RX_MATCH_COPIED(rx) && rx->subbeg != orig) {
2209                 m = s;
2210                 s = orig;
2211                 orig = rx->subbeg;
2212                 s = orig + (m - s);
2213                 strend = s + (strend - m);
2214             }
2215             m = rx->startp[0] + orig;
2216             if (doutf8 && !SvUTF8(dstr))
2217                 sv_catpvn_utf8_upgrade(dstr, s, m - s, nsv);
2218             else
2219                 sv_catpvn(dstr, s, m-s);
2220             s = rx->endp[0] + orig;
2221             if (clen)
2222                 sv_catpvn(dstr, c, clen);
2223             if (once)
2224                 break;
2225         } while (CALLREGEXEC(aTHX_ rx, s, strend, orig, s == m,
2226                              TARG, NULL, r_flags));
2227         if (doutf8 && !DO_UTF8(TARG))
2228             sv_catpvn_utf8_upgrade(dstr, s, strend - s, nsv);
2229         else
2230             sv_catpvn(dstr, s, strend - s);
2231
2232 #ifdef PERL_OLD_COPY_ON_WRITE
2233         /* The match may make the string COW. If so, brilliant, because that's
2234            just saved us one malloc, copy and free - the regexp has donated
2235            the old buffer, and we malloc an entirely new one, rather than the
2236            regexp malloc()ing a buffer and copying our original, only for
2237            us to throw it away here during the substitution.  */
2238         if (SvIsCOW(TARG)) {
2239             sv_force_normal_flags(TARG, SV_COW_DROP_PV);
2240         } else
2241 #endif
2242         {
2243             SvPV_free(TARG);
2244         }
2245         SvPV_set(TARG, SvPVX(dstr));
2246         SvCUR_set(TARG, SvCUR(dstr));
2247         SvLEN_set(TARG, SvLEN(dstr));
2248         doutf8 |= DO_UTF8(dstr);
2249         SvPV_set(dstr, (char*)0);
2250         sv_free(dstr);
2251
2252         TAINT_IF(rxtainted & 1);
2253         SPAGAIN;
2254         PUSHs(sv_2mortal(newSViv((I32)iters)));
2255
2256         (void)SvPOK_only(TARG);
2257         if (doutf8)
2258             SvUTF8_on(TARG);
2259         TAINT_IF(rxtainted);
2260         SvSETMAGIC(TARG);
2261         SvTAINT(TARG);
2262         LEAVE_SCOPE(oldsave);
2263         RETURN;
2264     }
2265     goto ret_no;
2266
2267 nope:
2268 ret_no:
2269     SPAGAIN;
2270     PUSHs(&PL_sv_no);
2271     LEAVE_SCOPE(oldsave);
2272     RETURN;
2273 }
2274
2275 PP(pp_grepwhile)
2276 {
2277     dVAR; dSP;
2278
2279     if (SvTRUEx(POPs))
2280         PL_stack_base[PL_markstack_ptr[-1]++] = PL_stack_base[*PL_markstack_ptr];
2281     ++*PL_markstack_ptr;
2282     LEAVE;                                      /* exit inner scope */
2283
2284     /* All done yet? */
2285     if (PL_stack_base + *PL_markstack_ptr > SP) {
2286         I32 items;
2287         I32 gimme = GIMME_V;
2288
2289         LEAVE;                                  /* exit outer scope */
2290         (void)POPMARK;                          /* pop src */
2291         items = --*PL_markstack_ptr - PL_markstack_ptr[-1];
2292         (void)POPMARK;                          /* pop dst */
2293         SP = PL_stack_base + POPMARK;           /* pop original mark */
2294         if (gimme == G_SCALAR) {
2295             if (PL_op->op_private & OPpGREP_LEX) {
2296                 SV* sv = sv_newmortal();
2297                 sv_setiv(sv, items);
2298                 PUSHs(sv);
2299             }
2300             else {
2301                 dTARGET;
2302                 XPUSHi(items);
2303             }
2304         }
2305         else if (gimme == G_ARRAY)
2306             SP += items;
2307         RETURN;
2308     }
2309     else {
2310         SV *src;
2311
2312         ENTER;                                  /* enter inner scope */
2313         SAVEVPTR(PL_curpm);
2314
2315         src = PL_stack_base[*PL_markstack_ptr];
2316         SvTEMP_off(src);
2317         if (PL_op->op_private & OPpGREP_LEX)
2318             PAD_SVl(PL_op->op_targ) = src;
2319         else
2320             DEFSV = src;
2321
2322         RETURNOP(cLOGOP->op_other);
2323     }
2324 }
2325
2326 PP(pp_leavesub)
2327 {
2328     dVAR; dSP;
2329     SV **mark;
2330     SV **newsp;
2331     PMOP *newpm;
2332     I32 gimme;
2333     register PERL_CONTEXT *cx;
2334     SV *sv;
2335
2336     POPBLOCK(cx,newpm);
2337     cxstack_ix++; /* temporarily protect top context */
2338
2339     TAINT_NOT;
2340     if (gimme == G_SCALAR) {
2341         MARK = newsp + 1;
2342         if (MARK <= SP) {
2343             if (cx->blk_sub.cv && CvDEPTH(cx->blk_sub.cv) > 1) {
2344                 if (SvTEMP(TOPs)) {
2345                     *MARK = SvREFCNT_inc(TOPs);
2346                     FREETMPS;
2347                     sv_2mortal(*MARK);
2348                 }
2349                 else {
2350                     sv = SvREFCNT_inc(TOPs);    /* FREETMPS could clobber it */
2351                     FREETMPS;
2352                     *MARK = sv_mortalcopy(sv);
2353                     SvREFCNT_dec(sv);
2354                 }
2355             }
2356             else
2357                 *MARK = SvTEMP(TOPs) ? TOPs : sv_mortalcopy(TOPs);
2358         }
2359         else {
2360             MEXTEND(MARK, 0);
2361             *MARK = &PL_sv_undef;
2362         }
2363         SP = MARK;
2364     }
2365     else if (gimme == G_ARRAY) {
2366         for (MARK = newsp + 1; MARK <= SP; MARK++) {
2367             if (!SvTEMP(*MARK)) {
2368                 *MARK = sv_mortalcopy(*MARK);
2369                 TAINT_NOT;      /* Each item is independent */
2370             }
2371         }
2372     }
2373     PUTBACK;
2374
2375     LEAVE;
2376     cxstack_ix--;
2377     POPSUB(cx,sv);      /* Stack values are safe: release CV and @_ ... */
2378     PL_curpm = newpm;   /* ... and pop $1 et al */
2379
2380     LEAVESUB(sv);
2381     return cx->blk_sub.retop;
2382 }
2383
2384 /* This duplicates the above code because the above code must not
2385  * get any slower by more conditions */
2386 PP(pp_leavesublv)
2387 {
2388     dVAR; dSP;
2389     SV **mark;
2390     SV **newsp;
2391     PMOP *newpm;
2392     I32 gimme;
2393     register PERL_CONTEXT *cx;
2394     SV *sv;
2395
2396     POPBLOCK(cx,newpm);
2397     cxstack_ix++; /* temporarily protect top context */
2398
2399     TAINT_NOT;
2400
2401     if (cx->blk_sub.lval & OPpENTERSUB_INARGS) {
2402         /* We are an argument to a function or grep().
2403          * This kind of lvalueness was legal before lvalue
2404          * subroutines too, so be backward compatible:
2405          * cannot report errors.  */
2406
2407         /* Scalar context *is* possible, on the LHS of -> only,
2408          * as in f()->meth().  But this is not an lvalue. */
2409         if (gimme == G_SCALAR)
2410             goto temporise;
2411         if (gimme == G_ARRAY) {
2412             if (!CvLVALUE(cx->blk_sub.cv))
2413                 goto temporise_array;
2414             EXTEND_MORTAL(SP - newsp);
2415             for (mark = newsp + 1; mark <= SP; mark++) {
2416                 if (SvTEMP(*mark))
2417                     /* empty */ ;
2418                 else if (SvFLAGS(*mark) & (SVs_PADTMP | SVf_READONLY))
2419                     *mark = sv_mortalcopy(*mark);
2420                 else {
2421                     /* Can be a localized value subject to deletion. */
2422                     PL_tmps_stack[++PL_tmps_ix] = *mark;
2423                     (void)SvREFCNT_inc(*mark);
2424                 }
2425             }
2426         }
2427     }
2428     else if (cx->blk_sub.lval) {     /* Leave it as it is if we can. */
2429         /* Here we go for robustness, not for speed, so we change all
2430          * the refcounts so the caller gets a live guy. Cannot set
2431          * TEMP, so sv_2mortal is out of question. */
2432         if (!CvLVALUE(cx->blk_sub.cv)) {
2433             LEAVE;
2434             cxstack_ix--;
2435             POPSUB(cx,sv);
2436             PL_curpm = newpm;
2437             LEAVESUB(sv);
2438             DIE(aTHX_ "Can't modify non-lvalue subroutine call");
2439         }
2440         if (gimme == G_SCALAR) {
2441             MARK = newsp + 1;
2442             EXTEND_MORTAL(1);
2443             if (MARK == SP) {
2444                 /* Temporaries are bad unless they happen to be elements
2445                  * of a tied hash or array */
2446                 if (SvFLAGS(TOPs) & (SVs_TEMP | SVs_PADTMP | SVf_READONLY) &&
2447                     !(SvRMAGICAL(TOPs) && mg_find(TOPs, PERL_MAGIC_tiedelem))) {
2448                     LEAVE;
2449                     cxstack_ix--;
2450                     POPSUB(cx,sv);
2451                     PL_curpm = newpm;
2452                     LEAVESUB(sv);
2453                     DIE(aTHX_ "Can't return %s from lvalue subroutine",
2454                         SvREADONLY(TOPs) ? (TOPs == &PL_sv_undef) ? "undef"
2455                         : "a readonly value" : "a temporary");
2456                 }
2457                 else {                  /* Can be a localized value
2458                                          * subject to deletion. */
2459                     PL_tmps_stack[++PL_tmps_ix] = *mark;
2460                     (void)SvREFCNT_inc(*mark);
2461                 }
2462             }
2463             else {                      /* Should not happen? */
2464                 LEAVE;
2465                 cxstack_ix--;
2466                 POPSUB(cx,sv);
2467                 PL_curpm = newpm;
2468                 LEAVESUB(sv);
2469                 DIE(aTHX_ "%s returned from lvalue subroutine in scalar context",
2470                     (MARK > SP ? "Empty array" : "Array"));
2471             }
2472             SP = MARK;
2473         }
2474         else if (gimme == G_ARRAY) {
2475             EXTEND_MORTAL(SP - newsp);
2476             for (mark = newsp + 1; mark <= SP; mark++) {
2477                 if (*mark != &PL_sv_undef
2478                     && SvFLAGS(*mark) & (SVs_TEMP | SVs_PADTMP | SVf_READONLY)) {
2479                     /* Might be flattened array after $#array =  */
2480                     PUTBACK;
2481                     LEAVE;
2482                     cxstack_ix--;
2483                     POPSUB(cx,sv);
2484                     PL_curpm = newpm;
2485                     LEAVESUB(sv);
2486                     DIE(aTHX_ "Can't return a %s from lvalue subroutine",
2487                         SvREADONLY(TOPs) ? "readonly value" : "temporary");
2488                 }
2489                 else {
2490                     /* Can be a localized value subject to deletion. */
2491                     PL_tmps_stack[++PL_tmps_ix] = *mark;
2492                     (void)SvREFCNT_inc(*mark);
2493                 }
2494             }
2495         }
2496     }
2497     else {
2498         if (gimme == G_SCALAR) {
2499           temporise:
2500             MARK = newsp + 1;
2501             if (MARK <= SP) {
2502                 if (cx->blk_sub.cv && CvDEPTH(cx->blk_sub.cv) > 1) {
2503                     if (SvTEMP(TOPs)) {
2504                         *MARK = SvREFCNT_inc(TOPs);
2505                         FREETMPS;
2506                         sv_2mortal(*MARK);
2507                     }
2508                     else {
2509                         sv = SvREFCNT_inc(TOPs); /* FREETMPS could clobber it */
2510                         FREETMPS;
2511                         *MARK = sv_mortalcopy(sv);
2512                         SvREFCNT_dec(sv);
2513                     }
2514                 }
2515                 else
2516                     *MARK = SvTEMP(TOPs) ? TOPs : sv_mortalcopy(TOPs);
2517             }
2518             else {
2519                 MEXTEND(MARK, 0);
2520                 *MARK = &PL_sv_undef;
2521             }
2522             SP = MARK;
2523         }
2524         else if (gimme == G_ARRAY) {
2525           temporise_array:
2526             for (MARK = newsp + 1; MARK <= SP; MARK++) {
2527                 if (!SvTEMP(*MARK)) {
2528                     *MARK = sv_mortalcopy(*MARK);
2529                     TAINT_NOT;  /* Each item is independent */
2530                 }
2531             }
2532         }
2533     }
2534     PUTBACK;
2535
2536     LEAVE;
2537     cxstack_ix--;
2538     POPSUB(cx,sv);      /* Stack values are safe: release CV and @_ ... */
2539     PL_curpm = newpm;   /* ... and pop $1 et al */
2540
2541     LEAVESUB(sv);
2542     return cx->blk_sub.retop;
2543 }
2544
2545
2546 STATIC CV *
2547 S_get_db_sub(pTHX_ SV **svp, CV *cv)
2548 {
2549     SV *dbsv = GvSVn(PL_DBsub);
2550
2551     save_item(dbsv);
2552     if (!PERLDB_SUB_NN) {
2553         GV *gv = CvGV(cv);
2554
2555         if ( (CvFLAGS(cv) & (CVf_ANON | CVf_CLONED))
2556              || strEQ(GvNAME(gv), "END")
2557              || ((GvCV(gv) != cv) && /* Could be imported, and old sub redefined. */
2558                  !( (SvTYPE(*svp) == SVt_PVGV) && (GvCV((GV*)*svp) == cv)
2559                     && (gv = (GV*)*svp) ))) {
2560             /* Use GV from the stack as a fallback. */
2561             /* GV is potentially non-unique, or contain different CV. */
2562             SV *tmp = newRV((SV*)cv);
2563             sv_setsv(dbsv, tmp);
2564             SvREFCNT_dec(tmp);
2565         }
2566         else {
2567             gv_efullname3(dbsv, gv, Nullch);
2568         }
2569     }
2570     else {
2571         const int type = SvTYPE(dbsv);
2572         if (type < SVt_PVIV && type != SVt_IV)
2573             sv_upgrade(dbsv, SVt_PVIV);
2574         (void)SvIOK_on(dbsv);
2575         SvIV_set(dbsv, PTR2IV(cv));     /* Do it the quickest way  */
2576     }
2577
2578     if (CvXSUB(cv))
2579         PL_curcopdb = PL_curcop;
2580     cv = GvCV(PL_DBsub);
2581     return cv;
2582 }
2583
2584 PP(pp_entersub)
2585 {
2586     dVAR; dSP; dPOPss;
2587     GV *gv;
2588     HV *stash;
2589     register CV *cv;
2590     register PERL_CONTEXT *cx;
2591     I32 gimme;
2592     const bool hasargs = (PL_op->op_flags & OPf_STACKED) != 0;
2593
2594     if (!sv)
2595         DIE(aTHX_ "Not a CODE reference");
2596     switch (SvTYPE(sv)) {
2597         /* This is overwhelming the most common case:  */
2598     case SVt_PVGV:
2599         if (!(cv = GvCVu((GV*)sv)))
2600             cv = sv_2cv(sv, &stash, &gv, FALSE);
2601         if (!cv) {
2602             ENTER;
2603             SAVETMPS;
2604             goto try_autoload;
2605         }
2606         break;
2607     default:
2608         if (!SvROK(sv)) {
2609             const char *sym;
2610             if (sv == &PL_sv_yes) {             /* unfound import, ignore */
2611                 if (hasargs)
2612                     SP = PL_stack_base + POPMARK;
2613                 RETURN;
2614             }
2615             if (SvGMAGICAL(sv)) {
2616                 mg_get(sv);
2617                 if (SvROK(sv))
2618                     goto got_rv;
2619                 sym = SvPOKp(sv) ? SvPVX_const(sv) : Nullch;
2620             }
2621             else {
2622                 sym = SvPV_nolen_const(sv);
2623             }
2624             if (!sym)
2625                 DIE(aTHX_ PL_no_usym, "a subroutine");
2626             if (PL_op->op_private & HINT_STRICT_REFS)
2627                 DIE(aTHX_ PL_no_symref, sym, "a subroutine");
2628             cv = get_cv(sym, TRUE);
2629             break;
2630         }
2631   got_rv:
2632         {
2633             SV **sp = &sv;              /* Used in tryAMAGICunDEREF macro. */
2634             tryAMAGICunDEREF(to_cv);
2635         }
2636         cv = (CV*)SvRV(sv);
2637         if (SvTYPE(cv) == SVt_PVCV)
2638             break;
2639         /* FALL THROUGH */
2640     case SVt_PVHV:
2641     case SVt_PVAV:
2642         DIE(aTHX_ "Not a CODE reference");
2643         /* This is the second most common case:  */
2644     case SVt_PVCV:
2645         cv = (CV*)sv;
2646         break;
2647     }
2648
2649     ENTER;
2650     SAVETMPS;
2651
2652   retry:
2653     if (!CvROOT(cv) && !CvXSUB(cv)) {
2654         goto fooey;
2655     }
2656
2657     gimme = GIMME_V;
2658     if ((PL_op->op_private & OPpENTERSUB_DB) && GvCV(PL_DBsub) && !CvNODEBUG(cv)) {
2659         if (CvASSERTION(cv) && PL_DBassertion)
2660             sv_setiv(PL_DBassertion, 1);
2661
2662         cv = get_db_sub(&sv, cv);
2663         if (!cv || (!CvXSUB(cv) && !CvSTART(cv)))
2664             DIE(aTHX_ "No DB::sub routine defined");
2665     }
2666
2667     if (!(CvXSUB(cv))) {
2668         /* This path taken at least 75% of the time   */
2669         dMARK;
2670         register I32 items = SP - MARK;
2671         AV* padlist = CvPADLIST(cv);
2672         PUSHBLOCK(cx, CXt_SUB, MARK);
2673         PUSHSUB(cx);
2674         cx->blk_sub.retop = PL_op->op_next;
2675         CvDEPTH(cv)++;
2676         /* XXX This would be a natural place to set C<PL_compcv = cv> so
2677          * that eval'' ops within this sub know the correct lexical space.
2678          * Owing the speed considerations, we choose instead to search for
2679          * the cv using find_runcv() when calling doeval().
2680          */
2681         if (CvDEPTH(cv) >= 2) {
2682             PERL_STACK_OVERFLOW_CHECK();
2683             pad_push(padlist, CvDEPTH(cv));
2684         }
2685         SAVECOMPPAD();
2686         PAD_SET_CUR_NOSAVE(padlist, CvDEPTH(cv));
2687         if (hasargs)
2688         {
2689             AV* av;
2690 #if 0
2691             DEBUG_S(PerlIO_printf(Perl_debug_log,
2692                                   "%p entersub preparing @_\n", thr));
2693 #endif
2694             av = (AV*)PAD_SVl(0);
2695             if (AvREAL(av)) {
2696                 /* @_ is normally not REAL--this should only ever
2697                  * happen when DB::sub() calls things that modify @_ */
2698                 av_clear(av);
2699                 AvREAL_off(av);
2700                 AvREIFY_on(av);
2701             }
2702             cx->blk_sub.savearray = GvAV(PL_defgv);
2703             GvAV(PL_defgv) = (AV*)SvREFCNT_inc(av);
2704             CX_CURPAD_SAVE(cx->blk_sub);
2705             cx->blk_sub.argarray = av;
2706             ++MARK;
2707
2708             if (items > AvMAX(av) + 1) {
2709                 SV **ary = AvALLOC(av);
2710                 if (AvARRAY(av) != ary) {
2711                     AvMAX(av) += AvARRAY(av) - AvALLOC(av);
2712                     SvPV_set(av, (char*)ary);
2713                 }
2714                 if (items > AvMAX(av) + 1) {
2715                     AvMAX(av) = items - 1;
2716                     Renew(ary,items,SV*);
2717                     AvALLOC(av) = ary;
2718                     SvPV_set(av, (char*)ary);
2719                 }
2720             }
2721             Copy(MARK,AvARRAY(av),items,SV*);
2722             AvFILLp(av) = items - 1;
2723
2724             while (items--) {
2725                 if (*MARK)
2726                     SvTEMP_off(*MARK);
2727                 MARK++;
2728             }
2729         }
2730         /* warning must come *after* we fully set up the context
2731          * stuff so that __WARN__ handlers can safely dounwind()
2732          * if they want to
2733          */
2734         if (CvDEPTH(cv) == 100 && ckWARN(WARN_RECURSION)
2735             && !(PERLDB_SUB && cv == GvCV(PL_DBsub)))
2736             sub_crush_depth(cv);
2737 #if 0
2738         DEBUG_S(PerlIO_printf(Perl_debug_log,
2739                               "%p entersub returning %p\n", thr, CvSTART(cv)));
2740 #endif
2741         RETURNOP(CvSTART(cv));
2742     }
2743     else {
2744 #ifdef PERL_XSUB_OLDSTYLE
2745         if (CvOLDSTYLE(cv)) {
2746             I32 (*fp3)(int,int,int);
2747             dMARK;
2748             register I32 items = SP - MARK;
2749                                         /* We dont worry to copy from @_. */
2750             while (SP > mark) {
2751                 SP[1] = SP[0];
2752                 SP--;
2753             }
2754             PL_stack_sp = mark + 1;
2755             fp3 = (I32(*)(int,int,int))CvXSUB(cv);
2756             items = (*fp3)(CvXSUBANY(cv).any_i32,
2757                            MARK - PL_stack_base + 1,
2758                            items);
2759             PL_stack_sp = PL_stack_base + items;
2760         }
2761         else
2762 #endif /* PERL_XSUB_OLDSTYLE */
2763         {
2764             I32 markix = TOPMARK;
2765
2766             PUTBACK;
2767
2768             if (!hasargs) {
2769                 /* Need to copy @_ to stack. Alternative may be to
2770                  * switch stack to @_, and copy return values
2771                  * back. This would allow popping @_ in XSUB, e.g.. XXXX */
2772                 AV * const av = GvAV(PL_defgv);
2773                 const I32 items = AvFILLp(av) + 1;   /* @_ is not tieable */
2774
2775                 if (items) {
2776                     /* Mark is at the end of the stack. */
2777                     EXTEND(SP, items);
2778                     Copy(AvARRAY(av), SP + 1, items, SV*);
2779                     SP += items;
2780                     PUTBACK ;
2781                 }
2782             }
2783             /* We assume first XSUB in &DB::sub is the called one. */
2784             if (PL_curcopdb) {
2785                 SAVEVPTR(PL_curcop);
2786                 PL_curcop = PL_curcopdb;
2787                 PL_curcopdb = NULL;
2788             }
2789             /* Do we need to open block here? XXXX */
2790             (void)(*CvXSUB(cv))(aTHX_ cv);
2791
2792             /* Enforce some sanity in scalar context. */
2793             if (gimme == G_SCALAR && ++markix != PL_stack_sp - PL_stack_base ) {
2794                 if (markix > PL_stack_sp - PL_stack_base)
2795                     *(PL_stack_base + markix) = &PL_sv_undef;
2796                 else
2797                     *(PL_stack_base + markix) = *PL_stack_sp;
2798                 PL_stack_sp = PL_stack_base + markix;
2799             }
2800         }
2801         LEAVE;
2802         return NORMAL;
2803     }
2804
2805     /*NOTREACHED*/
2806     assert (0); /* Cannot get here.  */
2807     /* This is deliberately moved here as spaghetti code to keep it out of the
2808        hot path.  */
2809     {
2810         GV* autogv;
2811         SV* sub_name;
2812
2813       fooey:
2814         /* anonymous or undef'd function leaves us no recourse */
2815         if (CvANON(cv) || !(gv = CvGV(cv)))
2816             DIE(aTHX_ "Undefined subroutine called");
2817
2818         /* autoloaded stub? */
2819         if (cv != GvCV(gv)) {
2820             cv = GvCV(gv);
2821         }
2822         /* should call AUTOLOAD now? */
2823         else {
2824 try_autoload:
2825             if ((autogv = gv_autoload4(GvSTASH(gv), GvNAME(gv), GvNAMELEN(gv),
2826                                    FALSE)))
2827             {
2828                 cv = GvCV(autogv);
2829             }
2830             /* sorry */
2831             else {
2832                 sub_name = sv_newmortal();
2833                 gv_efullname3(sub_name, gv, Nullch);
2834                 DIE(aTHX_ "Undefined subroutine &%"SVf" called", sub_name);
2835             }
2836         }
2837         if (!cv)
2838             DIE(aTHX_ "Not a CODE reference");
2839         goto retry;
2840     }
2841 }
2842
2843 void
2844 Perl_sub_crush_depth(pTHX_ CV *cv)
2845 {
2846     if (CvANON(cv))
2847         Perl_warner(aTHX_ packWARN(WARN_RECURSION), "Deep recursion on anonymous subroutine");
2848     else {
2849         SV* const tmpstr = sv_newmortal();
2850         gv_efullname3(tmpstr, CvGV(cv), Nullch);
2851         Perl_warner(aTHX_ packWARN(WARN_RECURSION), "Deep recursion on subroutine \"%"SVf"\"",
2852                 tmpstr);
2853     }
2854 }
2855
2856 PP(pp_aelem)
2857 {
2858     dSP;
2859     SV** svp;
2860     SV* const elemsv = POPs;
2861     IV elem = SvIV(elemsv);
2862     AV* av = (AV*)POPs;
2863     const U32 lval = PL_op->op_flags & OPf_MOD || LVRET;
2864     const U32 defer = (PL_op->op_private & OPpLVAL_DEFER) && (elem > av_len(av));
2865     SV *sv;
2866
2867     if (SvROK(elemsv) && !SvGAMAGIC(elemsv) && ckWARN(WARN_MISC))
2868         Perl_warner(aTHX_ packWARN(WARN_MISC), "Use of reference \"%"SVf"\" as array index", elemsv);
2869     if (elem > 0)
2870         elem -= PL_curcop->cop_arybase;
2871     if (SvTYPE(av) != SVt_PVAV)
2872         RETPUSHUNDEF;
2873     svp = av_fetch(av, elem, lval && !defer);
2874     if (lval) {
2875 #ifdef PERL_MALLOC_WRAP
2876          if (SvUOK(elemsv)) {
2877               const UV uv = SvUV(elemsv);
2878               elem = uv > IV_MAX ? IV_MAX : uv;
2879          }
2880          else if (SvNOK(elemsv))
2881               elem = (IV)SvNV(elemsv);
2882          if (elem > 0) {
2883               static const char oom_array_extend[] =
2884                 "Out of memory during array extend"; /* Duplicated in av.c */
2885               MEM_WRAP_CHECK_1(elem,SV*,oom_array_extend);
2886          }
2887 #endif
2888         if (!svp || *svp == &PL_sv_undef) {
2889             SV* lv;
2890             if (!defer)
2891                 DIE(aTHX_ PL_no_aelem, elem);
2892             lv = sv_newmortal();
2893             sv_upgrade(lv, SVt_PVLV);
2894             LvTYPE(lv) = 'y';
2895             sv_magic(lv, Nullsv, PERL_MAGIC_defelem, Nullch, 0);
2896             LvTARG(lv) = SvREFCNT_inc(av);
2897             LvTARGOFF(lv) = elem;
2898             LvTARGLEN(lv) = 1;
2899             PUSHs(lv);
2900             RETURN;
2901         }
2902         if (PL_op->op_private & OPpLVAL_INTRO)
2903             save_aelem(av, elem, svp);
2904         else if (PL_op->op_private & OPpDEREF)
2905             vivify_ref(*svp, PL_op->op_private & OPpDEREF);
2906     }
2907     sv = (svp ? *svp : &PL_sv_undef);
2908     if (!lval && SvGMAGICAL(sv))        /* see note in pp_helem() */
2909         sv = sv_mortalcopy(sv);
2910     PUSHs(sv);
2911     RETURN;
2912 }
2913
2914 void
2915 Perl_vivify_ref(pTHX_ SV *sv, U32 to_what)
2916 {
2917     if (SvGMAGICAL(sv))
2918         mg_get(sv);
2919     if (!SvOK(sv)) {
2920         if (SvREADONLY(sv))
2921             Perl_croak(aTHX_ PL_no_modify);
2922         if (SvTYPE(sv) < SVt_RV)
2923             sv_upgrade(sv, SVt_RV);
2924         else if (SvTYPE(sv) >= SVt_PV) {
2925             SvPV_free(sv);
2926             SvLEN_set(sv, 0);
2927             SvCUR_set(sv, 0);
2928         }
2929         switch (to_what) {
2930         case OPpDEREF_SV:
2931             SvRV_set(sv, NEWSV(355,0));
2932             break;
2933         case OPpDEREF_AV:
2934             SvRV_set(sv, (SV*)newAV());
2935             break;
2936         case OPpDEREF_HV:
2937             SvRV_set(sv, (SV*)newHV());
2938             break;
2939         }
2940         SvROK_on(sv);
2941         SvSETMAGIC(sv);
2942     }
2943 }
2944
2945 PP(pp_method)
2946 {
2947     dSP;
2948     SV* const sv = TOPs;
2949
2950     if (SvROK(sv)) {
2951         SV* const rsv = SvRV(sv);
2952         if (SvTYPE(rsv) == SVt_PVCV) {
2953             SETs(rsv);
2954             RETURN;
2955         }
2956     }
2957
2958     SETs(method_common(sv, Null(U32*)));
2959     RETURN;
2960 }
2961
2962 PP(pp_method_named)
2963 {
2964     dSP;
2965     SV* const sv = cSVOP_sv;
2966     U32 hash = SvSHARED_HASH(sv);
2967
2968     XPUSHs(method_common(sv, &hash));
2969     RETURN;
2970 }
2971
2972 STATIC SV *
2973 S_method_common(pTHX_ SV* meth, U32* hashp)
2974 {
2975     SV* ob;
2976     GV* gv;
2977     HV* stash;
2978     STRLEN namelen;
2979     const char* packname = Nullch;
2980     SV *packsv = Nullsv;
2981     STRLEN packlen;
2982     const char * const name = SvPV_const(meth, namelen);
2983     SV * const sv = *(PL_stack_base + TOPMARK + 1);
2984
2985     if (!sv)
2986         Perl_croak(aTHX_ "Can't call method \"%s\" on an undefined value", name);
2987
2988     if (SvGMAGICAL(sv))
2989         mg_get(sv);
2990     if (SvROK(sv))
2991         ob = (SV*)SvRV(sv);
2992     else {
2993         GV* iogv;
2994
2995         /* this isn't a reference */
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 * const 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  */