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 < 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     register char *t;
1188     register char *s;
1189     char *strend;
1190     I32 global;
1191     I32 r_flags = REXEC_CHECKED;
1192     char *truebase;                     /* Start of string  */
1193     register REGEXP *rx = PM_GETRE(pm);
1194     bool rxtainted;
1195     I32 gimme = GIMME;
1196     STRLEN len;
1197     I32 minmatch = 0;
1198     I32 oldsave = PL_savestack_ix;
1199     I32 update_minmatch = 1;
1200     I32 had_zerolen = 0;
1201
1202     if (PL_op->op_flags & OPf_STACKED)
1203         TARG = POPs;
1204     else {
1205         TARG = DEFSV;
1206         EXTEND(SP,1);
1207     }
1208
1209     PUTBACK;                            /* EVAL blocks need stack_sp. */
1210     s = SvPV(TARG, len);
1211     strend = s + len;
1212     if (!s)
1213         DIE(aTHX_ "panic: pp_match");
1214     rxtainted = ((pm->op_pmdynflags & PMdf_TAINTED) ||
1215                  (PL_tainted && (pm->op_pmflags & PMf_RETAINT)));
1216     TAINT_NOT;
1217
1218     PL_reg_match_utf8 = DO_UTF8(TARG);
1219
1220     if (pm->op_pmdynflags & PMdf_USED) {
1221       failure:
1222         if (gimme == G_ARRAY)
1223             RETURN;
1224         RETPUSHNO;
1225     }
1226
1227     if (!rx->prelen && PL_curpm) {
1228         pm = PL_curpm;
1229         rx = PM_GETRE(pm);
1230     }
1231     if (rx->minlen > len)
1232       goto failure;
1233
1234     truebase = t = s;
1235
1236     /* XXXX What part of this is needed with true \G-support? */
1237     if ((global = pm->op_pmflags & PMf_GLOBAL)) {
1238         rx->startp[0] = -1;
1239         if (SvTYPE(TARG) >= SVt_PVMG && SvMAGIC(TARG)) {
1240             MAGIC* mg = mg_find(TARG, PERL_MAGIC_regex_global);
1241             if (mg && mg->mg_len >= 0) {
1242                 if (!(rx->reganch & ROPT_GPOS_SEEN))
1243                     rx->endp[0] = rx->startp[0] = mg->mg_len;
1244                 else if (rx->reganch & ROPT_ANCH_GPOS) {
1245                     r_flags |= REXEC_IGNOREPOS;
1246                     rx->endp[0] = rx->startp[0] = mg->mg_len;
1247                 }
1248                 minmatch = (mg->mg_flags & MGf_MINMATCH);
1249                 update_minmatch = 0;
1250             }
1251         }
1252     }
1253     if ((!global && rx->nparens)
1254             || SvTEMP(TARG) || PL_sawampersand)
1255         r_flags |= REXEC_COPY_STR;
1256     if (SvSCREAM(TARG))
1257         r_flags |= REXEC_SCREAM;
1258
1259     if (pm->op_pmflags & (PMf_MULTILINE|PMf_SINGLELINE)) {
1260         SAVEINT(PL_multiline);
1261         PL_multiline = pm->op_pmflags & PMf_MULTILINE;
1262     }
1263
1264 play_it_again:
1265     if (global && rx->startp[0] != -1) {
1266         t = s = rx->endp[0] + truebase;
1267         if ((s + rx->minlen) > strend)
1268             goto nope;
1269         if (update_minmatch++)
1270             minmatch = had_zerolen;
1271     }
1272     if (rx->reganch & RE_USE_INTUIT &&
1273         DO_UTF8(TARG) == ((rx->reganch & ROPT_UTF8) != 0)) {
1274         PL_bostr = truebase;
1275         s = CALLREG_INTUIT_START(aTHX_ rx, TARG, s, strend, r_flags, NULL);
1276
1277         if (!s)
1278             goto nope;
1279         if ( (rx->reganch & ROPT_CHECK_ALL)
1280              && !PL_sawampersand
1281              && ((rx->reganch & ROPT_NOSCAN)
1282                  || !((rx->reganch & RE_INTUIT_TAIL)
1283                       && (r_flags & REXEC_SCREAM)))
1284              && !SvROK(TARG))   /* Cannot trust since INTUIT cannot guess ^ */
1285             goto yup;
1286     }
1287     if (CALLREGEXEC(aTHX_ rx, s, strend, truebase, minmatch, TARG, NULL, r_flags))
1288     {
1289         PL_curpm = pm;
1290         if (pm->op_pmflags & PMf_ONCE)
1291             pm->op_pmdynflags |= PMdf_USED;
1292         goto gotcha;
1293     }
1294     else
1295         goto ret_no;
1296     /*NOTREACHED*/
1297
1298   gotcha:
1299     if (rxtainted)
1300         RX_MATCH_TAINTED_on(rx);
1301     TAINT_IF(RX_MATCH_TAINTED(rx));
1302     if (gimme == G_ARRAY) {
1303         I32 nparens, i, len;
1304
1305         nparens = rx->nparens;
1306         if (global && !nparens)
1307             i = 1;
1308         else
1309             i = 0;
1310         SPAGAIN;                        /* EVAL blocks could move the stack. */
1311         EXTEND(SP, nparens + i);
1312         EXTEND_MORTAL(nparens + i);
1313         for (i = !i; i <= nparens; i++) {
1314             PUSHs(sv_newmortal());
1315             /*SUPPRESS 560*/
1316             if ((rx->startp[i] != -1) && rx->endp[i] != -1 ) {
1317                 len = rx->endp[i] - rx->startp[i];
1318                 if (rx->endp[i] < 0 || rx->startp[i] < 0 ||
1319                     len < 0 || len > strend - s)
1320                     DIE(aTHX_ "panic: pp_match start/end pointers");
1321                 s = rx->startp[i] + truebase;
1322                 sv_setpvn(*SP, s, len);
1323                 if (DO_UTF8(TARG) && is_utf8_string((U8*)s, len))
1324                     SvUTF8_on(*SP);
1325             }
1326         }
1327         if (global) {
1328             if (pm->op_pmflags & PMf_CONTINUE) {
1329                 MAGIC* mg = 0;
1330                 if (SvTYPE(TARG) >= SVt_PVMG && SvMAGIC(TARG))
1331                     mg = mg_find(TARG, PERL_MAGIC_regex_global);
1332                 if (!mg) {
1333                     sv_magic(TARG, (SV*)0, PERL_MAGIC_regex_global, Nullch, 0);
1334                     mg = mg_find(TARG, PERL_MAGIC_regex_global);
1335                 }
1336                 if (rx->startp[0] != -1) {
1337                     mg->mg_len = rx->endp[0];
1338                     if (rx->startp[0] == rx->endp[0])
1339                         mg->mg_flags |= MGf_MINMATCH;
1340                     else
1341                         mg->mg_flags &= ~MGf_MINMATCH;
1342                 }
1343             }
1344             had_zerolen = (rx->startp[0] != -1
1345                            && rx->startp[0] == rx->endp[0]);
1346             PUTBACK;                    /* EVAL blocks may use stack */
1347             r_flags |= REXEC_IGNOREPOS | REXEC_NOT_FIRST;
1348             goto play_it_again;
1349         }
1350         else if (!nparens)
1351             XPUSHs(&PL_sv_yes);
1352         LEAVE_SCOPE(oldsave);
1353         RETURN;
1354     }
1355     else {
1356         if (global) {
1357             MAGIC* mg = 0;
1358             if (SvTYPE(TARG) >= SVt_PVMG && SvMAGIC(TARG))
1359                 mg = mg_find(TARG, PERL_MAGIC_regex_global);
1360             if (!mg) {
1361                 sv_magic(TARG, (SV*)0, PERL_MAGIC_regex_global, Nullch, 0);
1362                 mg = mg_find(TARG, PERL_MAGIC_regex_global);
1363             }
1364             if (rx->startp[0] != -1) {
1365                 mg->mg_len = rx->endp[0];
1366                 if (rx->startp[0] == rx->endp[0])
1367                     mg->mg_flags |= MGf_MINMATCH;
1368                 else
1369                     mg->mg_flags &= ~MGf_MINMATCH;
1370             }
1371         }
1372         LEAVE_SCOPE(oldsave);
1373         RETPUSHYES;
1374     }
1375
1376 yup:                                    /* Confirmed by INTUIT */
1377     if (rxtainted)
1378         RX_MATCH_TAINTED_on(rx);
1379     TAINT_IF(RX_MATCH_TAINTED(rx));
1380     PL_curpm = pm;
1381     if (pm->op_pmflags & PMf_ONCE)
1382         pm->op_pmdynflags |= PMdf_USED;
1383     if (RX_MATCH_COPIED(rx))
1384         Safefree(rx->subbeg);
1385     RX_MATCH_COPIED_off(rx);
1386     rx->subbeg = Nullch;
1387     if (global) {
1388         rx->subbeg = truebase;
1389         rx->startp[0] = s - truebase;
1390         if (PL_reg_match_utf8) {
1391             char *t = (char*)utf8_hop((U8*)s, rx->minlen);
1392             rx->endp[0] = t - truebase;
1393         }
1394         else {
1395             rx->endp[0] = s - truebase + rx->minlen;
1396         }
1397         rx->sublen = strend - truebase;
1398         goto gotcha;
1399     }
1400     if (PL_sawampersand) {
1401         I32 off;
1402
1403         rx->subbeg = savepvn(t, strend - t);
1404         rx->sublen = strend - t;
1405         RX_MATCH_COPIED_on(rx);
1406         off = rx->startp[0] = s - t;
1407         rx->endp[0] = off + rx->minlen;
1408     }
1409     else {                      /* startp/endp are used by @- @+. */
1410         rx->startp[0] = s - truebase;
1411         rx->endp[0] = s - truebase + rx->minlen;
1412     }
1413     rx->nparens = rx->lastparen = 0;    /* used by @- and @+ */
1414     LEAVE_SCOPE(oldsave);
1415     RETPUSHYES;
1416
1417 nope:
1418 ret_no:
1419     if (global && !(pm->op_pmflags & PMf_CONTINUE)) {
1420         if (SvTYPE(TARG) >= SVt_PVMG && SvMAGIC(TARG)) {
1421             MAGIC* mg = mg_find(TARG, PERL_MAGIC_regex_global);
1422             if (mg)
1423                 mg->mg_len = -1;
1424         }
1425     }
1426     LEAVE_SCOPE(oldsave);
1427     if (gimme == G_ARRAY)
1428         RETURN;
1429     RETPUSHNO;
1430 }
1431
1432 OP *
1433 Perl_do_readline(pTHX)
1434 {
1435     dSP; dTARGETSTACKED;
1436     register SV *sv;
1437     STRLEN tmplen = 0;
1438     STRLEN offset;
1439     PerlIO *fp;
1440     register IO *io = GvIO(PL_last_in_gv);
1441     register I32 type = PL_op->op_type;
1442     I32 gimme = GIMME_V;
1443     MAGIC *mg;
1444
1445     if (io && (mg = SvTIED_mg((SV*)io, PERL_MAGIC_tiedscalar))) {
1446         PUSHMARK(SP);
1447         XPUSHs(SvTIED_obj((SV*)io, mg));
1448         PUTBACK;
1449         ENTER;
1450         call_method("READLINE", gimme);
1451         LEAVE;
1452         SPAGAIN;
1453         if (gimme == G_SCALAR)
1454             SvSetMagicSV_nosteal(TARG, TOPs);
1455         RETURN;
1456     }
1457     fp = Nullfp;
1458     if (io) {
1459         fp = IoIFP(io);
1460         if (!fp) {
1461             if (IoFLAGS(io) & IOf_ARGV) {
1462                 if (IoFLAGS(io) & IOf_START) {
1463                     IoLINES(io) = 0;
1464                     if (av_len(GvAVn(PL_last_in_gv)) < 0) {
1465                         IoFLAGS(io) &= ~IOf_START;
1466                         do_open(PL_last_in_gv,"-",1,FALSE,O_RDONLY,0,Nullfp);
1467                         sv_setpvn(GvSV(PL_last_in_gv), "-", 1);
1468                         SvSETMAGIC(GvSV(PL_last_in_gv));
1469                         fp = IoIFP(io);
1470                         goto have_fp;
1471                     }
1472                 }
1473                 fp = nextargv(PL_last_in_gv);
1474                 if (!fp) { /* Note: fp != IoIFP(io) */
1475                     (void)do_close(PL_last_in_gv, FALSE); /* now it does*/
1476                 }
1477             }
1478             else if (type == OP_GLOB)
1479                 fp = Perl_start_glob(aTHX_ POPs, io);
1480         }
1481         else if (type == OP_GLOB)
1482             SP--;
1483         else if (ckWARN(WARN_IO) && IoTYPE(io) == IoTYPE_WRONLY) {
1484             report_evil_fh(PL_last_in_gv, io, OP_phoney_OUTPUT_ONLY);
1485         }
1486     }
1487     if (!fp) {
1488         if (ckWARN2(WARN_GLOB, WARN_CLOSED)
1489                 && (!io || !(IoFLAGS(io) & IOf_START))) {
1490             if (type == OP_GLOB)
1491                 Perl_warner(aTHX_ packWARN(WARN_GLOB),
1492                             "glob failed (can't start child: %s)",
1493                             Strerror(errno));
1494             else
1495                 report_evil_fh(PL_last_in_gv, io, PL_op->op_type);
1496         }
1497         if (gimme == G_SCALAR) {
1498             (void)SvOK_off(TARG);
1499             PUSHTARG;
1500         }
1501         RETURN;
1502     }
1503   have_fp:
1504     if (gimme == G_SCALAR) {
1505         sv = TARG;
1506         if (SvROK(sv))
1507             sv_unref(sv);
1508         (void)SvUPGRADE(sv, SVt_PV);
1509         tmplen = SvLEN(sv);     /* remember if already alloced */
1510         if (!tmplen)
1511             Sv_Grow(sv, 80);    /* try short-buffering it */
1512         if (type == OP_RCATLINE)
1513             offset = SvCUR(sv);
1514         else
1515             offset = 0;
1516     }
1517     else {
1518         sv = sv_2mortal(NEWSV(57, 80));
1519         offset = 0;
1520     }
1521
1522     /* This should not be marked tainted if the fp is marked clean */
1523 #define MAYBE_TAINT_LINE(io, sv) \
1524     if (!(IoFLAGS(io) & IOf_UNTAINT)) { \
1525         TAINT;                          \
1526         SvTAINTED_on(sv);               \
1527     }
1528
1529 /* delay EOF state for a snarfed empty file */
1530 #define SNARF_EOF(gimme,rs,io,sv) \
1531     (gimme != G_SCALAR || SvCUR(sv)                                     \
1532      || (IoFLAGS(io) & IOf_NOLINE) || !RsSNARF(rs))
1533
1534     for (;;) {
1535         PUTBACK;
1536         if (!sv_gets(sv, fp, offset)
1537             && (type == OP_GLOB || SNARF_EOF(gimme, PL_rs, io, sv)))
1538         {
1539             PerlIO_clearerr(fp);
1540             if (IoFLAGS(io) & IOf_ARGV) {
1541                 fp = nextargv(PL_last_in_gv);
1542                 if (fp)
1543                     continue;
1544                 (void)do_close(PL_last_in_gv, FALSE);
1545             }
1546             else if (type == OP_GLOB) {
1547                 if (!do_close(PL_last_in_gv, FALSE) && ckWARN(WARN_GLOB)) {
1548                     Perl_warner(aTHX_ packWARN(WARN_GLOB),
1549                            "glob failed (child exited with status %d%s)",
1550                            (int)(STATUS_CURRENT >> 8),
1551                            (STATUS_CURRENT & 0x80) ? ", core dumped" : "");
1552                 }
1553             }
1554             if (gimme == G_SCALAR) {
1555                 (void)SvOK_off(TARG);
1556                 SPAGAIN;
1557                 PUSHTARG;
1558             }
1559             MAYBE_TAINT_LINE(io, sv);
1560             RETURN;
1561         }
1562         MAYBE_TAINT_LINE(io, sv);
1563         IoLINES(io)++;
1564         IoFLAGS(io) |= IOf_NOLINE;
1565         SvSETMAGIC(sv);
1566         SPAGAIN;
1567         XPUSHs(sv);
1568         if (type == OP_GLOB) {
1569             char *tmps;
1570
1571             if (SvCUR(sv) > 0 && SvCUR(PL_rs) > 0) {
1572                 tmps = SvEND(sv) - 1;
1573                 if (*tmps == *SvPVX(PL_rs)) {
1574                     *tmps = '\0';
1575                     SvCUR(sv)--;
1576                 }
1577             }
1578             for (tmps = SvPVX(sv); *tmps; tmps++)
1579                 if (!isALPHA(*tmps) && !isDIGIT(*tmps) &&
1580                     strchr("$&*(){}[]'\";\\|?<>~`", *tmps))
1581                         break;
1582             if (*tmps && PerlLIO_lstat(SvPVX(sv), &PL_statbuf) < 0) {
1583                 (void)POPs;             /* Unmatched wildcard?  Chuck it... */
1584                 continue;
1585             }
1586         }
1587         if (gimme == G_ARRAY) {
1588             if (SvLEN(sv) - SvCUR(sv) > 20) {
1589                 SvLEN_set(sv, SvCUR(sv)+1);
1590                 Renew(SvPVX(sv), SvLEN(sv), char);
1591             }
1592             sv = sv_2mortal(NEWSV(58, 80));
1593             continue;
1594         }
1595         else if (gimme == G_SCALAR && !tmplen && SvLEN(sv) - SvCUR(sv) > 80) {
1596             /* try to reclaim a bit of scalar space (only on 1st alloc) */
1597             if (SvCUR(sv) < 60)
1598                 SvLEN_set(sv, 80);
1599             else
1600                 SvLEN_set(sv, SvCUR(sv)+40);    /* allow some slop */
1601             Renew(SvPVX(sv), SvLEN(sv), char);
1602         }
1603         RETURN;
1604     }
1605 }
1606
1607 PP(pp_enter)
1608 {
1609     dSP;
1610     register PERL_CONTEXT *cx;
1611     I32 gimme = OP_GIMME(PL_op, -1);
1612
1613     if (gimme == -1) {
1614         if (cxstack_ix >= 0)
1615             gimme = cxstack[cxstack_ix].blk_gimme;
1616         else
1617             gimme = G_SCALAR;
1618     }
1619
1620     ENTER;
1621
1622     SAVETMPS;
1623     PUSHBLOCK(cx, CXt_BLOCK, SP);
1624
1625     RETURN;
1626 }
1627
1628 PP(pp_helem)
1629 {
1630     dSP;
1631     HE* he;
1632     SV **svp;
1633     SV *keysv = POPs;
1634     HV *hv = (HV*)POPs;
1635     U32 lval = PL_op->op_flags & OPf_MOD || LVRET;
1636     U32 defer = PL_op->op_private & OPpLVAL_DEFER;
1637     SV *sv;
1638     U32 hash = (SvFAKE(keysv) && SvREADONLY(keysv)) ? SvUVX(keysv) : 0;
1639     I32 preeminent = 0;
1640
1641     if (SvTYPE(hv) == SVt_PVHV) {
1642         if (PL_op->op_private & OPpLVAL_INTRO)
1643             preeminent = SvRMAGICAL(hv) ? 1 : hv_exists_ent(hv, keysv, 0);
1644         he = hv_fetch_ent(hv, keysv, lval && !defer, hash);
1645         svp = he ? &HeVAL(he) : 0;
1646     }
1647     else if (SvTYPE(hv) == SVt_PVAV) {
1648         if (PL_op->op_private & OPpLVAL_INTRO)
1649             DIE(aTHX_ "Can't localize pseudo-hash element");
1650         svp = avhv_fetch_ent((AV*)hv, keysv, lval && !defer, hash);
1651     }
1652     else {
1653         RETPUSHUNDEF;
1654     }
1655     if (lval) {
1656         if (!svp || *svp == &PL_sv_undef) {
1657             SV* lv;
1658             SV* key2;
1659             if (!defer) {
1660                 STRLEN n_a;
1661                 DIE(aTHX_ PL_no_helem, SvPV(keysv, n_a));
1662             }
1663             lv = sv_newmortal();
1664             sv_upgrade(lv, SVt_PVLV);
1665             LvTYPE(lv) = 'y';
1666             sv_magic(lv, key2 = newSVsv(keysv), PERL_MAGIC_defelem, Nullch, 0);
1667             SvREFCNT_dec(key2); /* sv_magic() increments refcount */
1668             LvTARG(lv) = SvREFCNT_inc(hv);
1669             LvTARGLEN(lv) = 1;
1670             PUSHs(lv);
1671             RETURN;
1672         }
1673         if (PL_op->op_private & OPpLVAL_INTRO) {
1674             if (HvNAME(hv) && isGV(*svp))
1675                 save_gp((GV*)*svp, !(PL_op->op_flags & OPf_SPECIAL));
1676             else {
1677                 if (!preeminent) {
1678                     STRLEN keylen;
1679                     char *key = SvPV(keysv, keylen);
1680                     SAVEDELETE(hv, savepvn(key,keylen), keylen);
1681                 } else
1682                     save_helem(hv, keysv, svp);
1683             }
1684         }
1685         else if (PL_op->op_private & OPpDEREF)
1686             vivify_ref(*svp, PL_op->op_private & OPpDEREF);
1687     }
1688     sv = (svp ? *svp : &PL_sv_undef);
1689     /* This makes C<local $tied{foo} = $tied{foo}> possible.
1690      * Pushing the magical RHS on to the stack is useless, since
1691      * that magic is soon destined to be misled by the local(),
1692      * and thus the later pp_sassign() will fail to mg_get() the
1693      * old value.  This should also cure problems with delayed
1694      * mg_get()s.  GSAR 98-07-03 */
1695     if (!lval && SvGMAGICAL(sv))
1696         sv = sv_mortalcopy(sv);
1697     PUSHs(sv);
1698     RETURN;
1699 }
1700
1701 PP(pp_leave)
1702 {
1703     dSP;
1704     register PERL_CONTEXT *cx;
1705     register SV **mark;
1706     SV **newsp;
1707     PMOP *newpm;
1708     I32 gimme;
1709
1710     if (PL_op->op_flags & OPf_SPECIAL) {
1711         cx = &cxstack[cxstack_ix];
1712         cx->blk_oldpm = PL_curpm;       /* fake block should preserve $1 et al */
1713     }
1714
1715     POPBLOCK(cx,newpm);
1716
1717     gimme = OP_GIMME(PL_op, -1);
1718     if (gimme == -1) {
1719         if (cxstack_ix >= 0)
1720             gimme = cxstack[cxstack_ix].blk_gimme;
1721         else
1722             gimme = G_SCALAR;
1723     }
1724
1725     TAINT_NOT;
1726     if (gimme == G_VOID)
1727         SP = newsp;
1728     else if (gimme == G_SCALAR) {
1729         MARK = newsp + 1;
1730         if (MARK <= SP) {
1731             if (SvFLAGS(TOPs) & (SVs_PADTMP|SVs_TEMP))
1732                 *MARK = TOPs;
1733             else
1734                 *MARK = sv_mortalcopy(TOPs);
1735         } else {
1736             MEXTEND(mark,0);
1737             *MARK = &PL_sv_undef;
1738         }
1739         SP = MARK;
1740     }
1741     else if (gimme == G_ARRAY) {
1742         /* in case LEAVE wipes old return values */
1743         for (mark = newsp + 1; mark <= SP; mark++) {
1744             if (!(SvFLAGS(*mark) & (SVs_PADTMP|SVs_TEMP))) {
1745                 *mark = sv_mortalcopy(*mark);
1746                 TAINT_NOT;      /* Each item is independent */
1747             }
1748         }
1749     }
1750     PL_curpm = newpm;   /* Don't pop $1 et al till now */
1751
1752     LEAVE;
1753
1754     RETURN;
1755 }
1756
1757 PP(pp_iter)
1758 {
1759     dSP;
1760     register PERL_CONTEXT *cx;
1761     SV* sv;
1762     AV* av;
1763     SV **itersvp;
1764
1765     EXTEND(SP, 1);
1766     cx = &cxstack[cxstack_ix];
1767     if (CxTYPE(cx) != CXt_LOOP)
1768         DIE(aTHX_ "panic: pp_iter");
1769
1770     itersvp = CxITERVAR(cx);
1771     av = cx->blk_loop.iterary;
1772     if (SvTYPE(av) != SVt_PVAV) {
1773         /* iterate ($min .. $max) */
1774         if (cx->blk_loop.iterlval) {
1775             /* string increment */
1776             register SV* cur = cx->blk_loop.iterlval;
1777             STRLEN maxlen;
1778             char *max = SvPV((SV*)av, maxlen);
1779             if (!SvNIOK(cur) && SvCUR(cur) <= maxlen) {
1780 #ifndef USE_5005THREADS                   /* don't risk potential race */
1781                 if (SvREFCNT(*itersvp) == 1 && !SvMAGICAL(*itersvp)) {
1782                     /* safe to reuse old SV */
1783                     sv_setsv(*itersvp, cur);
1784                 }
1785                 else
1786 #endif
1787                 {
1788                     /* we need a fresh SV every time so that loop body sees a
1789                      * completely new SV for closures/references to work as
1790                      * they used to */
1791                     SvREFCNT_dec(*itersvp);
1792                     *itersvp = newSVsv(cur);
1793                 }
1794                 if (strEQ(SvPVX(cur), max))
1795                     sv_setiv(cur, 0); /* terminate next time */
1796                 else
1797                     sv_inc(cur);
1798                 RETPUSHYES;
1799             }
1800             RETPUSHNO;
1801         }
1802         /* integer increment */
1803         if (cx->blk_loop.iterix > cx->blk_loop.itermax)
1804             RETPUSHNO;
1805
1806 #ifndef USE_5005THREADS                   /* don't risk potential race */
1807         if (SvREFCNT(*itersvp) == 1 && !SvMAGICAL(*itersvp)) {
1808             /* safe to reuse old SV */
1809             sv_setiv(*itersvp, cx->blk_loop.iterix++);
1810         }
1811         else
1812 #endif
1813         {
1814             /* we need a fresh SV every time so that loop body sees a
1815              * completely new SV for closures/references to work as they
1816              * used to */
1817             SvREFCNT_dec(*itersvp);
1818             *itersvp = newSViv(cx->blk_loop.iterix++);
1819         }
1820         RETPUSHYES;
1821     }
1822
1823     /* iterate array */
1824     if (cx->blk_loop.iterix >= (av == PL_curstack ? cx->blk_oldsp : AvFILL(av)))
1825         RETPUSHNO;
1826
1827     SvREFCNT_dec(*itersvp);
1828
1829     if (SvMAGICAL(av) || AvREIFY(av)) {
1830         SV **svp = av_fetch(av, ++cx->blk_loop.iterix, FALSE);
1831         if (svp)
1832             sv = *svp;
1833         else
1834             sv = Nullsv;
1835     }
1836     else {
1837         sv = AvARRAY(av)[++cx->blk_loop.iterix];
1838     }
1839     if (sv)
1840         SvTEMP_off(sv);
1841     else
1842         sv = &PL_sv_undef;
1843     if (av != PL_curstack && sv == &PL_sv_undef) {
1844         SV *lv = cx->blk_loop.iterlval;
1845         if (lv && SvREFCNT(lv) > 1) {
1846             SvREFCNT_dec(lv);
1847             lv = Nullsv;
1848         }
1849         if (lv)
1850             SvREFCNT_dec(LvTARG(lv));
1851         else {
1852             lv = cx->blk_loop.iterlval = NEWSV(26, 0);
1853             sv_upgrade(lv, SVt_PVLV);
1854             LvTYPE(lv) = 'y';
1855             sv_magic(lv, Nullsv, PERL_MAGIC_defelem, Nullch, 0);
1856         }
1857         LvTARG(lv) = SvREFCNT_inc(av);
1858         LvTARGOFF(lv) = cx->blk_loop.iterix;
1859         LvTARGLEN(lv) = (STRLEN)UV_MAX;
1860         sv = (SV*)lv;
1861     }
1862
1863     *itersvp = SvREFCNT_inc(sv);
1864     RETPUSHYES;
1865 }
1866
1867 PP(pp_subst)
1868 {
1869     dSP; dTARG;
1870     register PMOP *pm = cPMOP;
1871     PMOP *rpm = pm;
1872     register SV *dstr;
1873     register char *s;
1874     char *strend;
1875     register char *m;
1876     char *c;
1877     register char *d;
1878     STRLEN clen;
1879     I32 iters = 0;
1880     I32 maxiters;
1881     register I32 i;
1882     bool once;
1883     bool rxtainted;
1884     char *orig;
1885     I32 r_flags;
1886     register REGEXP *rx = PM_GETRE(pm);
1887     STRLEN len;
1888     int force_on_match = 0;
1889     I32 oldsave = PL_savestack_ix;
1890     STRLEN slen;
1891     bool doutf8 = FALSE;
1892
1893     /* known replacement string? */
1894     dstr = (pm->op_pmflags & PMf_CONST) ? POPs : Nullsv;
1895     if (PL_op->op_flags & OPf_STACKED)
1896         TARG = POPs;
1897     else {
1898         TARG = DEFSV;
1899         EXTEND(SP,1);
1900     }
1901
1902     if (SvFAKE(TARG) && SvREADONLY(TARG))
1903         sv_force_normal(TARG);
1904     if (SvREADONLY(TARG)
1905         || (SvTYPE(TARG) > SVt_PVLV
1906             && !(SvTYPE(TARG) == SVt_PVGV && SvFAKE(TARG))))
1907         DIE(aTHX_ PL_no_modify);
1908     PUTBACK;
1909
1910     s = SvPV(TARG, len);
1911     if (!SvPOKp(TARG) || SvTYPE(TARG) == SVt_PVGV)
1912         force_on_match = 1;
1913     rxtainted = ((pm->op_pmdynflags & PMdf_TAINTED) ||
1914                  (PL_tainted && (pm->op_pmflags & PMf_RETAINT)));
1915     if (PL_tainted)
1916         rxtainted |= 2;
1917     TAINT_NOT;
1918
1919     PL_reg_match_utf8 = DO_UTF8(TARG);
1920
1921   force_it:
1922     if (!pm || !s)
1923         DIE(aTHX_ "panic: pp_subst");
1924
1925     strend = s + len;
1926     slen = PL_reg_match_utf8 ? utf8_length((U8*)s, (U8*)strend) : len;
1927     maxiters = 2 * slen + 10;   /* We can match twice at each
1928                                    position, once with zero-length,
1929                                    second time with non-zero. */
1930
1931     if (!rx->prelen && PL_curpm) {
1932         pm = PL_curpm;
1933         rx = PM_GETRE(pm);
1934     }
1935     r_flags = (rx->nparens || SvTEMP(TARG) || PL_sawampersand)
1936                 ? REXEC_COPY_STR : 0;
1937     if (SvSCREAM(TARG))
1938         r_flags |= REXEC_SCREAM;
1939     if (pm->op_pmflags & (PMf_MULTILINE|PMf_SINGLELINE)) {
1940         SAVEINT(PL_multiline);
1941         PL_multiline = pm->op_pmflags & PMf_MULTILINE;
1942     }
1943     orig = m = s;
1944     if (rx->reganch & RE_USE_INTUIT) {
1945         PL_bostr = orig;
1946         s = CALLREG_INTUIT_START(aTHX_ rx, TARG, s, strend, r_flags, NULL);
1947
1948         if (!s)
1949             goto nope;
1950         /* How to do it in subst? */
1951 /*      if ( (rx->reganch & ROPT_CHECK_ALL)
1952              && !PL_sawampersand
1953              && ((rx->reganch & ROPT_NOSCAN)
1954                  || !((rx->reganch & RE_INTUIT_TAIL)
1955                       && (r_flags & REXEC_SCREAM))))
1956             goto yup;
1957 */
1958     }
1959
1960     /* only replace once? */
1961     once = !(rpm->op_pmflags & PMf_GLOBAL);
1962
1963     /* known replacement string? */
1964     if (dstr) {
1965         c = SvPV(dstr, clen);
1966         doutf8 = DO_UTF8(dstr);
1967     }
1968     else {
1969         c = Nullch;
1970         doutf8 = FALSE;
1971     }
1972
1973     /* can do inplace substitution? */
1974     if (c && clen <= rx->minlen && (once || !(r_flags & REXEC_COPY_STR))
1975         && !(rx->reganch & ROPT_LOOKBEHIND_SEEN)) {
1976         if (!CALLREGEXEC(aTHX_ rx, s, strend, orig, 0, TARG, NULL,
1977                          r_flags | REXEC_CHECKED))
1978         {
1979             SPAGAIN;
1980             PUSHs(&PL_sv_no);
1981             LEAVE_SCOPE(oldsave);
1982             RETURN;
1983         }
1984         if (force_on_match) {
1985             force_on_match = 0;
1986             s = SvPV_force(TARG, len);
1987             goto force_it;
1988         }
1989         d = s;
1990         PL_curpm = pm;
1991         SvSCREAM_off(TARG);     /* disable possible screamer */
1992         if (once) {
1993             rxtainted |= RX_MATCH_TAINTED(rx);
1994             m = orig + rx->startp[0];
1995             d = orig + rx->endp[0];
1996             s = orig;
1997             if (m - s > strend - d) {  /* faster to shorten from end */
1998                 if (clen) {
1999                     Copy(c, m, clen, char);
2000                     m += clen;
2001                 }
2002                 i = strend - d;
2003                 if (i > 0) {
2004                     Move(d, m, i, char);
2005                     m += i;
2006                 }
2007                 *m = '\0';
2008                 SvCUR_set(TARG, m - s);
2009             }
2010             /*SUPPRESS 560*/
2011             else if ((i = m - s)) {     /* faster from front */
2012                 d -= clen;
2013                 m = d;
2014                 sv_chop(TARG, d-i);
2015                 s += i;
2016                 while (i--)
2017                     *--d = *--s;
2018                 if (clen)
2019                     Copy(c, m, clen, char);
2020             }
2021             else if (clen) {
2022                 d -= clen;
2023                 sv_chop(TARG, d);
2024                 Copy(c, d, clen, char);
2025             }
2026             else {
2027                 sv_chop(TARG, d);
2028             }
2029             TAINT_IF(rxtainted & 1);
2030             SPAGAIN;
2031             PUSHs(&PL_sv_yes);
2032         }
2033         else {
2034             do {
2035                 if (iters++ > maxiters)
2036                     DIE(aTHX_ "Substitution loop");
2037                 rxtainted |= RX_MATCH_TAINTED(rx);
2038                 m = rx->startp[0] + orig;
2039                 /*SUPPRESS 560*/
2040                 if ((i = m - s)) {
2041                     if (s != d)
2042                         Move(s, d, i, char);
2043                     d += i;
2044                 }
2045                 if (clen) {
2046                     Copy(c, d, clen, char);
2047                     d += clen;
2048                 }
2049                 s = rx->endp[0] + orig;
2050             } while (CALLREGEXEC(aTHX_ rx, s, strend, orig, s == m,
2051                                  TARG, NULL,
2052                                  /* don't match same null twice */
2053                                  REXEC_NOT_FIRST|REXEC_IGNOREPOS));
2054             if (s != d) {
2055                 i = strend - s;
2056                 SvCUR_set(TARG, d - SvPVX(TARG) + i);
2057                 Move(s, d, i+1, char);          /* include the NUL */
2058             }
2059             TAINT_IF(rxtainted & 1);
2060             SPAGAIN;
2061             PUSHs(sv_2mortal(newSViv((I32)iters)));
2062         }
2063         (void)SvPOK_only_UTF8(TARG);
2064         TAINT_IF(rxtainted);
2065         if (SvSMAGICAL(TARG)) {
2066             PUTBACK;
2067             mg_set(TARG);
2068             SPAGAIN;
2069         }
2070         SvTAINT(TARG);
2071         LEAVE_SCOPE(oldsave);
2072         RETURN;
2073     }
2074
2075     if (CALLREGEXEC(aTHX_ rx, s, strend, orig, 0, TARG, NULL,
2076                     r_flags | REXEC_CHECKED))
2077     {
2078         if (force_on_match) {
2079             force_on_match = 0;
2080             s = SvPV_force(TARG, len);
2081             goto force_it;
2082         }
2083         rxtainted |= RX_MATCH_TAINTED(rx);
2084         dstr = NEWSV(25, len);
2085         sv_setpvn(dstr, m, s-m);
2086         if (DO_UTF8(TARG))
2087             SvUTF8_on(dstr);
2088         PL_curpm = pm;
2089         if (!c) {
2090             register PERL_CONTEXT *cx;
2091             SPAGAIN;
2092             PUSHSUBST(cx);
2093             RETURNOP(cPMOP->op_pmreplroot);
2094         }
2095         r_flags |= REXEC_IGNOREPOS | REXEC_NOT_FIRST;
2096         do {
2097             if (iters++ > maxiters)
2098                 DIE(aTHX_ "Substitution loop");
2099             rxtainted |= RX_MATCH_TAINTED(rx);
2100             if (RX_MATCH_COPIED(rx) && rx->subbeg != orig) {
2101                 m = s;
2102                 s = orig;
2103                 orig = rx->subbeg;
2104                 s = orig + (m - s);
2105                 strend = s + (strend - m);
2106             }
2107             m = rx->startp[0] + orig;
2108             sv_catpvn(dstr, s, m-s);
2109             s = rx->endp[0] + orig;
2110             if (clen)
2111                 sv_catpvn(dstr, c, clen);
2112             if (once)
2113                 break;
2114         } while (CALLREGEXEC(aTHX_ rx, s, strend, orig, s == m,
2115                              TARG, NULL, r_flags));
2116         sv_catpvn(dstr, s, strend - s);
2117
2118         (void)SvOOK_off(TARG);
2119         Safefree(SvPVX(TARG));
2120         SvPVX(TARG) = SvPVX(dstr);
2121         SvCUR_set(TARG, SvCUR(dstr));
2122         SvLEN_set(TARG, SvLEN(dstr));
2123         doutf8 |= DO_UTF8(dstr);
2124         SvPVX(dstr) = 0;
2125         sv_free(dstr);
2126
2127         TAINT_IF(rxtainted & 1);
2128         SPAGAIN;
2129         PUSHs(sv_2mortal(newSViv((I32)iters)));
2130
2131         (void)SvPOK_only(TARG);
2132         if (doutf8)
2133             SvUTF8_on(TARG);
2134         TAINT_IF(rxtainted);
2135         SvSETMAGIC(TARG);
2136         SvTAINT(TARG);
2137         LEAVE_SCOPE(oldsave);
2138         RETURN;
2139     }
2140     goto ret_no;
2141
2142 nope:
2143 ret_no:
2144     SPAGAIN;
2145     PUSHs(&PL_sv_no);
2146     LEAVE_SCOPE(oldsave);
2147     RETURN;
2148 }
2149
2150 PP(pp_grepwhile)
2151 {
2152     dSP;
2153
2154     if (SvTRUEx(POPs))
2155         PL_stack_base[PL_markstack_ptr[-1]++] = PL_stack_base[*PL_markstack_ptr];
2156     ++*PL_markstack_ptr;
2157     LEAVE;                                      /* exit inner scope */
2158
2159     /* All done yet? */
2160     if (PL_stack_base + *PL_markstack_ptr > SP) {
2161         I32 items;
2162         I32 gimme = GIMME_V;
2163
2164         LEAVE;                                  /* exit outer scope */
2165         (void)POPMARK;                          /* pop src */
2166         items = --*PL_markstack_ptr - PL_markstack_ptr[-1];
2167         (void)POPMARK;                          /* pop dst */
2168         SP = PL_stack_base + POPMARK;           /* pop original mark */
2169         if (gimme == G_SCALAR) {
2170             dTARGET;
2171             XPUSHi(items);
2172         }
2173         else if (gimme == G_ARRAY)
2174             SP += items;
2175         RETURN;
2176     }
2177     else {
2178         SV *src;
2179
2180         ENTER;                                  /* enter inner scope */
2181         SAVEVPTR(PL_curpm);
2182
2183         src = PL_stack_base[*PL_markstack_ptr];
2184         SvTEMP_off(src);
2185         DEFSV = src;
2186
2187         RETURNOP(cLOGOP->op_other);
2188     }
2189 }
2190
2191 PP(pp_leavesub)
2192 {
2193     dSP;
2194     SV **mark;
2195     SV **newsp;
2196     PMOP *newpm;
2197     I32 gimme;
2198     register PERL_CONTEXT *cx;
2199     SV *sv;
2200
2201     POPBLOCK(cx,newpm);
2202
2203     TAINT_NOT;
2204     if (gimme == G_SCALAR) {
2205         MARK = newsp + 1;
2206         if (MARK <= SP) {
2207             if (cx->blk_sub.cv && CvDEPTH(cx->blk_sub.cv) > 1) {
2208                 if (SvTEMP(TOPs)) {
2209                     *MARK = SvREFCNT_inc(TOPs);
2210                     FREETMPS;
2211                     sv_2mortal(*MARK);
2212                 }
2213                 else {
2214                     sv = SvREFCNT_inc(TOPs);    /* FREETMPS could clobber it */
2215                     FREETMPS;
2216                     *MARK = sv_mortalcopy(sv);
2217                     SvREFCNT_dec(sv);
2218                 }
2219             }
2220             else
2221                 *MARK = SvTEMP(TOPs) ? TOPs : sv_mortalcopy(TOPs);
2222         }
2223         else {
2224             MEXTEND(MARK, 0);
2225             *MARK = &PL_sv_undef;
2226         }
2227         SP = MARK;
2228     }
2229     else if (gimme == G_ARRAY) {
2230         for (MARK = newsp + 1; MARK <= SP; MARK++) {
2231             if (!SvTEMP(*MARK)) {
2232                 *MARK = sv_mortalcopy(*MARK);
2233                 TAINT_NOT;      /* Each item is independent */
2234             }
2235         }
2236     }
2237     PUTBACK;
2238
2239     POPSUB(cx,sv);      /* Stack values are safe: release CV and @_ ... */
2240     PL_curpm = newpm;   /* ... and pop $1 et al */
2241
2242     LEAVE;
2243     LEAVESUB(sv);
2244     return pop_return();
2245 }
2246
2247 /* This duplicates the above code because the above code must not
2248  * get any slower by more conditions */
2249 PP(pp_leavesublv)
2250 {
2251     dSP;
2252     SV **mark;
2253     SV **newsp;
2254     PMOP *newpm;
2255     I32 gimme;
2256     register PERL_CONTEXT *cx;
2257     SV *sv;
2258
2259     POPBLOCK(cx,newpm);
2260
2261     TAINT_NOT;
2262
2263     if (cx->blk_sub.lval & OPpENTERSUB_INARGS) {
2264         /* We are an argument to a function or grep().
2265          * This kind of lvalueness was legal before lvalue
2266          * subroutines too, so be backward compatible:
2267          * cannot report errors.  */
2268
2269         /* Scalar context *is* possible, on the LHS of -> only,
2270          * as in f()->meth().  But this is not an lvalue. */
2271         if (gimme == G_SCALAR)
2272             goto temporise;
2273         if (gimme == G_ARRAY) {
2274             if (!CvLVALUE(cx->blk_sub.cv))
2275                 goto temporise_array;
2276             EXTEND_MORTAL(SP - newsp);
2277             for (mark = newsp + 1; mark <= SP; mark++) {
2278                 if (SvTEMP(*mark))
2279                     /* empty */ ;
2280                 else if (SvFLAGS(*mark) & (SVs_PADTMP | SVf_READONLY))
2281                     *mark = sv_mortalcopy(*mark);
2282                 else {
2283                     /* Can be a localized value subject to deletion. */
2284                     PL_tmps_stack[++PL_tmps_ix] = *mark;
2285                     (void)SvREFCNT_inc(*mark);
2286                 }
2287             }
2288         }
2289     }
2290     else if (cx->blk_sub.lval) {     /* Leave it as it is if we can. */
2291         /* Here we go for robustness, not for speed, so we change all
2292          * the refcounts so the caller gets a live guy. Cannot set
2293          * TEMP, so sv_2mortal is out of question. */
2294         if (!CvLVALUE(cx->blk_sub.cv)) {
2295             POPSUB(cx,sv);
2296             PL_curpm = newpm;
2297             LEAVE;
2298             LEAVESUB(sv);
2299             DIE(aTHX_ "Can't modify non-lvalue subroutine call");
2300         }
2301         if (gimme == G_SCALAR) {
2302             MARK = newsp + 1;
2303             EXTEND_MORTAL(1);
2304             if (MARK == SP) {
2305                 if (SvFLAGS(TOPs) & (SVs_TEMP | SVs_PADTMP | SVf_READONLY)) {
2306                     POPSUB(cx,sv);
2307                     PL_curpm = newpm;
2308                     LEAVE;
2309                     LEAVESUB(sv);
2310                     DIE(aTHX_ "Can't return a %s from lvalue subroutine",
2311                         SvREADONLY(TOPs) ? "readonly value" : "temporary");
2312                 }
2313                 else {                  /* Can be a localized value
2314                                          * subject to deletion. */
2315                     PL_tmps_stack[++PL_tmps_ix] = *mark;
2316                     (void)SvREFCNT_inc(*mark);
2317                 }
2318             }
2319             else {                      /* Should not happen? */
2320                 POPSUB(cx,sv);
2321                 PL_curpm = newpm;
2322                 LEAVE;
2323                 LEAVESUB(sv);
2324                 DIE(aTHX_ "%s returned from lvalue subroutine in scalar context",
2325                     (MARK > SP ? "Empty array" : "Array"));
2326             }
2327             SP = MARK;
2328         }
2329         else if (gimme == G_ARRAY) {
2330             EXTEND_MORTAL(SP - newsp);
2331             for (mark = newsp + 1; mark <= SP; mark++) {
2332                 if (*mark != &PL_sv_undef
2333                     && SvFLAGS(*mark) & (SVs_TEMP | SVs_PADTMP | SVf_READONLY)) {
2334                     /* Might be flattened array after $#array =  */
2335                     PUTBACK;
2336                     POPSUB(cx,sv);
2337                     PL_curpm = newpm;
2338                     LEAVE;
2339                     LEAVESUB(sv);
2340                     DIE(aTHX_ "Can't return a %s from lvalue subroutine",
2341                         SvREADONLY(TOPs) ? "readonly value" : "temporary");
2342                 }
2343                 else {
2344                     /* Can be a localized value subject to deletion. */
2345                     PL_tmps_stack[++PL_tmps_ix] = *mark;
2346                     (void)SvREFCNT_inc(*mark);
2347                 }
2348             }
2349         }
2350     }
2351     else {
2352         if (gimme == G_SCALAR) {
2353           temporise:
2354             MARK = newsp + 1;
2355             if (MARK <= SP) {
2356                 if (cx->blk_sub.cv && CvDEPTH(cx->blk_sub.cv) > 1) {
2357                     if (SvTEMP(TOPs)) {
2358                         *MARK = SvREFCNT_inc(TOPs);
2359                         FREETMPS;
2360                         sv_2mortal(*MARK);
2361                     }
2362                     else {
2363                         sv = SvREFCNT_inc(TOPs); /* FREETMPS could clobber it */
2364                         FREETMPS;
2365                         *MARK = sv_mortalcopy(sv);
2366                         SvREFCNT_dec(sv);
2367                     }
2368                 }
2369                 else
2370                     *MARK = SvTEMP(TOPs) ? TOPs : sv_mortalcopy(TOPs);
2371             }
2372             else {
2373                 MEXTEND(MARK, 0);
2374                 *MARK = &PL_sv_undef;
2375             }
2376             SP = MARK;
2377         }
2378         else if (gimme == G_ARRAY) {
2379           temporise_array:
2380             for (MARK = newsp + 1; MARK <= SP; MARK++) {
2381                 if (!SvTEMP(*MARK)) {
2382                     *MARK = sv_mortalcopy(*MARK);
2383                     TAINT_NOT;  /* Each item is independent */
2384                 }
2385             }
2386         }
2387     }
2388     PUTBACK;
2389
2390     POPSUB(cx,sv);      /* Stack values are safe: release CV and @_ ... */
2391     PL_curpm = newpm;   /* ... and pop $1 et al */
2392
2393     LEAVE;
2394     LEAVESUB(sv);
2395     return pop_return();
2396 }
2397
2398
2399 STATIC CV *
2400 S_get_db_sub(pTHX_ SV **svp, CV *cv)
2401 {
2402     SV *dbsv = GvSV(PL_DBsub);
2403
2404     if (!PERLDB_SUB_NN) {
2405         GV *gv = CvGV(cv);
2406
2407         save_item(dbsv);
2408         if ( (CvFLAGS(cv) & (CVf_ANON | CVf_CLONED))
2409              || strEQ(GvNAME(gv), "END")
2410              || ((GvCV(gv) != cv) && /* Could be imported, and old sub redefined. */
2411                  !( (SvTYPE(*svp) == SVt_PVGV) && (GvCV((GV*)*svp) == cv)
2412                     && (gv = (GV*)*svp) ))) {
2413             /* Use GV from the stack as a fallback. */
2414             /* GV is potentially non-unique, or contain different CV. */
2415             SV *tmp = newRV((SV*)cv);
2416             sv_setsv(dbsv, tmp);
2417             SvREFCNT_dec(tmp);
2418         }
2419         else {
2420             gv_efullname3(dbsv, gv, Nullch);
2421         }
2422     }
2423     else {
2424         (void)SvUPGRADE(dbsv, SVt_PVIV);
2425         (void)SvIOK_on(dbsv);
2426         SAVEIV(SvIVX(dbsv));
2427         SvIVX(dbsv) = PTR2IV(cv);       /* Do it the quickest way  */
2428     }
2429
2430     if (CvXSUB(cv))
2431         PL_curcopdb = PL_curcop;
2432     cv = GvCV(PL_DBsub);
2433     return cv;
2434 }
2435
2436 PP(pp_entersub)
2437 {
2438     dSP; dPOPss;
2439     GV *gv;
2440     HV *stash;
2441     register CV *cv;
2442     register PERL_CONTEXT *cx;
2443     I32 gimme;
2444     bool hasargs = (PL_op->op_flags & OPf_STACKED) != 0;
2445
2446     if (!sv)
2447         DIE(aTHX_ "Not a CODE reference");
2448     switch (SvTYPE(sv)) {
2449     default:
2450         if (!SvROK(sv)) {
2451             char *sym;
2452             STRLEN n_a;
2453
2454             if (sv == &PL_sv_yes) {             /* unfound import, ignore */
2455                 if (hasargs)
2456                     SP = PL_stack_base + POPMARK;
2457                 RETURN;
2458             }
2459             if (SvGMAGICAL(sv)) {
2460                 mg_get(sv);
2461                 if (SvROK(sv))
2462                     goto got_rv;
2463                 sym = SvPOKp(sv) ? SvPVX(sv) : Nullch;
2464             }
2465             else
2466                 sym = SvPV(sv, n_a);
2467             if (!sym)
2468                 DIE(aTHX_ PL_no_usym, "a subroutine");
2469             if (PL_op->op_private & HINT_STRICT_REFS)
2470                 DIE(aTHX_ PL_no_symref, sym, "a subroutine");
2471             cv = get_cv(sym, TRUE);
2472             break;
2473         }
2474   got_rv:
2475         {
2476             SV **sp = &sv;              /* Used in tryAMAGICunDEREF macro. */
2477             tryAMAGICunDEREF(to_cv);
2478         }
2479         cv = (CV*)SvRV(sv);
2480         if (SvTYPE(cv) == SVt_PVCV)
2481             break;
2482         /* FALL THROUGH */
2483     case SVt_PVHV:
2484     case SVt_PVAV:
2485         DIE(aTHX_ "Not a CODE reference");
2486     case SVt_PVCV:
2487         cv = (CV*)sv;
2488         break;
2489     case SVt_PVGV:
2490         if (!(cv = GvCVu((GV*)sv)))
2491             cv = sv_2cv(sv, &stash, &gv, FALSE);
2492         if (!cv) {
2493             ENTER;
2494             SAVETMPS;
2495             goto try_autoload;
2496         }
2497         break;
2498     }
2499
2500     ENTER;
2501     SAVETMPS;
2502
2503   retry:
2504     if (!CvROOT(cv) && !CvXSUB(cv)) {
2505         GV* autogv;
2506         SV* sub_name;
2507
2508         /* anonymous or undef'd function leaves us no recourse */
2509         if (CvANON(cv) || !(gv = CvGV(cv)))
2510             DIE(aTHX_ "Undefined subroutine called");
2511
2512         /* autoloaded stub? */
2513         if (cv != GvCV(gv)) {
2514             cv = GvCV(gv);
2515         }
2516         /* should call AUTOLOAD now? */
2517         else {
2518 try_autoload:
2519             if ((autogv = gv_autoload4(GvSTASH(gv), GvNAME(gv), GvNAMELEN(gv),
2520                                    FALSE)))
2521             {
2522                 cv = GvCV(autogv);
2523             }
2524             /* sorry */
2525             else {
2526                 sub_name = sv_newmortal();
2527                 gv_efullname3(sub_name, gv, Nullch);
2528                 DIE(aTHX_ "Undefined subroutine &%s called", SvPVX(sub_name));
2529             }
2530         }
2531         if (!cv)
2532             DIE(aTHX_ "Not a CODE reference");
2533         goto retry;
2534     }
2535
2536     gimme = GIMME_V;
2537     if ((PL_op->op_private & OPpENTERSUB_DB) && GvCV(PL_DBsub) && !CvNODEBUG(cv)) {
2538         cv = get_db_sub(&sv, cv);
2539         if (!cv)
2540             DIE(aTHX_ "No DBsub routine");
2541     }
2542
2543 #ifdef USE_5005THREADS
2544     /*
2545      * First we need to check if the sub or method requires locking.
2546      * If so, we gain a lock on the CV, the first argument or the
2547      * stash (for static methods), as appropriate. This has to be
2548      * inline because for FAKE_THREADS, COND_WAIT inlines code to
2549      * reschedule by returning a new op.
2550      */
2551     MUTEX_LOCK(CvMUTEXP(cv));
2552     if (CvFLAGS(cv) & CVf_LOCKED) {
2553         MAGIC *mg;
2554         if (CvFLAGS(cv) & CVf_METHOD) {
2555             if (SP > PL_stack_base + TOPMARK)
2556                 sv = *(PL_stack_base + TOPMARK + 1);
2557             else {
2558                 AV *av = (AV*)PL_curpad[0];
2559                 if (hasargs || !av || AvFILLp(av) < 0
2560                     || !(sv = AvARRAY(av)[0]))
2561                 {
2562                     MUTEX_UNLOCK(CvMUTEXP(cv));
2563                     DIE(aTHX_ "no argument for locked method call");
2564                 }
2565             }
2566             if (SvROK(sv))
2567                 sv = SvRV(sv);
2568             else {
2569                 STRLEN len;
2570                 char *stashname = SvPV(sv, len);
2571                 sv = (SV*)gv_stashpvn(stashname, len, TRUE);
2572             }
2573         }
2574         else {
2575             sv = (SV*)cv;
2576         }
2577         MUTEX_UNLOCK(CvMUTEXP(cv));
2578         mg = condpair_magic(sv);
2579         MUTEX_LOCK(MgMUTEXP(mg));
2580         if (MgOWNER(mg) == thr)
2581             MUTEX_UNLOCK(MgMUTEXP(mg));
2582         else {
2583             while (MgOWNER(mg))
2584                 COND_WAIT(MgOWNERCONDP(mg), MgMUTEXP(mg));
2585             MgOWNER(mg) = thr;
2586             DEBUG_S(PerlIO_printf(Perl_debug_log, "%p: pp_entersub lock %p\n",
2587                                   thr, sv));
2588             MUTEX_UNLOCK(MgMUTEXP(mg));
2589             SAVEDESTRUCTOR_X(Perl_unlock_condpair, sv);
2590         }
2591         MUTEX_LOCK(CvMUTEXP(cv));
2592     }
2593     /*
2594      * Now we have permission to enter the sub, we must distinguish
2595      * four cases. (0) It's an XSUB (in which case we don't care
2596      * about ownership); (1) it's ours already (and we're recursing);
2597      * (2) it's free (but we may already be using a cached clone);
2598      * (3) another thread owns it. Case (1) is easy: we just use it.
2599      * Case (2) means we look for a clone--if we have one, use it
2600      * otherwise grab ownership of cv. Case (3) means we look for a
2601      * clone (for non-XSUBs) and have to create one if we don't
2602      * already have one.
2603      * Why look for a clone in case (2) when we could just grab
2604      * ownership of cv straight away? Well, we could be recursing,
2605      * i.e. we originally tried to enter cv while another thread
2606      * owned it (hence we used a clone) but it has been freed up
2607      * and we're now recursing into it. It may or may not be "better"
2608      * to use the clone but at least CvDEPTH can be trusted.
2609      */
2610     if (CvOWNER(cv) == thr || CvXSUB(cv))
2611         MUTEX_UNLOCK(CvMUTEXP(cv));
2612     else {
2613         /* Case (2) or (3) */
2614         SV **svp;
2615
2616         /*
2617          * XXX Might it be better to release CvMUTEXP(cv) while we
2618          * do the hv_fetch? We might find someone has pinched it
2619          * when we look again, in which case we would be in case
2620          * (3) instead of (2) so we'd have to clone. Would the fact
2621          * that we released the mutex more quickly make up for this?
2622          */
2623         if ((svp = hv_fetch(thr->cvcache, (char *)cv, sizeof(cv), FALSE)))
2624         {
2625             /* We already have a clone to use */
2626             MUTEX_UNLOCK(CvMUTEXP(cv));
2627             cv = *(CV**)svp;
2628             DEBUG_S(PerlIO_printf(Perl_debug_log,
2629                                   "entersub: %p already has clone %p:%s\n",
2630                                   thr, cv, SvPEEK((SV*)cv)));
2631             CvOWNER(cv) = thr;
2632             SvREFCNT_inc(cv);
2633             if (CvDEPTH(cv) == 0)
2634                 SAVEDESTRUCTOR_X(unset_cvowner, (void*) cv);
2635         }
2636         else {
2637             /* (2) => grab ownership of cv. (3) => make clone */
2638             if (!CvOWNER(cv)) {
2639                 CvOWNER(cv) = thr;
2640                 SvREFCNT_inc(cv);
2641                 MUTEX_UNLOCK(CvMUTEXP(cv));
2642                 DEBUG_S(PerlIO_printf(Perl_debug_log,
2643                             "entersub: %p grabbing %p:%s in stash %s\n",
2644                             thr, cv, SvPEEK((SV*)cv), CvSTASH(cv) ?
2645                                 HvNAME(CvSTASH(cv)) : "(none)"));
2646             }
2647             else {
2648                 /* Make a new clone. */
2649                 CV *clonecv;
2650                 SvREFCNT_inc(cv); /* don't let it vanish from under us */
2651                 MUTEX_UNLOCK(CvMUTEXP(cv));
2652                 DEBUG_S((PerlIO_printf(Perl_debug_log,
2653                                        "entersub: %p cloning %p:%s\n",
2654                                        thr, cv, SvPEEK((SV*)cv))));
2655                 /*
2656                  * We're creating a new clone so there's no race
2657                  * between the original MUTEX_UNLOCK and the
2658                  * SvREFCNT_inc since no one will be trying to undef
2659                  * it out from underneath us. At least, I don't think
2660                  * there's a race...
2661                  */
2662                 clonecv = cv_clone(cv);
2663                 SvREFCNT_dec(cv); /* finished with this */
2664                 hv_store(thr->cvcache, (char*)cv, sizeof(cv), (SV*)clonecv,0);
2665                 CvOWNER(clonecv) = thr;
2666                 cv = clonecv;
2667                 SvREFCNT_inc(cv);
2668             }
2669             DEBUG_S(if (CvDEPTH(cv) != 0)
2670                         PerlIO_printf(Perl_debug_log, "depth %ld != 0\n",
2671                                      CvDEPTH(cv)));
2672             SAVEDESTRUCTOR_X(unset_cvowner, (void*) cv);
2673         }
2674     }
2675 #endif /* USE_5005THREADS */
2676
2677     if (CvXSUB(cv)) {
2678 #ifdef PERL_XSUB_OLDSTYLE
2679         if (CvOLDSTYLE(cv)) {
2680             I32 (*fp3)(int,int,int);
2681             dMARK;
2682             register I32 items = SP - MARK;
2683                                         /* We dont worry to copy from @_. */
2684             while (SP > mark) {
2685                 SP[1] = SP[0];
2686                 SP--;
2687             }
2688             PL_stack_sp = mark + 1;
2689             fp3 = (I32(*)(int,int,int))CvXSUB(cv);
2690             items = (*fp3)(CvXSUBANY(cv).any_i32,
2691                            MARK - PL_stack_base + 1,
2692                            items);
2693             PL_stack_sp = PL_stack_base + items;
2694         }
2695         else
2696 #endif /* PERL_XSUB_OLDSTYLE */
2697         {
2698             I32 markix = TOPMARK;
2699
2700             PUTBACK;
2701
2702             if (!hasargs) {
2703                 /* Need to copy @_ to stack. Alternative may be to
2704                  * switch stack to @_, and copy return values
2705                  * back. This would allow popping @_ in XSUB, e.g.. XXXX */
2706                 AV* av;
2707                 I32 items;
2708 #ifdef USE_5005THREADS
2709                 av = (AV*)PL_curpad[0];
2710 #else
2711                 av = GvAV(PL_defgv);
2712 #endif /* USE_5005THREADS */
2713                 items = AvFILLp(av) + 1;   /* @_ is not tieable */
2714
2715                 if (items) {
2716                     /* Mark is at the end of the stack. */
2717                     EXTEND(SP, items);
2718                     Copy(AvARRAY(av), SP + 1, items, SV*);
2719                     SP += items;
2720                     PUTBACK ;
2721                 }
2722             }
2723             /* We assume first XSUB in &DB::sub is the called one. */
2724             if (PL_curcopdb) {
2725                 SAVEVPTR(PL_curcop);
2726                 PL_curcop = PL_curcopdb;
2727                 PL_curcopdb = NULL;
2728             }
2729             /* Do we need to open block here? XXXX */
2730             (void)(*CvXSUB(cv))(aTHX_ cv);
2731
2732             /* Enforce some sanity in scalar context. */
2733             if (gimme == G_SCALAR && ++markix != PL_stack_sp - PL_stack_base ) {
2734                 if (markix > PL_stack_sp - PL_stack_base)
2735                     *(PL_stack_base + markix) = &PL_sv_undef;
2736                 else
2737                     *(PL_stack_base + markix) = *PL_stack_sp;
2738                 PL_stack_sp = PL_stack_base + markix;
2739             }
2740         }
2741         LEAVE;
2742         return NORMAL;
2743     }
2744     else {
2745         dMARK;
2746         register I32 items = SP - MARK;
2747         AV* padlist = CvPADLIST(cv);
2748         SV** svp = AvARRAY(padlist);
2749         push_return(PL_op->op_next);
2750         PUSHBLOCK(cx, CXt_SUB, MARK);
2751         PUSHSUB(cx);
2752         CvDEPTH(cv)++;
2753         /* XXX This would be a natural place to set C<PL_compcv = cv> so
2754          * that eval'' ops within this sub know the correct lexical space.
2755          * Owing the speed considerations, we choose to search for the cv
2756          * in doeval() instead.
2757          */
2758         if (CvDEPTH(cv) < 2)
2759             (void)SvREFCNT_inc(cv);
2760         else {  /* save temporaries on recursion? */
2761             PERL_STACK_OVERFLOW_CHECK();
2762             if (CvDEPTH(cv) > AvFILLp(padlist)) {
2763                 AV *av;
2764                 AV *newpad = newAV();
2765                 SV **oldpad = AvARRAY(svp[CvDEPTH(cv)-1]);
2766                 I32 ix = AvFILLp((AV*)svp[1]);
2767                 I32 names_fill = AvFILLp((AV*)svp[0]);
2768                 svp = AvARRAY(svp[0]);
2769                 for ( ;ix > 0; ix--) {
2770                     if (names_fill >= ix && svp[ix] != &PL_sv_undef) {
2771                         char *name = SvPVX(svp[ix]);
2772                         if ((SvFLAGS(svp[ix]) & SVf_FAKE) /* outer lexical? */
2773                             || *name == '&')              /* anonymous code? */
2774                         {
2775                             av_store(newpad, ix, SvREFCNT_inc(oldpad[ix]));
2776                         }
2777                         else {                          /* our own lexical */
2778                             if (*name == '@')
2779                                 av_store(newpad, ix, sv = (SV*)newAV());
2780                             else if (*name == '%')
2781                                 av_store(newpad, ix, sv = (SV*)newHV());
2782                             else
2783                                 av_store(newpad, ix, sv = NEWSV(0,0));
2784                             SvPADMY_on(sv);
2785                         }
2786                     }
2787                     else if (IS_PADGV(oldpad[ix]) || IS_PADCONST(oldpad[ix])) {
2788                         av_store(newpad, ix, sv = SvREFCNT_inc(oldpad[ix]));
2789                     }
2790                     else {
2791                         av_store(newpad, ix, sv = NEWSV(0,0));
2792                         SvPADTMP_on(sv);
2793                     }
2794                 }
2795                 av = newAV();           /* will be @_ */
2796                 av_extend(av, 0);
2797                 av_store(newpad, 0, (SV*)av);
2798                 AvFLAGS(av) = AVf_REIFY;
2799                 av_store(padlist, CvDEPTH(cv), (SV*)newpad);
2800                 AvFILLp(padlist) = CvDEPTH(cv);
2801                 svp = AvARRAY(padlist);
2802             }
2803         }
2804 #ifdef USE_5005THREADS
2805         if (!hasargs) {
2806             AV* av = (AV*)PL_curpad[0];
2807
2808             items = AvFILLp(av) + 1;
2809             if (items) {
2810                 /* Mark is at the end of the stack. */
2811                 EXTEND(SP, items);
2812                 Copy(AvARRAY(av), SP + 1, items, SV*);
2813                 SP += items;
2814                 PUTBACK ;
2815             }
2816         }
2817 #endif /* USE_5005THREADS */
2818         SAVEVPTR(PL_curpad);
2819         PL_curpad = AvARRAY((AV*)svp[CvDEPTH(cv)]);
2820 #ifndef USE_5005THREADS
2821         if (hasargs)
2822 #endif /* USE_5005THREADS */
2823         {
2824             AV* av;
2825             SV** ary;
2826
2827 #if 0
2828             DEBUG_S(PerlIO_printf(Perl_debug_log,
2829                                   "%p entersub preparing @_\n", thr));
2830 #endif
2831             av = (AV*)PL_curpad[0];
2832             if (AvREAL(av)) {
2833                 /* @_ is normally not REAL--this should only ever
2834                  * happen when DB::sub() calls things that modify @_ */
2835                 av_clear(av);
2836                 AvREAL_off(av);
2837                 AvREIFY_on(av);
2838             }
2839 #ifndef USE_5005THREADS
2840             cx->blk_sub.savearray = GvAV(PL_defgv);
2841             GvAV(PL_defgv) = (AV*)SvREFCNT_inc(av);
2842 #endif /* USE_5005THREADS */
2843             cx->blk_sub.oldcurpad = PL_curpad;
2844             cx->blk_sub.argarray = av;
2845             ++MARK;
2846
2847             if (items > AvMAX(av) + 1) {
2848                 ary = AvALLOC(av);
2849                 if (AvARRAY(av) != ary) {
2850                     AvMAX(av) += AvARRAY(av) - AvALLOC(av);
2851                     SvPVX(av) = (char*)ary;
2852                 }
2853                 if (items > AvMAX(av) + 1) {
2854                     AvMAX(av) = items - 1;
2855                     Renew(ary,items,SV*);
2856                     AvALLOC(av) = ary;
2857                     SvPVX(av) = (char*)ary;
2858                 }
2859             }
2860             Copy(MARK,AvARRAY(av),items,SV*);
2861             AvFILLp(av) = items - 1;
2862
2863             while (items--) {
2864                 if (*MARK)
2865                     SvTEMP_off(*MARK);
2866                 MARK++;
2867             }
2868         }
2869         /* warning must come *after* we fully set up the context
2870          * stuff so that __WARN__ handlers can safely dounwind()
2871          * if they want to
2872          */
2873         if (CvDEPTH(cv) == 100 && ckWARN(WARN_RECURSION)
2874             && !(PERLDB_SUB && cv == GvCV(PL_DBsub)))
2875             sub_crush_depth(cv);
2876 #if 0
2877         DEBUG_S(PerlIO_printf(Perl_debug_log,
2878                               "%p entersub returning %p\n", thr, CvSTART(cv)));
2879 #endif
2880         RETURNOP(CvSTART(cv));
2881     }
2882 }
2883
2884 void
2885 Perl_sub_crush_depth(pTHX_ CV *cv)
2886 {
2887     if (CvANON(cv))
2888         Perl_warner(aTHX_ packWARN(WARN_RECURSION), "Deep recursion on anonymous subroutine");
2889     else {
2890         SV* tmpstr = sv_newmortal();
2891         gv_efullname3(tmpstr, CvGV(cv), Nullch);
2892         Perl_warner(aTHX_ packWARN(WARN_RECURSION), "Deep recursion on subroutine \"%s\"",
2893                 SvPVX(tmpstr));
2894     }
2895 }
2896
2897 PP(pp_aelem)
2898 {
2899     dSP;
2900     SV** svp;
2901     SV* elemsv = POPs;
2902     IV elem = SvIV(elemsv);
2903     AV* av = (AV*)POPs;
2904     U32 lval = PL_op->op_flags & OPf_MOD || LVRET;
2905     U32 defer = (PL_op->op_private & OPpLVAL_DEFER) && (elem > AvFILL(av));
2906     SV *sv;
2907
2908     if (SvROK(elemsv) && !SvGAMAGIC(elemsv) && ckWARN(WARN_MISC))
2909         Perl_warner(aTHX_ packWARN(WARN_MISC), "Use of reference \"%s\" as array index", SvPV_nolen(elemsv));
2910     if (elem > 0)
2911         elem -= PL_curcop->cop_arybase;
2912     if (SvTYPE(av) != SVt_PVAV)
2913         RETPUSHUNDEF;
2914     svp = av_fetch(av, elem, lval && !defer);
2915     if (lval) {
2916         if (!svp || *svp == &PL_sv_undef) {
2917             SV* lv;
2918             if (!defer)
2919                 DIE(aTHX_ PL_no_aelem, elem);
2920             lv = sv_newmortal();
2921             sv_upgrade(lv, SVt_PVLV);
2922             LvTYPE(lv) = 'y';
2923             sv_magic(lv, Nullsv, PERL_MAGIC_defelem, Nullch, 0);
2924             LvTARG(lv) = SvREFCNT_inc(av);
2925             LvTARGOFF(lv) = elem;
2926             LvTARGLEN(lv) = 1;
2927             PUSHs(lv);
2928             RETURN;
2929         }
2930         if (PL_op->op_private & OPpLVAL_INTRO)
2931             save_aelem(av, elem, svp);
2932         else if (PL_op->op_private & OPpDEREF)
2933             vivify_ref(*svp, PL_op->op_private & OPpDEREF);
2934     }
2935     sv = (svp ? *svp : &PL_sv_undef);
2936     if (!lval && SvGMAGICAL(sv))        /* see note in pp_helem() */
2937         sv = sv_mortalcopy(sv);
2938     PUSHs(sv);
2939     RETURN;
2940 }
2941
2942 void
2943 Perl_vivify_ref(pTHX_ SV *sv, U32 to_what)
2944 {
2945     if (SvGMAGICAL(sv))
2946         mg_get(sv);
2947     if (!SvOK(sv)) {
2948         if (SvREADONLY(sv))
2949             Perl_croak(aTHX_ PL_no_modify);
2950         if (SvTYPE(sv) < SVt_RV)
2951             sv_upgrade(sv, SVt_RV);
2952         else if (SvTYPE(sv) >= SVt_PV) {
2953             (void)SvOOK_off(sv);
2954             Safefree(SvPVX(sv));
2955             SvLEN(sv) = SvCUR(sv) = 0;
2956         }
2957         switch (to_what) {
2958         case OPpDEREF_SV:
2959             SvRV(sv) = NEWSV(355,0);
2960             break;
2961         case OPpDEREF_AV:
2962             SvRV(sv) = (SV*)newAV();
2963             break;
2964         case OPpDEREF_HV:
2965             SvRV(sv) = (SV*)newHV();
2966             break;
2967         }
2968         SvROK_on(sv);
2969         SvSETMAGIC(sv);
2970     }
2971 }
2972
2973 PP(pp_method)
2974 {
2975     dSP;
2976     SV* sv = TOPs;
2977
2978     if (SvROK(sv)) {
2979         SV* rsv = SvRV(sv);
2980         if (SvTYPE(rsv) == SVt_PVCV) {
2981             SETs(rsv);
2982             RETURN;
2983         }
2984     }
2985
2986     SETs(method_common(sv, Null(U32*)));
2987     RETURN;
2988 }
2989
2990 PP(pp_method_named)
2991 {
2992     dSP;
2993     SV* sv = cSVOP->op_sv;
2994     U32 hash = SvUVX(sv);
2995
2996     XPUSHs(method_common(sv, &hash));
2997     RETURN;
2998 }
2999
3000 STATIC SV *
3001 S_method_common(pTHX_ SV* meth, U32* hashp)
3002 {
3003     SV* sv;
3004     SV* ob;
3005     GV* gv;
3006     HV* stash;
3007     char* name;
3008     STRLEN namelen;
3009     char* packname = 0;
3010     STRLEN packlen;
3011
3012     name = SvPV(meth, namelen);
3013     sv = *(PL_stack_base + TOPMARK + 1);
3014
3015     if (!sv)
3016         Perl_croak(aTHX_ "Can't call method \"%s\" on an undefined value", name);
3017
3018     if (SvGMAGICAL(sv))
3019         mg_get(sv);
3020     if (SvROK(sv))
3021         ob = (SV*)SvRV(sv);
3022     else {
3023         GV* iogv;
3024
3025         /* this isn't a reference */
3026         packname = Nullch;
3027         if (!SvOK(sv) ||
3028             !(packname = SvPV(sv, packlen)) ||
3029             !(iogv = gv_fetchpv(packname, FALSE, SVt_PVIO)) ||
3030             !(ob=(SV*)GvIO(iogv)))
3031         {
3032             /* this isn't the name of a filehandle either */
3033             if (!packname ||
3034                 ((UTF8_IS_START(*packname) && DO_UTF8(sv))
3035                     ? !isIDFIRST_utf8((U8*)packname)
3036                     : !isIDFIRST(*packname)
3037                 ))
3038             {
3039                 Perl_croak(aTHX_ "Can't call method \"%s\" %s", name,
3040                            SvOK(sv) ? "without a package or object reference"
3041                                     : "on an undefined value");
3042             }
3043             /* assume it's a package name */
3044             stash = gv_stashpvn(packname, packlen, FALSE);
3045             goto fetch;
3046         }
3047         /* it _is_ a filehandle name -- replace with a reference */
3048         *(PL_stack_base + TOPMARK + 1) = sv_2mortal(newRV((SV*)iogv));
3049     }
3050
3051     /* if we got here, ob should be a reference or a glob */
3052     if (!ob || !(SvOBJECT(ob)
3053                  || (SvTYPE(ob) == SVt_PVGV && (ob = (SV*)GvIO((GV*)ob))
3054                      && SvOBJECT(ob))))
3055     {
3056         Perl_croak(aTHX_ "Can't call method \"%s\" on unblessed reference",
3057                    name);
3058     }
3059
3060     stash = SvSTASH(ob);
3061
3062   fetch:
3063     /* NOTE: stash may be null, hope hv_fetch_ent and
3064        gv_fetchmethod can cope (it seems they can) */
3065
3066     /* shortcut for simple names */
3067     if (hashp) {
3068         HE* he = hv_fetch_ent(stash, meth, 0, *hashp);
3069         if (he) {
3070             gv = (GV*)HeVAL(he);
3071             if (isGV(gv) && GvCV(gv) &&
3072                 (!GvCVGEN(gv) || GvCVGEN(gv) == PL_sub_generation))
3073                 return (SV*)GvCV(gv);
3074         }
3075     }
3076
3077     gv = gv_fetchmethod(stash, name);
3078
3079     if (!gv) {
3080         /* This code tries to figure out just what went wrong with
3081            gv_fetchmethod.  It therefore needs to duplicate a lot of
3082            the internals of that function.  We can't move it inside
3083            Perl_gv_fetchmethod_autoload(), however, since that would
3084            cause UNIVERSAL->can("NoSuchPackage::foo") to croak, and we
3085            don't want that.
3086         */
3087         char* leaf = name;
3088         char* sep = Nullch;
3089         char* p;
3090
3091         for (p = name; *p; p++) {
3092             if (*p == '\'')
3093                 sep = p, leaf = p + 1;
3094             else if (*p == ':' && *(p + 1) == ':')
3095                 sep = p, leaf = p + 2;
3096         }
3097         if (!sep || ((sep - name) == 5 && strnEQ(name, "SUPER", 5))) {
3098             /* the method name is unqualified or starts with SUPER:: */
3099             packname = sep ? CopSTASHPV(PL_curcop) :
3100                 stash ? HvNAME(stash) : packname;
3101             packlen = strlen(packname);
3102         }
3103         else {
3104             /* the method name is qualified */
3105             packname = name;
3106             packlen = sep - name;
3107         }
3108
3109         /* we're relying on gv_fetchmethod not autovivifying the stash */
3110         if (gv_stashpvn(packname, packlen, FALSE)) {
3111             Perl_croak(aTHX_
3112                        "Can't locate object method \"%s\" via package \"%.*s\"",
3113                        leaf, (int)packlen, packname);
3114         }
3115         else {
3116             Perl_croak(aTHX_
3117                        "Can't locate object method \"%s\" via package \"%.*s\""
3118                        " (perhaps you forgot to load \"%.*s\"?)",
3119                        leaf, (int)packlen, packname, (int)packlen, packname);
3120         }
3121     }
3122     return isGV(gv) ? (SV*)GvCV(gv) : (SV*)gv;
3123 }
3124
3125 #ifdef USE_5005THREADS
3126 static void
3127 unset_cvowner(pTHX_ void *cvarg)
3128 {
3129     register CV* cv = (CV *) cvarg;
3130
3131     DEBUG_S((PerlIO_printf(Perl_debug_log, "%p unsetting CvOWNER of %p:%s\n",
3132                            thr, cv, SvPEEK((SV*)cv))));
3133     MUTEX_LOCK(CvMUTEXP(cv));
3134     DEBUG_S(if (CvDEPTH(cv) != 0)
3135                 PerlIO_printf(Perl_debug_log, "depth %ld != 0\n",
3136                              CvDEPTH(cv)));
3137     assert(thr == CvOWNER(cv));
3138     CvOWNER(cv) = 0;
3139     MUTEX_UNLOCK(CvMUTEXP(cv));
3140     SvREFCNT_dec(cv);
3141 }
3142 #endif /* USE_5005THREADS */