pp_hot.c

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