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