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