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