pp_hot.c

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