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