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