pp_hot.c

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