pp_hot.c

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