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