pp_hot.c

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