pp_hot.c

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