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             if (SvCUR(sv) < 60)
1636                 SvLEN_set(sv, 80);
1637             else
1638                 SvLEN_set(sv, SvCUR(sv)+40);    /* allow some slop */
1639             Renew(SvPVX(sv), SvLEN(sv), char);
1640         }
1641         RETURN;
1642     }
1643 }
1644
1645 PP(pp_enter)
1646 {
1647     dSP;
1648     register PERL_CONTEXT *cx;
1649     I32 gimme = OP_GIMME(PL_op, -1);
1650
1651     if (gimme == -1) {
1652         if (cxstack_ix >= 0)
1653             gimme = cxstack[cxstack_ix].blk_gimme;
1654         else
1655             gimme = G_SCALAR;
1656     }
1657
1658     ENTER;
1659
1660     SAVETMPS;
1661     PUSHBLOCK(cx, CXt_BLOCK, SP);
1662
1663     RETURN;
1664 }
1665
1666 PP(pp_helem)
1667 {
1668     dSP;
1669     HE* he;
1670     SV **svp;
1671     SV *keysv = POPs;
1672     HV *hv = (HV*)POPs;
1673     U32 lval = PL_op->op_flags & OPf_MOD || LVRET;
1674     U32 defer = PL_op->op_private & OPpLVAL_DEFER;
1675     SV *sv;
1676 #ifdef PERL_COPY_ON_WRITE
1677     U32 hash = (SvIsCOW_shared_hash(keysv)) ? SvUVX(keysv) : 0;
1678 #else
1679     U32 hash = (SvFAKE(keysv) && SvREADONLY(keysv)) ? SvUVX(keysv) : 0;
1680 #endif
1681     I32 preeminent = 0;
1682
1683     if (SvTYPE(hv) == SVt_PVHV) {
1684         if (PL_op->op_private & OPpLVAL_INTRO) {
1685             MAGIC *mg;
1686             HV *stash;
1687             /* does the element we're localizing already exist? */
1688             preeminent =
1689                 /* can we determine whether it exists? */
1690                 (    !SvRMAGICAL(hv)
1691                   || mg_find((SV*)hv, PERL_MAGIC_env)
1692                   || (     (mg = mg_find((SV*)hv, PERL_MAGIC_tied))
1693                         /* Try to preserve the existenceness of a tied hash
1694                          * element by using EXISTS and DELETE if possible.
1695                          * Fallback to FETCH and STORE otherwise */
1696                         && (stash = SvSTASH(SvRV(SvTIED_obj((SV*)hv, mg))))
1697                         && gv_fetchmethod_autoload(stash, "EXISTS", TRUE)
1698                         && gv_fetchmethod_autoload(stash, "DELETE", TRUE)
1699                     )
1700                 ) ? hv_exists_ent(hv, keysv, 0) : 1;
1701
1702         }
1703         he = hv_fetch_ent(hv, keysv, lval && !defer, hash);
1704         svp = he ? &HeVAL(he) : 0;
1705     }
1706     else {
1707         RETPUSHUNDEF;
1708     }
1709     if (lval) {
1710         if (!svp || *svp == &PL_sv_undef) {
1711             SV* lv;
1712             SV* key2;
1713             if (!defer) {
1714                 STRLEN n_a;
1715                 DIE(aTHX_ PL_no_helem, SvPV(keysv, n_a));
1716             }
1717             lv = sv_newmortal();
1718             sv_upgrade(lv, SVt_PVLV);
1719             LvTYPE(lv) = 'y';
1720             sv_magic(lv, key2 = newSVsv(keysv), PERL_MAGIC_defelem, Nullch, 0);
1721             SvREFCNT_dec(key2); /* sv_magic() increments refcount */
1722             LvTARG(lv) = SvREFCNT_inc(hv);
1723             LvTARGLEN(lv) = 1;
1724             PUSHs(lv);
1725             RETURN;
1726         }
1727         if (PL_op->op_private & OPpLVAL_INTRO) {
1728             if (HvNAME(hv) && isGV(*svp))
1729                 save_gp((GV*)*svp, !(PL_op->op_flags & OPf_SPECIAL));
1730             else {
1731                 if (!preeminent) {
1732                     STRLEN keylen;
1733                     char *key = SvPV(keysv, keylen);
1734                     SAVEDELETE(hv, savepvn(key,keylen), keylen);
1735                 } else
1736                     save_helem(hv, keysv, svp);
1737             }
1738         }
1739         else if (PL_op->op_private & OPpDEREF)
1740             vivify_ref(*svp, PL_op->op_private & OPpDEREF);
1741     }
1742     sv = (svp ? *svp : &PL_sv_undef);
1743     /* This makes C<local $tied{foo} = $tied{foo}> possible.
1744      * Pushing the magical RHS on to the stack is useless, since
1745      * that magic is soon destined to be misled by the local(),
1746      * and thus the later pp_sassign() will fail to mg_get() the
1747      * old value.  This should also cure problems with delayed
1748      * mg_get()s.  GSAR 98-07-03 */
1749     if (!lval && SvGMAGICAL(sv))
1750         sv = sv_mortalcopy(sv);
1751     PUSHs(sv);
1752     RETURN;
1753 }
1754
1755 PP(pp_leave)
1756 {
1757     dSP;
1758     register PERL_CONTEXT *cx;
1759     register SV **mark;
1760     SV **newsp;
1761     PMOP *newpm;
1762     I32 gimme;
1763
1764     if (PL_op->op_flags & OPf_SPECIAL) {
1765         cx = &cxstack[cxstack_ix];
1766         cx->blk_oldpm = PL_curpm;       /* fake block should preserve $1 et al */
1767     }
1768
1769     POPBLOCK(cx,newpm);
1770
1771     gimme = OP_GIMME(PL_op, -1);
1772     if (gimme == -1) {
1773         if (cxstack_ix >= 0)
1774             gimme = cxstack[cxstack_ix].blk_gimme;
1775         else
1776             gimme = G_SCALAR;
1777     }
1778
1779     TAINT_NOT;
1780     if (gimme == G_VOID)
1781         SP = newsp;
1782     else if (gimme == G_SCALAR) {
1783         MARK = newsp + 1;
1784         if (MARK <= SP) {
1785             if (SvFLAGS(TOPs) & (SVs_PADTMP|SVs_TEMP))
1786                 *MARK = TOPs;
1787             else
1788                 *MARK = sv_mortalcopy(TOPs);
1789         } else {
1790             MEXTEND(mark,0);
1791             *MARK = &PL_sv_undef;
1792         }
1793         SP = MARK;
1794     }
1795     else if (gimme == G_ARRAY) {
1796         /* in case LEAVE wipes old return values */
1797         for (mark = newsp + 1; mark <= SP; mark++) {
1798             if (!(SvFLAGS(*mark) & (SVs_PADTMP|SVs_TEMP))) {
1799                 *mark = sv_mortalcopy(*mark);
1800                 TAINT_NOT;      /* Each item is independent */
1801             }
1802         }
1803     }
1804     PL_curpm = newpm;   /* Don't pop $1 et al till now */
1805
1806     LEAVE;
1807
1808     RETURN;
1809 }
1810
1811 PP(pp_iter)
1812 {
1813     dSP;
1814     register PERL_CONTEXT *cx;
1815     SV *sv, *oldsv;
1816     AV* av;
1817     SV **itersvp;
1818
1819     EXTEND(SP, 1);
1820     cx = &cxstack[cxstack_ix];
1821     if (CxTYPE(cx) != CXt_LOOP)
1822         DIE(aTHX_ "panic: pp_iter");
1823
1824     itersvp = CxITERVAR(cx);
1825     av = cx->blk_loop.iterary;
1826     if (SvTYPE(av) != SVt_PVAV) {
1827         /* iterate ($min .. $max) */
1828         if (cx->blk_loop.iterlval) {
1829             /* string increment */
1830             register SV* cur = cx->blk_loop.iterlval;
1831             STRLEN maxlen = 0;
1832             const char *max = SvOK((SV*)av) ? SvPV((SV*)av, maxlen) : "";
1833             if (!SvNIOK(cur) && SvCUR(cur) <= maxlen) {
1834                 if (SvREFCNT(*itersvp) == 1 && !SvMAGICAL(*itersvp)) {
1835                     /* safe to reuse old SV */
1836                     sv_setsv(*itersvp, cur);
1837                 }
1838                 else
1839                 {
1840                     /* we need a fresh SV every time so that loop body sees a
1841                      * completely new SV for closures/references to work as
1842                      * they used to */
1843                     oldsv = *itersvp;
1844                     *itersvp = newSVsv(cur);
1845                     SvREFCNT_dec(oldsv);
1846                 }
1847                 if (strEQ(SvPVX(cur), max))
1848                     sv_setiv(cur, 0); /* terminate next time */
1849                 else
1850                     sv_inc(cur);
1851                 RETPUSHYES;
1852             }
1853             RETPUSHNO;
1854         }
1855         /* integer increment */
1856         if (cx->blk_loop.iterix > cx->blk_loop.itermax)
1857             RETPUSHNO;
1858
1859         /* don't risk potential race */
1860         if (SvREFCNT(*itersvp) == 1 && !SvMAGICAL(*itersvp)) {
1861             /* safe to reuse old SV */
1862             sv_setiv(*itersvp, cx->blk_loop.iterix++);
1863         }
1864         else
1865         {
1866             /* we need a fresh SV every time so that loop body sees a
1867              * completely new SV for closures/references to work as they
1868              * used to */
1869             oldsv = *itersvp;
1870             *itersvp = newSViv(cx->blk_loop.iterix++);
1871             SvREFCNT_dec(oldsv);
1872         }
1873         RETPUSHYES;
1874     }
1875
1876     /* iterate array */
1877     if (PL_op->op_private & OPpITER_REVERSED) {
1878         /* In reverse, use itermax as the min :-)  */
1879         if (cx->blk_loop.iterix <= cx->blk_loop.itermax)
1880             RETPUSHNO;
1881
1882         if (SvMAGICAL(av) || AvREIFY(av)) {
1883             SV **svp = av_fetch(av, cx->blk_loop.iterix--, FALSE);
1884             if (svp)
1885                 sv = *svp;
1886             else
1887                 sv = Nullsv;
1888         }
1889         else {
1890             sv = AvARRAY(av)[cx->blk_loop.iterix--];
1891         }
1892     }
1893     else {
1894         if (cx->blk_loop.iterix >= (av == PL_curstack ? cx->blk_oldsp :
1895                                     AvFILL(av)))
1896             RETPUSHNO;
1897
1898         if (SvMAGICAL(av) || AvREIFY(av)) {
1899             SV **svp = av_fetch(av, ++cx->blk_loop.iterix, FALSE);
1900             if (svp)
1901                 sv = *svp;
1902             else
1903                 sv = Nullsv;
1904         }
1905         else {
1906             sv = AvARRAY(av)[++cx->blk_loop.iterix];
1907         }
1908     }
1909
1910     if (sv && SvREFCNT(sv) == 0) {
1911         *itersvp = Nullsv;
1912         Perl_croak(aTHX_ "Use of freed value in iteration");
1913     }
1914
1915     if (sv)
1916         SvTEMP_off(sv);
1917     else
1918         sv = &PL_sv_undef;
1919     if (av != PL_curstack && sv == &PL_sv_undef) {
1920         SV *lv = cx->blk_loop.iterlval;
1921         if (lv && SvREFCNT(lv) > 1) {
1922             SvREFCNT_dec(lv);
1923             lv = Nullsv;
1924         }
1925         if (lv)
1926             SvREFCNT_dec(LvTARG(lv));
1927         else {
1928             lv = cx->blk_loop.iterlval = NEWSV(26, 0);
1929             sv_upgrade(lv, SVt_PVLV);
1930             LvTYPE(lv) = 'y';
1931             sv_magic(lv, Nullsv, PERL_MAGIC_defelem, Nullch, 0);
1932         }
1933         LvTARG(lv) = SvREFCNT_inc(av);
1934         LvTARGOFF(lv) = cx->blk_loop.iterix;
1935         LvTARGLEN(lv) = (STRLEN)UV_MAX;
1936         sv = (SV*)lv;
1937     }
1938
1939     oldsv = *itersvp;
1940     *itersvp = SvREFCNT_inc(sv);
1941     SvREFCNT_dec(oldsv);
1942
1943     RETPUSHYES;
1944 }
1945
1946 PP(pp_subst)
1947 {
1948     dSP; dTARG;
1949     register PMOP *pm = cPMOP;
1950     PMOP *rpm = pm;
1951     register SV *dstr;
1952     register char *s;
1953     char *strend;
1954     register char *m;
1955     char *c;
1956     register char *d;
1957     STRLEN clen;
1958     I32 iters = 0;
1959     I32 maxiters;
1960     register I32 i;
1961     bool once;
1962     bool rxtainted;
1963     char *orig;
1964     I32 r_flags;
1965     register REGEXP *rx = PM_GETRE(pm);
1966     STRLEN len;
1967     int force_on_match = 0;
1968     I32 oldsave = PL_savestack_ix;
1969     STRLEN slen;
1970     bool doutf8 = FALSE;
1971 #ifdef PERL_COPY_ON_WRITE
1972     bool is_cow;
1973 #endif
1974     SV *nsv = Nullsv;
1975
1976     /* known replacement string? */
1977     dstr = (pm->op_pmflags & PMf_CONST) ? POPs : Nullsv;
1978     if (PL_op->op_flags & OPf_STACKED)
1979         TARG = POPs;
1980     else if (PL_op->op_private & OPpTARGET_MY)
1981         GETTARGET;
1982     else {
1983         TARG = DEFSV;
1984         EXTEND(SP,1);
1985     }
1986
1987 #ifdef PERL_COPY_ON_WRITE
1988     /* Awooga. Awooga. "bool" types that are actually char are dangerous,
1989        because they make integers such as 256 "false".  */
1990     is_cow = SvIsCOW(TARG) ? TRUE : FALSE;
1991 #else
1992     if (SvIsCOW(TARG))
1993         sv_force_normal_flags(TARG,0);
1994 #endif
1995     if (
1996 #ifdef PERL_COPY_ON_WRITE
1997         !is_cow &&
1998 #endif
1999         (SvREADONLY(TARG)
2000         || ( (SvTYPE(TARG) == SVt_PVGV || SvTYPE(TARG) > SVt_PVLV)
2001              && !(SvTYPE(TARG) == SVt_PVGV && SvFAKE(TARG)))))
2002         DIE(aTHX_ PL_no_modify);
2003     PUTBACK;
2004
2005     s = SvPV(TARG, len);
2006     if (!SvPOKp(TARG) || SvTYPE(TARG) == SVt_PVGV)
2007         force_on_match = 1;
2008     rxtainted = ((pm->op_pmdynflags & PMdf_TAINTED) ||
2009                  (PL_tainted && (pm->op_pmflags & PMf_RETAINT)));
2010     if (PL_tainted)
2011         rxtainted |= 2;
2012     TAINT_NOT;
2013
2014     RX_MATCH_UTF8_set(rx, DO_UTF8(TARG));
2015
2016   force_it:
2017     if (!pm || !s)
2018         DIE(aTHX_ "panic: pp_subst");
2019
2020     strend = s + len;
2021     slen = RX_MATCH_UTF8(rx) ? utf8_length((U8*)s, (U8*)strend) : len;
2022     maxiters = 2 * slen + 10;   /* We can match twice at each
2023                                    position, once with zero-length,
2024                                    second time with non-zero. */
2025
2026     if (!rx->prelen && PL_curpm) {
2027         pm = PL_curpm;
2028         rx = PM_GETRE(pm);
2029     }
2030     r_flags = (rx->nparens || SvTEMP(TARG) || PL_sawampersand)
2031                ? REXEC_COPY_STR : 0;
2032     if (SvSCREAM(TARG))
2033         r_flags |= REXEC_SCREAM;
2034
2035     orig = m = s;
2036     if (rx->reganch & RE_USE_INTUIT) {
2037         PL_bostr = orig;
2038         s = CALLREG_INTUIT_START(aTHX_ rx, TARG, s, strend, r_flags, NULL);
2039
2040         if (!s)
2041             goto nope;
2042         /* How to do it in subst? */
2043 /*      if ( (rx->reganch & ROPT_CHECK_ALL)
2044              && !PL_sawampersand
2045              && ((rx->reganch & ROPT_NOSCAN)
2046                  || !((rx->reganch & RE_INTUIT_TAIL)
2047                       && (r_flags & REXEC_SCREAM))))
2048             goto yup;
2049 */
2050     }
2051
2052     /* only replace once? */
2053     once = !(rpm->op_pmflags & PMf_GLOBAL);
2054
2055     /* known replacement string? */
2056     if (dstr) {
2057         /* replacement needing upgrading? */
2058         if (DO_UTF8(TARG) && !doutf8) {
2059              nsv = sv_newmortal();
2060              SvSetSV(nsv, dstr);
2061              if (PL_encoding)
2062                   sv_recode_to_utf8(nsv, PL_encoding);
2063              else
2064                   sv_utf8_upgrade(nsv);
2065              c = SvPV(nsv, clen);
2066              doutf8 = TRUE;
2067         }
2068         else {
2069             c = SvPV(dstr, clen);
2070             doutf8 = DO_UTF8(dstr);
2071         }
2072     }
2073     else {
2074         c = Nullch;
2075         doutf8 = FALSE;
2076     }
2077
2078     /* can do inplace substitution? */
2079     if (c
2080 #ifdef PERL_COPY_ON_WRITE
2081         && !is_cow
2082 #endif
2083         && (I32)clen <= rx->minlen && (once || !(r_flags & REXEC_COPY_STR))
2084         && !(rx->reganch & ROPT_LOOKBEHIND_SEEN)
2085         && (!doutf8 || SvUTF8(TARG))) {
2086         if (!CALLREGEXEC(aTHX_ rx, s, strend, orig, 0, TARG, NULL,
2087                          r_flags | REXEC_CHECKED))
2088         {
2089             SPAGAIN;
2090             PUSHs(&PL_sv_no);
2091             LEAVE_SCOPE(oldsave);
2092             RETURN;
2093         }
2094 #ifdef PERL_COPY_ON_WRITE
2095         if (SvIsCOW(TARG)) {
2096             assert (!force_on_match);
2097             goto have_a_cow;
2098         }
2099 #endif
2100         if (force_on_match) {
2101             force_on_match = 0;
2102             s = SvPV_force(TARG, len);
2103             goto force_it;
2104         }
2105         d = s;
2106         PL_curpm = pm;
2107         SvSCREAM_off(TARG);     /* disable possible screamer */
2108         if (once) {
2109             rxtainted |= RX_MATCH_TAINTED(rx);
2110             m = orig + rx->startp[0];
2111             d = orig + rx->endp[0];
2112             s = orig;
2113             if (m - s > strend - d) {  /* faster to shorten from end */
2114                 if (clen) {
2115                     Copy(c, m, clen, char);
2116                     m += clen;
2117                 }
2118                 i = strend - d;
2119                 if (i > 0) {
2120                     Move(d, m, i, char);
2121                     m += i;
2122                 }
2123                 *m = '\0';
2124                 SvCUR_set(TARG, m - s);
2125             }
2126             /*SUPPRESS 560*/
2127             else if ((i = m - s)) {     /* faster from front */
2128                 d -= clen;
2129                 m = d;
2130                 sv_chop(TARG, d-i);
2131                 s += i;
2132                 while (i--)
2133                     *--d = *--s;
2134                 if (clen)
2135                     Copy(c, m, clen, char);
2136             }
2137             else if (clen) {
2138                 d -= clen;
2139                 sv_chop(TARG, d);
2140                 Copy(c, d, clen, char);
2141             }
2142             else {
2143                 sv_chop(TARG, d);
2144             }
2145             TAINT_IF(rxtainted & 1);
2146             SPAGAIN;
2147             PUSHs(&PL_sv_yes);
2148         }
2149         else {
2150             do {
2151                 if (iters++ > maxiters)
2152                     DIE(aTHX_ "Substitution loop");
2153                 rxtainted |= RX_MATCH_TAINTED(rx);
2154                 m = rx->startp[0] + orig;
2155                 /*SUPPRESS 560*/
2156                 if ((i = m - s)) {
2157                     if (s != d)
2158                         Move(s, d, i, char);
2159                     d += i;
2160                 }
2161                 if (clen) {
2162                     Copy(c, d, clen, char);
2163                     d += clen;
2164                 }
2165                 s = rx->endp[0] + orig;
2166             } while (CALLREGEXEC(aTHX_ rx, s, strend, orig, s == m,
2167                                  TARG, NULL,
2168                                  /* don't match same null twice */
2169                                  REXEC_NOT_FIRST|REXEC_IGNOREPOS));
2170             if (s != d) {
2171                 i = strend - s;
2172                 SvCUR_set(TARG, d - SvPVX(TARG) + i);
2173                 Move(s, d, i+1, char);          /* include the NUL */
2174             }
2175             TAINT_IF(rxtainted & 1);
2176             SPAGAIN;
2177             PUSHs(sv_2mortal(newSViv((I32)iters)));
2178         }
2179         (void)SvPOK_only_UTF8(TARG);
2180         TAINT_IF(rxtainted);
2181         if (SvSMAGICAL(TARG)) {
2182             PUTBACK;
2183             mg_set(TARG);
2184             SPAGAIN;
2185         }
2186         SvTAINT(TARG);
2187         if (doutf8)
2188             SvUTF8_on(TARG);
2189         LEAVE_SCOPE(oldsave);
2190         RETURN;
2191     }
2192
2193     if (CALLREGEXEC(aTHX_ rx, s, strend, orig, 0, TARG, NULL,
2194                     r_flags | REXEC_CHECKED))
2195     {
2196         if (force_on_match) {
2197             force_on_match = 0;
2198             s = SvPV_force(TARG, len);
2199             goto force_it;
2200         }
2201 #ifdef PERL_COPY_ON_WRITE
2202       have_a_cow:
2203 #endif
2204         rxtainted |= RX_MATCH_TAINTED(rx);
2205         dstr = newSVpvn(m, s-m);
2206         if (DO_UTF8(TARG))
2207             SvUTF8_on(dstr);
2208         PL_curpm = pm;
2209         if (!c) {
2210             register PERL_CONTEXT *cx;
2211             SPAGAIN;
2212             ReREFCNT_inc(rx);
2213             PUSHSUBST(cx);
2214             RETURNOP(cPMOP->op_pmreplroot);
2215         }
2216         r_flags |= REXEC_IGNOREPOS | REXEC_NOT_FIRST;
2217         do {
2218             if (iters++ > maxiters)
2219                 DIE(aTHX_ "Substitution loop");
2220             rxtainted |= RX_MATCH_TAINTED(rx);
2221             if (RX_MATCH_COPIED(rx) && rx->subbeg != orig) {
2222                 m = s;
2223                 s = orig;
2224                 orig = rx->subbeg;
2225                 s = orig + (m - s);
2226                 strend = s + (strend - m);
2227             }
2228             m = rx->startp[0] + orig;
2229             if (doutf8 && !SvUTF8(dstr))
2230                 sv_catpvn_utf8_upgrade(dstr, s, m - s, nsv);
2231             else
2232                 sv_catpvn(dstr, s, m-s);
2233             s = rx->endp[0] + orig;
2234             if (clen)
2235                 sv_catpvn(dstr, c, clen);
2236             if (once)
2237                 break;
2238         } while (CALLREGEXEC(aTHX_ rx, s, strend, orig, s == m,
2239                              TARG, NULL, r_flags));
2240         if (doutf8 && !DO_UTF8(TARG))
2241             sv_catpvn_utf8_upgrade(dstr, s, strend - s, nsv);
2242         else
2243             sv_catpvn(dstr, s, strend - s);
2244
2245 #ifdef PERL_COPY_ON_WRITE
2246         /* The match may make the string COW. If so, brilliant, because that's
2247            just saved us one malloc, copy and free - the regexp has donated
2248            the old buffer, and we malloc an entirely new one, rather than the
2249            regexp malloc()ing a buffer and copying our original, only for
2250            us to throw it away here during the substitution.  */
2251         if (SvIsCOW(TARG)) {
2252             sv_force_normal_flags(TARG, SV_COW_DROP_PV);
2253         } else
2254 #endif
2255         {
2256             SvOOK_off(TARG);
2257             if (SvLEN(TARG))
2258                 Safefree(SvPVX(TARG));
2259         }
2260         SvPV_set(TARG, SvPVX(dstr));
2261         SvCUR_set(TARG, SvCUR(dstr));
2262         SvLEN_set(TARG, SvLEN(dstr));
2263         doutf8 |= DO_UTF8(dstr);
2264         SvPV_set(dstr, (char*)0);
2265         sv_free(dstr);
2266
2267         TAINT_IF(rxtainted & 1);
2268         SPAGAIN;
2269         PUSHs(sv_2mortal(newSViv((I32)iters)));
2270
2271         (void)SvPOK_only(TARG);
2272         if (doutf8)
2273             SvUTF8_on(TARG);
2274         TAINT_IF(rxtainted);
2275         SvSETMAGIC(TARG);
2276         SvTAINT(TARG);
2277         LEAVE_SCOPE(oldsave);
2278         RETURN;
2279     }
2280     goto ret_no;
2281
2282 nope:
2283 ret_no:
2284     SPAGAIN;
2285     PUSHs(&PL_sv_no);
2286     LEAVE_SCOPE(oldsave);
2287     RETURN;
2288 }
2289
2290 PP(pp_grepwhile)
2291 {
2292     dSP;
2293
2294     if (SvTRUEx(POPs))
2295         PL_stack_base[PL_markstack_ptr[-1]++] = PL_stack_base[*PL_markstack_ptr];
2296     ++*PL_markstack_ptr;
2297     LEAVE;                                      /* exit inner scope */
2298
2299     /* All done yet? */
2300     if (PL_stack_base + *PL_markstack_ptr > SP) {
2301         I32 items;
2302         I32 gimme = GIMME_V;
2303
2304         LEAVE;                                  /* exit outer scope */
2305         (void)POPMARK;                          /* pop src */
2306         items = --*PL_markstack_ptr - PL_markstack_ptr[-1];
2307         (void)POPMARK;                          /* pop dst */
2308         SP = PL_stack_base + POPMARK;           /* pop original mark */
2309         if (gimme == G_SCALAR) {
2310             if (PL_op->op_private & OPpGREP_LEX) {
2311                 SV* sv = sv_newmortal();
2312                 sv_setiv(sv, items);
2313                 PUSHs(sv);
2314             }
2315             else {
2316                 dTARGET;
2317                 XPUSHi(items);
2318             }
2319         }
2320         else if (gimme == G_ARRAY)
2321             SP += items;
2322         RETURN;
2323     }
2324     else {
2325         SV *src;
2326
2327         ENTER;                                  /* enter inner scope */
2328         SAVEVPTR(PL_curpm);
2329
2330         src = PL_stack_base[*PL_markstack_ptr];
2331         SvTEMP_off(src);
2332         if (PL_op->op_private & OPpGREP_LEX)
2333             PAD_SVl(PL_op->op_targ) = src;
2334         else
2335             DEFSV = src;
2336
2337         RETURNOP(cLOGOP->op_other);
2338     }
2339 }
2340
2341 PP(pp_leavesub)
2342 {
2343     dSP;
2344     SV **mark;
2345     SV **newsp;
2346     PMOP *newpm;
2347     I32 gimme;
2348     register PERL_CONTEXT *cx;
2349     SV *sv;
2350
2351     POPBLOCK(cx,newpm);
2352     cxstack_ix++; /* temporarily protect top context */
2353
2354     TAINT_NOT;
2355     if (gimme == G_SCALAR) {
2356         MARK = newsp + 1;
2357         if (MARK <= SP) {
2358             if (cx->blk_sub.cv && CvDEPTH(cx->blk_sub.cv) > 1) {
2359                 if (SvTEMP(TOPs)) {
2360                     *MARK = SvREFCNT_inc(TOPs);
2361                     FREETMPS;
2362                     sv_2mortal(*MARK);
2363                 }
2364                 else {
2365                     sv = SvREFCNT_inc(TOPs);    /* FREETMPS could clobber it */
2366                     FREETMPS;
2367                     *MARK = sv_mortalcopy(sv);
2368                     SvREFCNT_dec(sv);
2369                 }
2370             }
2371             else
2372                 *MARK = SvTEMP(TOPs) ? TOPs : sv_mortalcopy(TOPs);
2373         }
2374         else {
2375             MEXTEND(MARK, 0);
2376             *MARK = &PL_sv_undef;
2377         }
2378         SP = MARK;
2379     }
2380     else if (gimme == G_ARRAY) {
2381         for (MARK = newsp + 1; MARK <= SP; MARK++) {
2382             if (!SvTEMP(*MARK)) {
2383                 *MARK = sv_mortalcopy(*MARK);
2384                 TAINT_NOT;      /* Each item is independent */
2385             }
2386         }
2387     }
2388     PUTBACK;
2389
2390     LEAVE;
2391     cxstack_ix--;
2392     POPSUB(cx,sv);      /* Stack values are safe: release CV and @_ ... */
2393     PL_curpm = newpm;   /* ... and pop $1 et al */
2394
2395     LEAVESUB(sv);
2396     return cx->blk_sub.retop;
2397 }
2398
2399 /* This duplicates the above code because the above code must not
2400  * get any slower by more conditions */
2401 PP(pp_leavesublv)
2402 {
2403     dSP;
2404     SV **mark;
2405     SV **newsp;
2406     PMOP *newpm;
2407     I32 gimme;
2408     register PERL_CONTEXT *cx;
2409     SV *sv;
2410
2411     POPBLOCK(cx,newpm);
2412     cxstack_ix++; /* temporarily protect top context */
2413
2414     TAINT_NOT;
2415
2416     if (cx->blk_sub.lval & OPpENTERSUB_INARGS) {
2417         /* We are an argument to a function or grep().
2418          * This kind of lvalueness was legal before lvalue
2419          * subroutines too, so be backward compatible:
2420          * cannot report errors.  */
2421
2422         /* Scalar context *is* possible, on the LHS of -> only,
2423          * as in f()->meth().  But this is not an lvalue. */
2424         if (gimme == G_SCALAR)
2425             goto temporise;
2426         if (gimme == G_ARRAY) {
2427             if (!CvLVALUE(cx->blk_sub.cv))
2428                 goto temporise_array;
2429             EXTEND_MORTAL(SP - newsp);
2430             for (mark = newsp + 1; mark <= SP; mark++) {
2431                 if (SvTEMP(*mark))
2432                     /* empty */ ;
2433                 else if (SvFLAGS(*mark) & (SVs_PADTMP | SVf_READONLY))
2434                     *mark = sv_mortalcopy(*mark);
2435                 else {
2436                     /* Can be a localized value subject to deletion. */
2437                     PL_tmps_stack[++PL_tmps_ix] = *mark;
2438                     (void)SvREFCNT_inc(*mark);
2439                 }
2440             }
2441         }
2442     }
2443     else if (cx->blk_sub.lval) {     /* Leave it as it is if we can. */
2444         /* Here we go for robustness, not for speed, so we change all
2445          * the refcounts so the caller gets a live guy. Cannot set
2446          * TEMP, so sv_2mortal is out of question. */
2447         if (!CvLVALUE(cx->blk_sub.cv)) {
2448             LEAVE;
2449             cxstack_ix--;
2450             POPSUB(cx,sv);
2451             PL_curpm = newpm;
2452             LEAVESUB(sv);
2453             DIE(aTHX_ "Can't modify non-lvalue subroutine call");
2454         }
2455         if (gimme == G_SCALAR) {
2456             MARK = newsp + 1;
2457             EXTEND_MORTAL(1);
2458             if (MARK == SP) {
2459                 if (SvFLAGS(TOPs) & (SVs_TEMP | SVs_PADTMP | SVf_READONLY)) {
2460                     LEAVE;
2461                     cxstack_ix--;
2462                     POPSUB(cx,sv);
2463                     PL_curpm = newpm;
2464                     LEAVESUB(sv);
2465                     DIE(aTHX_ "Can't return %s from lvalue subroutine",
2466                         SvREADONLY(TOPs) ? (TOPs == &PL_sv_undef) ? "undef"
2467                         : "a readonly value" : "a temporary");
2468                 }
2469                 else {                  /* Can be a localized value
2470                                          * subject to deletion. */
2471                     PL_tmps_stack[++PL_tmps_ix] = *mark;
2472                     (void)SvREFCNT_inc(*mark);
2473                 }
2474             }
2475             else {                      /* Should not happen? */
2476                 LEAVE;
2477                 cxstack_ix--;
2478                 POPSUB(cx,sv);
2479                 PL_curpm = newpm;
2480                 LEAVESUB(sv);
2481                 DIE(aTHX_ "%s returned from lvalue subroutine in scalar context",
2482                     (MARK > SP ? "Empty array" : "Array"));
2483             }
2484             SP = MARK;
2485         }
2486         else if (gimme == G_ARRAY) {
2487             EXTEND_MORTAL(SP - newsp);
2488             for (mark = newsp + 1; mark <= SP; mark++) {
2489                 if (*mark != &PL_sv_undef
2490                     && SvFLAGS(*mark) & (SVs_TEMP | SVs_PADTMP | SVf_READONLY)) {
2491                     /* Might be flattened array after $#array =  */
2492                     PUTBACK;
2493                     LEAVE;
2494                     cxstack_ix--;
2495                     POPSUB(cx,sv);
2496                     PL_curpm = newpm;
2497                     LEAVESUB(sv);
2498                     DIE(aTHX_ "Can't return a %s from lvalue subroutine",
2499                         SvREADONLY(TOPs) ? "readonly value" : "temporary");
2500                 }
2501                 else {
2502                     /* Can be a localized value subject to deletion. */
2503                     PL_tmps_stack[++PL_tmps_ix] = *mark;
2504                     (void)SvREFCNT_inc(*mark);
2505                 }
2506             }
2507         }
2508     }
2509     else {
2510         if (gimme == G_SCALAR) {
2511           temporise:
2512             MARK = newsp + 1;
2513             if (MARK <= SP) {
2514                 if (cx->blk_sub.cv && CvDEPTH(cx->blk_sub.cv) > 1) {
2515                     if (SvTEMP(TOPs)) {
2516                         *MARK = SvREFCNT_inc(TOPs);
2517                         FREETMPS;
2518                         sv_2mortal(*MARK);
2519                     }
2520                     else {
2521                         sv = SvREFCNT_inc(TOPs); /* FREETMPS could clobber it */
2522                         FREETMPS;
2523                         *MARK = sv_mortalcopy(sv);
2524                         SvREFCNT_dec(sv);
2525                     }
2526                 }
2527                 else
2528                     *MARK = SvTEMP(TOPs) ? TOPs : sv_mortalcopy(TOPs);
2529             }
2530             else {
2531                 MEXTEND(MARK, 0);
2532                 *MARK = &PL_sv_undef;
2533             }
2534             SP = MARK;
2535         }
2536         else if (gimme == G_ARRAY) {
2537           temporise_array:
2538             for (MARK = newsp + 1; MARK <= SP; MARK++) {
2539                 if (!SvTEMP(*MARK)) {
2540                     *MARK = sv_mortalcopy(*MARK);
2541                     TAINT_NOT;  /* Each item is independent */
2542                 }
2543             }
2544         }
2545     }
2546     PUTBACK;
2547
2548     LEAVE;
2549     cxstack_ix--;
2550     POPSUB(cx,sv);      /* Stack values are safe: release CV and @_ ... */
2551     PL_curpm = newpm;   /* ... and pop $1 et al */
2552
2553     LEAVESUB(sv);
2554     return cx->blk_sub.retop;
2555 }
2556
2557
2558 STATIC CV *
2559 S_get_db_sub(pTHX_ SV **svp, CV *cv)
2560 {
2561     SV *dbsv = GvSV(PL_DBsub);
2562
2563     save_item(dbsv);
2564     if (!PERLDB_SUB_NN) {
2565         GV *gv = CvGV(cv);
2566
2567         if ( (CvFLAGS(cv) & (CVf_ANON | CVf_CLONED))
2568              || strEQ(GvNAME(gv), "END")
2569              || ((GvCV(gv) != cv) && /* Could be imported, and old sub redefined. */
2570                  !( (SvTYPE(*svp) == SVt_PVGV) && (GvCV((GV*)*svp) == cv)
2571                     && (gv = (GV*)*svp) ))) {
2572             /* Use GV from the stack as a fallback. */
2573             /* GV is potentially non-unique, or contain different CV. */
2574             SV *tmp = newRV((SV*)cv);
2575             sv_setsv(dbsv, tmp);
2576             SvREFCNT_dec(tmp);
2577         }
2578         else {
2579             gv_efullname3(dbsv, gv, Nullch);
2580         }
2581     }
2582     else {
2583         int type = SvTYPE(dbsv);
2584         if (type < SVt_PVIV && type != SVt_IV)
2585             sv_upgrade(dbsv, SVt_PVIV);
2586         (void)SvIOK_on(dbsv);
2587         SvIV_set(dbsv, PTR2IV(cv));     /* Do it the quickest way  */
2588     }
2589
2590     if (CvXSUB(cv))
2591         PL_curcopdb = PL_curcop;
2592     cv = GvCV(PL_DBsub);
2593     return cv;
2594 }
2595
2596 PP(pp_entersub)
2597 {
2598     dSP; dPOPss;
2599     GV *gv;
2600     HV *stash;
2601     register CV *cv;
2602     register PERL_CONTEXT *cx;
2603     I32 gimme;
2604     bool hasargs = (PL_op->op_flags & OPf_STACKED) != 0;
2605
2606     if (!sv)
2607         DIE(aTHX_ "Not a CODE reference");
2608     switch (SvTYPE(sv)) {
2609         /* This is overwhelming the most common case:  */
2610     case SVt_PVGV:
2611         if (!(cv = GvCVu((GV*)sv)))
2612             cv = sv_2cv(sv, &stash, &gv, FALSE);
2613         if (!cv) {
2614             ENTER;
2615             SAVETMPS;
2616             goto try_autoload;
2617         }
2618         break;
2619     default:
2620         if (!SvROK(sv)) {
2621             char *sym;
2622             STRLEN n_a;
2623
2624             if (sv == &PL_sv_yes) {             /* unfound import, ignore */
2625                 if (hasargs)
2626                     SP = PL_stack_base + POPMARK;
2627                 RETURN;
2628             }
2629             if (SvGMAGICAL(sv)) {
2630                 mg_get(sv);
2631                 if (SvROK(sv))
2632                     goto got_rv;
2633                 sym = SvPOKp(sv) ? SvPVX(sv) : Nullch;
2634             }
2635             else
2636                 sym = SvPV(sv, n_a);
2637             if (!sym)
2638                 DIE(aTHX_ PL_no_usym, "a subroutine");
2639             if (PL_op->op_private & HINT_STRICT_REFS)
2640                 DIE(aTHX_ PL_no_symref, sym, "a subroutine");
2641             cv = get_cv(sym, TRUE);
2642             break;
2643         }
2644   got_rv:
2645         {
2646             SV **sp = &sv;              /* Used in tryAMAGICunDEREF macro. */
2647             tryAMAGICunDEREF(to_cv);
2648         }
2649         cv = (CV*)SvRV(sv);
2650         if (SvTYPE(cv) == SVt_PVCV)
2651             break;
2652         /* FALL THROUGH */
2653     case SVt_PVHV:
2654     case SVt_PVAV:
2655         DIE(aTHX_ "Not a CODE reference");
2656         /* This is the second most common case:  */
2657     case SVt_PVCV:
2658         cv = (CV*)sv;
2659         break;
2660     }
2661
2662     ENTER;
2663     SAVETMPS;
2664
2665   retry:
2666     if (!CvROOT(cv) && !CvXSUB(cv)) {
2667         goto fooey;
2668     }
2669
2670     gimme = GIMME_V;
2671     if ((PL_op->op_private & OPpENTERSUB_DB) && GvCV(PL_DBsub) && !CvNODEBUG(cv)) {
2672         if (CvASSERTION(cv) && PL_DBassertion)
2673             sv_setiv(PL_DBassertion, 1);
2674
2675         cv = get_db_sub(&sv, cv);
2676         if (!cv || (!CvXSUB(cv) && !CvSTART(cv)))
2677             DIE(aTHX_ "No DB::sub routine defined");
2678     }
2679
2680     if (!(CvXSUB(cv))) {
2681         /* This path taken at least 75% of the time   */
2682         dMARK;
2683         register I32 items = SP - MARK;
2684         AV* padlist = CvPADLIST(cv);
2685         PUSHBLOCK(cx, CXt_SUB, MARK);
2686         PUSHSUB(cx);
2687         cx->blk_sub.retop = PL_op->op_next;
2688         CvDEPTH(cv)++;
2689         /* XXX This would be a natural place to set C<PL_compcv = cv> so
2690          * that eval'' ops within this sub know the correct lexical space.
2691          * Owing the speed considerations, we choose instead to search for
2692          * the cv using find_runcv() when calling doeval().
2693          */
2694         if (CvDEPTH(cv) >= 2) {
2695             PERL_STACK_OVERFLOW_CHECK();
2696             pad_push(padlist, CvDEPTH(cv));
2697         }
2698         PAD_SET_CUR(padlist, CvDEPTH(cv));
2699         if (hasargs)
2700         {
2701             AV* av;
2702             SV** ary;
2703
2704 #if 0
2705             DEBUG_S(PerlIO_printf(Perl_debug_log,
2706                                   "%p entersub preparing @_\n", thr));
2707 #endif
2708             av = (AV*)PAD_SVl(0);
2709             if (AvREAL(av)) {
2710                 /* @_ is normally not REAL--this should only ever
2711                  * happen when DB::sub() calls things that modify @_ */
2712                 av_clear(av);
2713                 AvREAL_off(av);
2714                 AvREIFY_on(av);
2715             }
2716             cx->blk_sub.savearray = GvAV(PL_defgv);
2717             GvAV(PL_defgv) = (AV*)SvREFCNT_inc(av);
2718             CX_CURPAD_SAVE(cx->blk_sub);
2719             cx->blk_sub.argarray = av;
2720             ++MARK;
2721
2722             if (items > AvMAX(av) + 1) {
2723                 ary = AvALLOC(av);
2724                 if (AvARRAY(av) != ary) {
2725                     AvMAX(av) += AvARRAY(av) - AvALLOC(av);
2726                     SvPV_set(av, (char*)ary);
2727                 }
2728                 if (items > AvMAX(av) + 1) {
2729                     AvMAX(av) = items - 1;
2730                     Renew(ary,items,SV*);
2731                     AvALLOC(av) = ary;
2732                     SvPV_set(av, (char*)ary);
2733                 }
2734             }
2735             Copy(MARK,AvARRAY(av),items,SV*);
2736             AvFILLp(av) = items - 1;
2737
2738             while (items--) {
2739                 if (*MARK)
2740                     SvTEMP_off(*MARK);
2741                 MARK++;
2742             }
2743         }
2744         /* warning must come *after* we fully set up the context
2745          * stuff so that __WARN__ handlers can safely dounwind()
2746          * if they want to
2747          */
2748         if (CvDEPTH(cv) == 100 && ckWARN(WARN_RECURSION)
2749             && !(PERLDB_SUB && cv == GvCV(PL_DBsub)))
2750             sub_crush_depth(cv);
2751 #if 0
2752         DEBUG_S(PerlIO_printf(Perl_debug_log,
2753                               "%p entersub returning %p\n", thr, CvSTART(cv)));
2754 #endif
2755         RETURNOP(CvSTART(cv));
2756     }
2757     else {
2758 #ifdef PERL_XSUB_OLDSTYLE
2759         if (CvOLDSTYLE(cv)) {
2760             I32 (*fp3)(int,int,int);
2761             dMARK;
2762             register I32 items = SP - MARK;
2763                                         /* We dont worry to copy from @_. */
2764             while (SP > mark) {
2765                 SP[1] = SP[0];
2766                 SP--;
2767             }
2768             PL_stack_sp = mark + 1;
2769             fp3 = (I32(*)(int,int,int))CvXSUB(cv);
2770             items = (*fp3)(CvXSUBANY(cv).any_i32,
2771                            MARK - PL_stack_base + 1,
2772                            items);
2773             PL_stack_sp = PL_stack_base + items;
2774         }
2775         else
2776 #endif /* PERL_XSUB_OLDSTYLE */
2777         {
2778             I32 markix = TOPMARK;
2779
2780             PUTBACK;
2781
2782             if (!hasargs) {
2783                 /* Need to copy @_ to stack. Alternative may be to
2784                  * switch stack to @_, and copy return values
2785                  * back. This would allow popping @_ in XSUB, e.g.. XXXX */
2786                 AV* av;
2787                 I32 items;
2788                 av = GvAV(PL_defgv);
2789                 items = AvFILLp(av) + 1;   /* @_ is not tieable */
2790
2791                 if (items) {
2792                     /* Mark is at the end of the stack. */
2793                     EXTEND(SP, items);
2794                     Copy(AvARRAY(av), SP + 1, items, SV*);
2795                     SP += items;
2796                     PUTBACK ;
2797                 }
2798             }
2799             /* We assume first XSUB in &DB::sub is the called one. */
2800             if (PL_curcopdb) {
2801                 SAVEVPTR(PL_curcop);
2802                 PL_curcop = PL_curcopdb;
2803                 PL_curcopdb = NULL;
2804             }
2805             /* Do we need to open block here? XXXX */
2806             (void)(*CvXSUB(cv))(aTHX_ cv);
2807
2808             /* Enforce some sanity in scalar context. */
2809             if (gimme == G_SCALAR && ++markix != PL_stack_sp - PL_stack_base ) {
2810                 if (markix > PL_stack_sp - PL_stack_base)
2811                     *(PL_stack_base + markix) = &PL_sv_undef;
2812                 else
2813                     *(PL_stack_base + markix) = *PL_stack_sp;
2814                 PL_stack_sp = PL_stack_base + markix;
2815             }
2816         }
2817         LEAVE;
2818         return NORMAL;
2819     }
2820
2821     assert (0); /* Cannot get here.  */
2822     /* This is deliberately moved here as spaghetti code to keep it out of the
2823        hot path.  */
2824     {
2825         GV* autogv;
2826         SV* sub_name;
2827
2828       fooey:
2829         /* anonymous or undef'd function leaves us no recourse */
2830         if (CvANON(cv) || !(gv = CvGV(cv)))
2831             DIE(aTHX_ "Undefined subroutine called");
2832
2833         /* autoloaded stub? */
2834         if (cv != GvCV(gv)) {
2835             cv = GvCV(gv);
2836         }
2837         /* should call AUTOLOAD now? */
2838         else {
2839 try_autoload:
2840             if ((autogv = gv_autoload4(GvSTASH(gv), GvNAME(gv), GvNAMELEN(gv),
2841                                    FALSE)))
2842             {
2843                 cv = GvCV(autogv);
2844             }
2845             /* sorry */
2846             else {
2847                 sub_name = sv_newmortal();
2848                 gv_efullname3(sub_name, gv, Nullch);
2849                 DIE(aTHX_ "Undefined subroutine &%"SVf" called", sub_name);
2850             }
2851         }
2852         if (!cv)
2853             DIE(aTHX_ "Not a CODE reference");
2854         goto retry;
2855     }
2856 }
2857
2858 void
2859 Perl_sub_crush_depth(pTHX_ CV *cv)
2860 {
2861     if (CvANON(cv))
2862         Perl_warner(aTHX_ packWARN(WARN_RECURSION), "Deep recursion on anonymous subroutine");
2863     else {
2864         SV* tmpstr = sv_newmortal();
2865         gv_efullname3(tmpstr, CvGV(cv), Nullch);
2866         Perl_warner(aTHX_ packWARN(WARN_RECURSION), "Deep recursion on subroutine \"%"SVf"\"",
2867                 tmpstr);
2868     }
2869 }
2870
2871 PP(pp_aelem)
2872 {
2873     dSP;
2874     SV** svp;
2875     SV* elemsv = POPs;
2876     IV elem = SvIV(elemsv);
2877     AV* av = (AV*)POPs;
2878     const U32 lval = PL_op->op_flags & OPf_MOD || LVRET;
2879     const U32 defer = (PL_op->op_private & OPpLVAL_DEFER) && (elem > av_len(av));
2880     SV *sv;
2881
2882     if (SvROK(elemsv) && !SvGAMAGIC(elemsv) && ckWARN(WARN_MISC))
2883         Perl_warner(aTHX_ packWARN(WARN_MISC), "Use of reference \"%"SVf"\" as array index", elemsv);
2884     if (elem > 0)
2885         elem -= PL_curcop->cop_arybase;
2886     if (SvTYPE(av) != SVt_PVAV)
2887         RETPUSHUNDEF;
2888     svp = av_fetch(av, elem, lval && !defer);
2889     if (lval) {
2890 #ifdef PERL_MALLOC_WRAP
2891          static const char oom_array_extend[] =
2892               "Out of memory during array extend"; /* Duplicated in av.c */
2893          if (SvUOK(elemsv)) {
2894               UV uv = SvUV(elemsv);
2895               elem = uv > IV_MAX ? IV_MAX : uv;
2896          }
2897          else if (SvNOK(elemsv))
2898               elem = (IV)SvNV(elemsv);
2899          if (elem > 0)
2900               MEM_WRAP_CHECK_1(elem,SV*,oom_array_extend);
2901 #endif
2902         if (!svp || *svp == &PL_sv_undef) {
2903             SV* lv;
2904             if (!defer)
2905                 DIE(aTHX_ PL_no_aelem, elem);
2906             lv = sv_newmortal();
2907             sv_upgrade(lv, SVt_PVLV);
2908             LvTYPE(lv) = 'y';
2909             sv_magic(lv, Nullsv, PERL_MAGIC_defelem, Nullch, 0);
2910             LvTARG(lv) = SvREFCNT_inc(av);
2911             LvTARGOFF(lv) = elem;
2912             LvTARGLEN(lv) = 1;
2913             PUSHs(lv);
2914             RETURN;
2915         }
2916         if (PL_op->op_private & OPpLVAL_INTRO)
2917             save_aelem(av, elem, svp);
2918         else if (PL_op->op_private & OPpDEREF)
2919             vivify_ref(*svp, PL_op->op_private & OPpDEREF);
2920     }
2921     sv = (svp ? *svp : &PL_sv_undef);
2922     if (!lval && SvGMAGICAL(sv))        /* see note in pp_helem() */
2923         sv = sv_mortalcopy(sv);
2924     PUSHs(sv);
2925     RETURN;
2926 }
2927
2928 void
2929 Perl_vivify_ref(pTHX_ SV *sv, U32 to_what)
2930 {
2931     if (SvGMAGICAL(sv))
2932         mg_get(sv);
2933     if (!SvOK(sv)) {
2934         if (SvREADONLY(sv))
2935             Perl_croak(aTHX_ PL_no_modify);
2936         if (SvTYPE(sv) < SVt_RV)
2937             sv_upgrade(sv, SVt_RV);
2938         else if (SvTYPE(sv) >= SVt_PV) {
2939             SvOOK_off(sv);
2940             Safefree(SvPVX(sv));
2941             SvLEN(sv) = SvCUR(sv) = 0;
2942         }
2943         switch (to_what) {
2944         case OPpDEREF_SV:
2945             SvRV(sv) = NEWSV(355,0);
2946             break;
2947         case OPpDEREF_AV:
2948             SvRV(sv) = (SV*)newAV();
2949             break;
2950         case OPpDEREF_HV:
2951             SvRV(sv) = (SV*)newHV();
2952             break;
2953         }
2954         SvROK_on(sv);
2955         SvSETMAGIC(sv);
2956     }
2957 }
2958
2959 PP(pp_method)
2960 {
2961     dSP;
2962     SV* sv = TOPs;
2963
2964     if (SvROK(sv)) {
2965         SV* rsv = SvRV(sv);
2966         if (SvTYPE(rsv) == SVt_PVCV) {
2967             SETs(rsv);
2968             RETURN;
2969         }
2970     }
2971
2972     SETs(method_common(sv, Null(U32*)));
2973     RETURN;
2974 }
2975
2976 PP(pp_method_named)
2977 {
2978     dSP;
2979     SV* sv = cSVOP_sv;
2980     U32 hash = SvUVX(sv);
2981
2982     XPUSHs(method_common(sv, &hash));
2983     RETURN;
2984 }
2985
2986 STATIC SV *
2987 S_method_common(pTHX_ SV* meth, U32* hashp)
2988 {
2989     SV* sv;
2990     SV* ob;
2991     GV* gv;
2992     HV* stash;
2993     char* name;
2994     STRLEN namelen;
2995     char* packname = 0;
2996     SV *packsv = Nullsv;
2997     STRLEN packlen;
2998
2999     name = SvPV(meth, namelen);
3000     sv = *(PL_stack_base + TOPMARK + 1);
3001
3002     if (!sv)
3003         Perl_croak(aTHX_ "Can't call method \"%s\" on an undefined value", name);
3004
3005     if (SvGMAGICAL(sv))
3006         mg_get(sv);
3007     if (SvROK(sv))
3008         ob = (SV*)SvRV(sv);
3009     else {
3010         GV* iogv;
3011
3012         /* this isn't a reference */
3013         packname = Nullch;
3014
3015         if(SvOK(sv) && (packname = SvPV(sv, packlen))) {
3016           HE* he;
3017           he = hv_fetch_ent(PL_stashcache, sv, 0, 0);
3018           if (he) {
3019             stash = INT2PTR(HV*,SvIV(HeVAL(he)));
3020             goto fetch;
3021           }
3022         }
3023
3024         if (!SvOK(sv) ||
3025             !(packname) ||
3026             !(iogv = gv_fetchsv(sv, FALSE, SVt_PVIO)) ||
3027             !(ob=(SV*)GvIO(iogv)))
3028         {
3029             /* this isn't the name of a filehandle either */
3030             if (!packname ||
3031                 ((UTF8_IS_START(*packname) && DO_UTF8(sv))
3032                     ? !isIDFIRST_utf8((U8*)packname)
3033                     : !isIDFIRST(*packname)
3034                 ))
3035             {
3036                 Perl_croak(aTHX_ "Can't call method \"%s\" %s", name,
3037                            SvOK(sv) ? "without a package or object reference"
3038                                     : "on an undefined value");
3039             }
3040             /* assume it's a package name */
3041             stash = gv_stashpvn(packname, packlen, FALSE);
3042             if (!stash)
3043                 packsv = sv;
3044             else {
3045                 SV* ref = newSViv(PTR2IV(stash));
3046                 hv_store(PL_stashcache, packname, packlen, ref, 0);
3047             }
3048             goto fetch;
3049         }
3050         /* it _is_ a filehandle name -- replace with a reference */
3051         *(PL_stack_base + TOPMARK + 1) = sv_2mortal(newRV((SV*)iogv));
3052     }
3053
3054     /* if we got here, ob should be a reference or a glob */
3055     if (!ob || !(SvOBJECT(ob)
3056                  || (SvTYPE(ob) == SVt_PVGV && (ob = (SV*)GvIO((GV*)ob))
3057                      && SvOBJECT(ob))))
3058     {
3059         Perl_croak(aTHX_ "Can't call method \"%s\" on unblessed reference",
3060                    name);
3061     }
3062
3063     stash = SvSTASH(ob);
3064
3065   fetch:
3066     /* NOTE: stash may be null, hope hv_fetch_ent and
3067        gv_fetchmethod can cope (it seems they can) */
3068
3069     /* shortcut for simple names */
3070     if (hashp) {
3071         HE* he = hv_fetch_ent(stash, meth, 0, *hashp);
3072         if (he) {
3073             gv = (GV*)HeVAL(he);
3074             if (isGV(gv) && GvCV(gv) &&
3075                 (!GvCVGEN(gv) || GvCVGEN(gv) == PL_sub_generation))
3076                 return (SV*)GvCV(gv);
3077         }
3078     }
3079
3080     gv = gv_fetchmethod(stash ? stash : (HV*)packsv, name);
3081
3082     if (!gv) {
3083         /* This code tries to figure out just what went wrong with
3084            gv_fetchmethod.  It therefore needs to duplicate a lot of
3085            the internals of that function.  We can't move it inside
3086            Perl_gv_fetchmethod_autoload(), however, since that would
3087            cause UNIVERSAL->can("NoSuchPackage::foo") to croak, and we
3088            don't want that.
3089         */
3090         char* leaf = name;
3091         char* sep = Nullch;
3092         char* p;
3093
3094         for (p = name; *p; p++) {
3095             if (*p == '\'')
3096                 sep = p, leaf = p + 1;
3097             else if (*p == ':' && *(p + 1) == ':')
3098                 sep = p, leaf = p + 2;
3099         }
3100         if (!sep || ((sep - name) == 5 && strnEQ(name, "SUPER", 5))) {
3101             /* the method name is unqualified or starts with SUPER:: */
3102             packname = sep ? CopSTASHPV(PL_curcop) :
3103                 stash ? HvNAME(stash) : packname;
3104             if (!packname)
3105                 Perl_croak(aTHX_
3106                            "Can't use anonymous symbol table for method lookup");
3107             else
3108                 packlen = strlen(packname);
3109         }
3110         else {
3111             /* the method name is qualified */
3112             packname = name;
3113             packlen = sep - name;
3114         }
3115
3116         /* we're relying on gv_fetchmethod not autovivifying the stash */
3117         if (gv_stashpvn(packname, packlen, FALSE)) {
3118             Perl_croak(aTHX_
3119                        "Can't locate object method \"%s\" via package \"%.*s\"",
3120                        leaf, (int)packlen, packname);
3121         }
3122         else {
3123             Perl_croak(aTHX_
3124                        "Can't locate object method \"%s\" via package \"%.*s\""
3125                        " (perhaps you forgot to load \"%.*s\"?)",
3126                        leaf, (int)packlen, packname, (int)packlen, packname);
3127         }
3128     }
3129     return isGV(gv) ? (SV*)GvCV(gv) : (SV*)gv;
3130 }
3131
3132 /*
3133  * Local variables:
3134  * c-indentation-style: bsd
3135  * c-basic-offset: 4
3136  * indent-tabs-mode: t
3137  * End:
3138  *
3139  * vim: shiftwidth=4:
3140 */