pp_hot.c

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