pp_hot.c

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