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