pp_hot.c

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