pp_hot.c

   1 /*    pp_hot.c
   2  *
   3  *    Copyright (c) 1991-2001, Larry Wall
   4  *
   5  *    You may distribute under the terms of either the GNU General Public
   6  *    License or the Artistic License, as specified in the README file.
   7  *
   8  */
   9
  10 /*
  11  * Then he heard Merry change the note, and up went the Horn-cry of Buckland,
  12  * shaking the air.
  13  *
  14  *            Awake!  Awake!  Fear, Fire, Foes!  Awake!
  15  *                     Fire, Foes!  Awake!
  16  */
  17
  18 #include "EXTERN.h"
  19 #define PERL_IN_PP_HOT_C
  20 #include "perl.h"
  21
  22 /* Hot code. */
  23
  24 #ifdef USE_THREADS
  25 static void unset_cvowner(pTHXo_ void *cvarg);
  26 #endif /* USE_THREADS */
  27
  28 PP(pp_const)
  29 {
  30     dSP;
  31     XPUSHs(cSVOP_sv);
  32     RETURN;
  33 }
  34
  35 PP(pp_nextstate)
  36 {
  37     PL_curcop = (COP*)PL_op;
  38     TAINT_NOT;          /* Each statement is presumed innocent */
  39     PL_stack_sp = PL_stack_base + cxstack[cxstack_ix].blk_oldsp;
  40     FREETMPS;
  41     return NORMAL;
  42 }
  43
  44 PP(pp_gvsv)
  45 {
  46     dSP;
  47     EXTEND(SP,1);
  48     if (PL_op->op_private & OPpLVAL_INTRO)
  49         PUSHs(save_scalar(cGVOP_gv));
  50     else
  51         PUSHs(GvSV(cGVOP_gv));
  52     RETURN;
  53 }
  54
  55 PP(pp_null)
  56 {
  57     return NORMAL;
  58 }
  59
  60 PP(pp_setstate)
  61 {
  62     PL_curcop = (COP*)PL_op;
  63     return NORMAL;
  64 }
  65
  66 PP(pp_pushmark)
  67 {
  68     PUSHMARK(PL_stack_sp);
  69     return NORMAL;
  70 }
  71
  72 PP(pp_stringify)
  73 {
  74     dSP; dTARGET;
  75     STRLEN len;
  76     char *s;
  77     s = SvPV(TOPs,len);
  78     sv_setpvn(TARG,s,len);
  79     if (SvUTF8(TOPs))
  80         SvUTF8_on(TARG);
  81     else
  82         SvUTF8_off(TARG);
  83     SETTARG;
  84     RETURN;
  85 }
  86
  87 PP(pp_gv)
  88 {
  89     dSP;
  90     XPUSHs((SV*)cGVOP_gv);
  91     RETURN;
  92 }
  93
  94 PP(pp_and)
  95 {
  96     dSP;
  97     if (!SvTRUE(TOPs))
  98         RETURN;
  99     else {
 100         --SP;
 101         RETURNOP(cLOGOP->op_other);
 102     }
 103 }
 104
 105 PP(pp_sassign)
 106 {
 107     dSP; dPOPTOPssrl;
 108
 109     if (PL_op->op_private & OPpASSIGN_BACKWARDS) {
 110         SV *temp;
 111         temp = left; left = right; right = temp;
 112     }
 113     if (PL_tainting && PL_tainted && !SvTAINTED(left))
 114         TAINT_NOT;
 115     SvSetMagicSV(right, left);
 116     SETs(right);
 117     RETURN;
 118 }
 119
 120 PP(pp_cond_expr)
 121 {
 122     dSP;
 123     if (SvTRUEx(POPs))
 124         RETURNOP(cLOGOP->op_other);
 125     else
 126         RETURNOP(cLOGOP->op_next);
 127 }
 128
 129 PP(pp_unstack)
 130 {
 131     I32 oldsave;
 132     TAINT_NOT;          /* Each statement is presumed innocent */
 133     PL_stack_sp = PL_stack_base + cxstack[cxstack_ix].blk_oldsp;
 134     FREETMPS;
 135     oldsave = PL_scopestack[PL_scopestack_ix - 1];
 136     LEAVE_SCOPE(oldsave);
 137     return NORMAL;
 138 }
 139
 140 PP(pp_concat)
 141 {
 142   dSP; dATARGET; tryAMAGICbin(concat,opASSIGN);
 143   {
 144     dPOPTOPssrl;
 145     SV* rcopy = Nullsv;
 146
 147     if (SvGMAGICAL(left))
 148         mg_get(left);
 149     if (TARG == right && SvGMAGICAL(right))
 150         mg_get(right);
 151
 152     if (TARG == right && left != right)
 153         /* Clone since otherwise we cannot prepend. */
 154         rcopy = sv_2mortal(newSVsv(right));
 155
 156     if (TARG != left)
 157         sv_setsv(TARG, left);
 158
 159     if (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     dSP; dTARGET;
 199     XPUSHs(TARG);
 200     if (PL_op->op_flags & OPf_MOD) {
 201         if (PL_op->op_private & OPpLVAL_INTRO)
 202             SAVECLEARSV(PL_curpad[PL_op->op_targ]);
 203         else if (PL_op->op_private & OPpDEREF) {
 204             PUTBACK;
 205             vivify_ref(PL_curpad[PL_op->op_targ], PL_op->op_private & OPpDEREF);
 206             SPAGAIN;
 207         }
 208     }
 209     RETURN;
 210 }
 211
 212 PP(pp_readline)
 213 {
 214     tryAMAGICunTARGET(iter, 0);
 215     PL_last_in_gv = (GV*)(*PL_stack_sp--);
 216     if (SvTYPE(PL_last_in_gv) != SVt_PVGV) {
 217         if (SvROK(PL_last_in_gv) && SvTYPE(SvRV(PL_last_in_gv)) == SVt_PVGV)
 218             PL_last_in_gv = (GV*)SvRV(PL_last_in_gv);
 219         else {
 220             dSP;
 221             XPUSHs((SV*)PL_last_in_gv);
 222             PUTBACK;
 223             pp_rv2gv();
 224             PL_last_in_gv = (GV*)(*PL_stack_sp--);
 225         }
 226     }
 227     return do_readline();
 228 }
 229
 230 PP(pp_eq)
 231 {
 232     dSP; tryAMAGICbinSET(eq,0);
 233 #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     dSP;
 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     dSP;
 323     if (SvTRUE(TOPs))
 324         RETURN;
 325     else {
 326         --SP;
 327         RETURNOP(cLOGOP->op_other);
 328     }
 329 }
 330
 331 PP(pp_add)
 332 {
 333     dSP; 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     dSP;
 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     dSP; 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     dSP;
 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     dSP; 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     dSP; 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     dSP; 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     dSP;
 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     dSP;
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     dSP; 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 ((!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) && IoTYPE(io) == IoTYPE_WRONLY) {
1463             report_evil_fh(PL_last_in_gv, io, OP_phoney_OUTPUT_ONLY);
1464         }
1465     }
1466     if (!fp) {
1467         if (ckWARN2(WARN_GLOB, WARN_CLOSED)
1468                 && (!io || !(IoFLAGS(io) & IOf_START))) {
1469             if (type == OP_GLOB)
1470                 Perl_warner(aTHX_ WARN_GLOB,
1471                             "glob failed (can't start child: %s)",
1472                             Strerror(errno));
1473             else
1474                 report_evil_fh(PL_last_in_gv, io, PL_op->op_type);
1475         }
1476         if (gimme == G_SCALAR) {
1477             (void)SvOK_off(TARG);
1478             PUSHTARG;
1479         }
1480         RETURN;
1481     }
1482   have_fp:
1483     if (gimme == G_SCALAR) {
1484         sv = TARG;
1485         if (SvROK(sv))
1486             sv_unref(sv);
1487         (void)SvUPGRADE(sv, SVt_PV);
1488         tmplen = SvLEN(sv);     /* remember if already alloced */
1489         if (!tmplen)
1490             Sv_Grow(sv, 80);    /* try short-buffering it */
1491         if (type == OP_RCATLINE)
1492             offset = SvCUR(sv);
1493         else
1494             offset = 0;
1495     }
1496     else {
1497         sv = sv_2mortal(NEWSV(57, 80));
1498         offset = 0;
1499     }
1500
1501     /* This should not be marked tainted if the fp is marked clean */
1502 #define MAYBE_TAINT_LINE(io, sv) \
1503     if (!(IoFLAGS(io) & IOf_UNTAINT)) { \
1504         TAINT;                          \
1505         SvTAINTED_on(sv);               \
1506     }
1507
1508 /* delay EOF state for a snarfed empty file */
1509 #define SNARF_EOF(gimme,rs,io,sv) \
1510     (gimme != G_SCALAR || SvCUR(sv)                                     \
1511      || (IoFLAGS(io) & IOf_NOLINE) || !RsSNARF(rs))
1512
1513     for (;;) {
1514         PUTBACK;
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                 SPAGAIN;
1536                 PUSHTARG;
1537             }
1538             MAYBE_TAINT_LINE(io, sv);
1539             RETURN;
1540         }
1541         MAYBE_TAINT_LINE(io, sv);
1542         IoLINES(io)++;
1543         IoFLAGS(io) |= IOf_NOLINE;
1544         SvSETMAGIC(sv);
1545         SPAGAIN;
1546         XPUSHs(sv);
1547         if (type == OP_GLOB) {
1548             char *tmps;
1549
1550             if (SvCUR(sv) > 0 && SvCUR(PL_rs) > 0) {
1551                 tmps = SvEND(sv) - 1;
1552                 if (*tmps == *SvPVX(PL_rs)) {
1553                     *tmps = '\0';
1554                     SvCUR(sv)--;
1555                 }
1556             }
1557             for (tmps = SvPVX(sv); *tmps; tmps++)
1558                 if (!isALPHA(*tmps) && !isDIGIT(*tmps) &&
1559                     strchr("$&*(){}[]'\";\\|?<>~`", *tmps))
1560                         break;
1561             if (*tmps && PerlLIO_lstat(SvPVX(sv), &PL_statbuf) < 0) {
1562                 (void)POPs;             /* Unmatched wildcard?  Chuck it... */
1563                 continue;
1564             }
1565         }
1566         if (gimme == G_ARRAY) {
1567             if (SvLEN(sv) - SvCUR(sv) > 20) {
1568                 SvLEN_set(sv, SvCUR(sv)+1);
1569                 Renew(SvPVX(sv), SvLEN(sv), char);
1570             }
1571             sv = sv_2mortal(NEWSV(58, 80));
1572             continue;
1573         }
1574         else if (gimme == G_SCALAR && !tmplen && SvLEN(sv) - SvCUR(sv) > 80) {
1575             /* try to reclaim a bit of scalar space (only on 1st alloc) */
1576             if (SvCUR(sv) < 60)
1577                 SvLEN_set(sv, 80);
1578             else
1579                 SvLEN_set(sv, SvCUR(sv)+40);    /* allow some slop */
1580             Renew(SvPVX(sv), SvLEN(sv), char);
1581         }
1582         RETURN;
1583     }
1584 }
1585
1586 PP(pp_enter)
1587 {
1588     dSP;
1589     register PERL_CONTEXT *cx;
1590     I32 gimme = OP_GIMME(PL_op, -1);
1591
1592     if (gimme == -1) {
1593         if (cxstack_ix >= 0)
1594             gimme = cxstack[cxstack_ix].blk_gimme;
1595         else
1596             gimme = G_SCALAR;
1597     }
1598
1599     ENTER;
1600
1601     SAVETMPS;
1602     PUSHBLOCK(cx, CXt_BLOCK, SP);
1603
1604     RETURN;
1605 }
1606
1607 PP(pp_helem)
1608 {
1609     dSP;
1610     HE* he;
1611     SV **svp;
1612     SV *keysv = POPs;
1613     HV *hv = (HV*)POPs;
1614     U32 lval = PL_op->op_flags & OPf_MOD || LVRET;
1615     U32 defer = PL_op->op_private & OPpLVAL_DEFER;
1616     SV *sv;
1617     U32 hash = (SvFAKE(keysv) && SvREADONLY(keysv)) ? SvUVX(keysv) : 0;
1618     I32 preeminent;
1619
1620     if (SvTYPE(hv) == SVt_PVHV) {
1621         if (PL_op->op_private & OPpLVAL_INTRO)
1622             preeminent = SvRMAGICAL(hv) ? 1 : hv_exists_ent(hv, keysv, 0);
1623         he = hv_fetch_ent(hv, keysv, lval && !defer, hash);
1624         svp = he ? &HeVAL(he) : 0;
1625     }
1626     else if (SvTYPE(hv) == SVt_PVAV) {
1627         if (PL_op->op_private & OPpLVAL_INTRO)
1628             DIE(aTHX_ "Can't localize pseudo-hash element");
1629         svp = avhv_fetch_ent((AV*)hv, keysv, lval && !defer, hash);
1630     }
1631     else {
1632         RETPUSHUNDEF;
1633     }
1634     if (lval) {
1635         if (!svp || *svp == &PL_sv_undef) {
1636             SV* lv;
1637             SV* key2;
1638             if (!defer) {
1639                 STRLEN n_a;
1640                 DIE(aTHX_ PL_no_helem, SvPV(keysv, n_a));
1641             }
1642             lv = sv_newmortal();
1643             sv_upgrade(lv, SVt_PVLV);
1644             LvTYPE(lv) = 'y';
1645             sv_magic(lv, key2 = newSVsv(keysv), 'y', Nullch, 0);
1646             SvREFCNT_dec(key2); /* sv_magic() increments refcount */
1647             LvTARG(lv) = SvREFCNT_inc(hv);
1648             LvTARGLEN(lv) = 1;
1649             PUSHs(lv);
1650             RETURN;
1651         }
1652         if (PL_op->op_private & OPpLVAL_INTRO) {
1653             if (HvNAME(hv) && isGV(*svp))
1654                 save_gp((GV*)*svp, !(PL_op->op_flags & OPf_SPECIAL));
1655             else {
1656                 if (!preeminent) {
1657                     STRLEN keylen;
1658                     char *key = SvPV(keysv, keylen);
1659                     SAVEDELETE(hv, savepvn(key,keylen), keylen);
1660                 } else
1661                     save_helem(hv, keysv, svp);
1662             }
1663         }
1664         else if (PL_op->op_private & OPpDEREF)
1665             vivify_ref(*svp, PL_op->op_private & OPpDEREF);
1666     }
1667     sv = (svp ? *svp : &PL_sv_undef);
1668     /* This makes C<local $tied{foo} = $tied{foo}> possible.
1669      * Pushing the magical RHS on to the stack is useless, since
1670      * that magic is soon destined to be misled by the local(),
1671      * and thus the later pp_sassign() will fail to mg_get() the
1672      * old value.  This should also cure problems with delayed
1673      * mg_get()s.  GSAR 98-07-03 */
1674     if (!lval && SvGMAGICAL(sv))
1675         sv = sv_mortalcopy(sv);
1676     PUSHs(sv);
1677     RETURN;
1678 }
1679
1680 PP(pp_leave)
1681 {
1682     dSP;
1683     register PERL_CONTEXT *cx;
1684     register SV **mark;
1685     SV **newsp;
1686     PMOP *newpm;
1687     I32 gimme;
1688
1689     if (PL_op->op_flags & OPf_SPECIAL) {
1690         cx = &cxstack[cxstack_ix];
1691         cx->blk_oldpm = PL_curpm;       /* fake block should preserve $1 et al */
1692     }
1693
1694     POPBLOCK(cx,newpm);
1695
1696     gimme = OP_GIMME(PL_op, -1);
1697     if (gimme == -1) {
1698         if (cxstack_ix >= 0)
1699             gimme = cxstack[cxstack_ix].blk_gimme;
1700         else
1701             gimme = G_SCALAR;
1702     }
1703
1704     TAINT_NOT;
1705     if (gimme == G_VOID)
1706         SP = newsp;
1707     else if (gimme == G_SCALAR) {
1708         MARK = newsp + 1;
1709         if (MARK <= SP)
1710             if (SvFLAGS(TOPs) & (SVs_PADTMP|SVs_TEMP))
1711                 *MARK = TOPs;
1712             else
1713                 *MARK = sv_mortalcopy(TOPs);
1714         else {
1715             MEXTEND(mark,0);
1716             *MARK = &PL_sv_undef;
1717         }
1718         SP = MARK;
1719     }
1720     else if (gimme == G_ARRAY) {
1721         /* in case LEAVE wipes old return values */
1722         for (mark = newsp + 1; mark <= SP; mark++) {
1723             if (!(SvFLAGS(*mark) & (SVs_PADTMP|SVs_TEMP))) {
1724                 *mark = sv_mortalcopy(*mark);
1725                 TAINT_NOT;      /* Each item is independent */
1726             }
1727         }
1728     }
1729     PL_curpm = newpm;   /* Don't pop $1 et al till now */
1730
1731     LEAVE;
1732
1733     RETURN;
1734 }
1735
1736 PP(pp_iter)
1737 {
1738     dSP;
1739     register PERL_CONTEXT *cx;
1740     SV* sv;
1741     AV* av;
1742     SV **itersvp;
1743
1744     EXTEND(SP, 1);
1745     cx = &cxstack[cxstack_ix];
1746     if (CxTYPE(cx) != CXt_LOOP)
1747         DIE(aTHX_ "panic: pp_iter");
1748
1749     itersvp = CxITERVAR(cx);
1750     av = cx->blk_loop.iterary;
1751     if (SvTYPE(av) != SVt_PVAV) {
1752         /* iterate ($min .. $max) */
1753         if (cx->blk_loop.iterlval) {
1754             /* string increment */
1755             register SV* cur = cx->blk_loop.iterlval;
1756             STRLEN maxlen;
1757             char *max = SvPV((SV*)av, maxlen);
1758             if (!SvNIOK(cur) && SvCUR(cur) <= maxlen) {
1759 #ifndef USE_THREADS                       /* don't risk potential race */
1760                 if (SvREFCNT(*itersvp) == 1 && !SvMAGICAL(*itersvp)) {
1761                     /* safe to reuse old SV */
1762                     sv_setsv(*itersvp, cur);
1763                 }
1764                 else
1765 #endif
1766                 {
1767                     /* we need a fresh SV every time so that loop body sees a
1768                      * completely new SV for closures/references to work as
1769                      * they used to */
1770                     SvREFCNT_dec(*itersvp);
1771                     *itersvp = newSVsv(cur);
1772                 }
1773                 if (strEQ(SvPVX(cur), max))
1774                     sv_setiv(cur, 0); /* terminate next time */
1775                 else
1776                     sv_inc(cur);
1777                 RETPUSHYES;
1778             }
1779             RETPUSHNO;
1780         }
1781         /* integer increment */
1782         if (cx->blk_loop.iterix > cx->blk_loop.itermax)
1783             RETPUSHNO;
1784
1785 #ifndef USE_THREADS                       /* don't risk potential race */
1786         if (SvREFCNT(*itersvp) == 1 && !SvMAGICAL(*itersvp)) {
1787             /* safe to reuse old SV */
1788             sv_setiv(*itersvp, cx->blk_loop.iterix++);
1789         }
1790         else
1791 #endif
1792         {
1793             /* we need a fresh SV every time so that loop body sees a
1794              * completely new SV for closures/references to work as they
1795              * used to */
1796             SvREFCNT_dec(*itersvp);
1797             *itersvp = newSViv(cx->blk_loop.iterix++);
1798         }
1799         RETPUSHYES;
1800     }
1801
1802     /* iterate array */
1803     if (cx->blk_loop.iterix >= (av == PL_curstack ? cx->blk_oldsp : AvFILL(av)))
1804         RETPUSHNO;
1805
1806     SvREFCNT_dec(*itersvp);
1807
1808     if ((sv = SvMAGICAL(av)
1809               ? *av_fetch(av, ++cx->blk_loop.iterix, FALSE)
1810               : AvARRAY(av)[++cx->blk_loop.iterix]))
1811         SvTEMP_off(sv);
1812     else
1813         sv = &PL_sv_undef;
1814     if (av != PL_curstack && SvIMMORTAL(sv)) {
1815         SV *lv = cx->blk_loop.iterlval;
1816         if (lv && SvREFCNT(lv) > 1) {
1817             SvREFCNT_dec(lv);
1818             lv = Nullsv;
1819         }
1820         if (lv)
1821             SvREFCNT_dec(LvTARG(lv));
1822         else {
1823             lv = cx->blk_loop.iterlval = NEWSV(26, 0);
1824             sv_upgrade(lv, SVt_PVLV);
1825             LvTYPE(lv) = 'y';
1826             sv_magic(lv, Nullsv, 'y', Nullch, 0);
1827         }
1828         LvTARG(lv) = SvREFCNT_inc(av);
1829         LvTARGOFF(lv) = cx->blk_loop.iterix;
1830         LvTARGLEN(lv) = (STRLEN)UV_MAX;
1831         sv = (SV*)lv;
1832     }
1833
1834     *itersvp = SvREFCNT_inc(sv);
1835     RETPUSHYES;
1836 }
1837
1838 PP(pp_subst)
1839 {
1840     dSP; dTARG;
1841     register PMOP *pm = cPMOP;
1842     PMOP *rpm = pm;
1843     register SV *dstr;
1844     register char *s;
1845     char *strend;
1846     register char *m;
1847     char *c;
1848     register char *d;
1849     STRLEN clen;
1850     I32 iters = 0;
1851     I32 maxiters;
1852     register I32 i;
1853     bool once;
1854     bool rxtainted;
1855     char *orig;
1856     I32 r_flags;
1857     register REGEXP *rx = pm->op_pmregexp;
1858     STRLEN len;
1859     int force_on_match = 0;
1860     I32 oldsave = PL_savestack_ix;
1861     bool do_utf8;
1862     STRLEN slen;
1863
1864     /* known replacement string? */
1865     dstr = (pm->op_pmflags & PMf_CONST) ? POPs : Nullsv;
1866     if (PL_op->op_flags & OPf_STACKED)
1867         TARG = POPs;
1868     else {
1869         TARG = DEFSV;
1870         EXTEND(SP,1);
1871     }
1872     PL_reg_sv = TARG;
1873     do_utf8 = DO_UTF8(PL_reg_sv);
1874     if (SvFAKE(TARG) && SvREADONLY(TARG))
1875         sv_force_normal(TARG);
1876     if (SvREADONLY(TARG)
1877         || (SvTYPE(TARG) > SVt_PVLV
1878             && !(SvTYPE(TARG) == SVt_PVGV && SvFAKE(TARG))))
1879         DIE(aTHX_ PL_no_modify);
1880     PUTBACK;
1881
1882     s = SvPV(TARG, len);
1883     if (!SvPOKp(TARG) || SvTYPE(TARG) == SVt_PVGV)
1884         force_on_match = 1;
1885     rxtainted = ((pm->op_pmdynflags & PMdf_TAINTED) ||
1886                  (PL_tainted && (pm->op_pmflags & PMf_RETAINT)));
1887     if (PL_tainted)
1888         rxtainted |= 2;
1889     TAINT_NOT;
1890
1891   force_it:
1892     if (!pm || !s)
1893         DIE(aTHX_ "panic: pp_subst");
1894
1895     strend = s + len;
1896     slen = do_utf8 ? utf8_length((U8*)s, (U8*)strend) : len;
1897     maxiters = 2 * slen + 10;   /* We can match twice at each
1898                                    position, once with zero-length,
1899                                    second time with non-zero. */
1900
1901     if (!rx->prelen && PL_curpm) {
1902         pm = PL_curpm;
1903         rx = pm->op_pmregexp;
1904     }
1905     r_flags = (rx->nparens || SvTEMP(TARG) || PL_sawampersand)
1906                 ? REXEC_COPY_STR : 0;
1907     if (SvSCREAM(TARG))
1908         r_flags |= REXEC_SCREAM;
1909     if (pm->op_pmflags & (PMf_MULTILINE|PMf_SINGLELINE)) {
1910         SAVEINT(PL_multiline);
1911         PL_multiline = pm->op_pmflags & PMf_MULTILINE;
1912     }
1913     orig = m = s;
1914     if (rx->reganch & RE_USE_INTUIT) {
1915         s = CALLREG_INTUIT_START(aTHX_ rx, TARG, s, strend, r_flags, NULL);
1916
1917         if (!s)
1918             goto nope;
1919         /* How to do it in subst? */
1920 /*      if ( (rx->reganch & ROPT_CHECK_ALL)
1921              && !PL_sawampersand
1922              && ((rx->reganch & ROPT_NOSCAN)
1923                  || !((rx->reganch & RE_INTUIT_TAIL)
1924                       && (r_flags & REXEC_SCREAM))))
1925             goto yup;
1926 */
1927     }
1928
1929     /* only replace once? */
1930     once = !(rpm->op_pmflags & PMf_GLOBAL);
1931
1932     /* known replacement string? */
1933     c = dstr ? SvPV(dstr, clen) : Nullch;
1934
1935     /* can do inplace substitution? */
1936     if (c && clen <= rx->minlen && (once || !(r_flags & REXEC_COPY_STR))
1937         && !(rx->reganch & ROPT_LOOKBEHIND_SEEN)) {
1938         if (!CALLREGEXEC(aTHX_ rx, s, strend, orig, 0, TARG, NULL,
1939                          r_flags | REXEC_CHECKED))
1940         {
1941             SPAGAIN;
1942             PUSHs(&PL_sv_no);
1943             LEAVE_SCOPE(oldsave);
1944             RETURN;
1945         }
1946         if (force_on_match) {
1947             force_on_match = 0;
1948             s = SvPV_force(TARG, len);
1949             goto force_it;
1950         }
1951         d = s;
1952         PL_curpm = pm;
1953         SvSCREAM_off(TARG);     /* disable possible screamer */
1954         if (once) {
1955             rxtainted |= RX_MATCH_TAINTED(rx);
1956             m = orig + rx->startp[0];
1957             d = orig + rx->endp[0];
1958             s = orig;
1959             if (m - s > strend - d) {  /* faster to shorten from end */
1960                 if (clen) {
1961                     Copy(c, m, clen, char);
1962                     m += clen;
1963                 }
1964                 i = strend - d;
1965                 if (i > 0) {
1966                     Move(d, m, i, char);
1967                     m += i;
1968                 }
1969                 *m = '\0';
1970                 SvCUR_set(TARG, m - s);
1971             }
1972             /*SUPPRESS 560*/
1973             else if ((i = m - s)) {     /* faster from front */
1974                 d -= clen;
1975                 m = d;
1976                 sv_chop(TARG, d-i);
1977                 s += i;
1978                 while (i--)
1979                     *--d = *--s;
1980                 if (clen)
1981                     Copy(c, m, clen, char);
1982             }
1983             else if (clen) {
1984                 d -= clen;
1985                 sv_chop(TARG, d);
1986                 Copy(c, d, clen, char);
1987             }
1988             else {
1989                 sv_chop(TARG, d);
1990             }
1991             TAINT_IF(rxtainted & 1);
1992             SPAGAIN;
1993             PUSHs(&PL_sv_yes);
1994         }
1995         else {
1996             do {
1997                 if (iters++ > maxiters)
1998                     DIE(aTHX_ "Substitution loop");
1999                 rxtainted |= RX_MATCH_TAINTED(rx);
2000                 m = rx->startp[0] + orig;
2001                 /*SUPPRESS 560*/
2002                 if ((i = m - s)) {
2003                     if (s != d)
2004                         Move(s, d, i, char);
2005                     d += i;
2006                 }
2007                 if (clen) {
2008                     Copy(c, d, clen, char);
2009                     d += clen;
2010                 }
2011                 s = rx->endp[0] + orig;
2012             } while (CALLREGEXEC(aTHX_ rx, s, strend, orig, s == m,
2013                                  TARG, NULL,
2014                                  /* don't match same null twice */
2015                                  REXEC_NOT_FIRST|REXEC_IGNOREPOS));
2016             if (s != d) {
2017                 i = strend - s;
2018                 SvCUR_set(TARG, d - SvPVX(TARG) + i);
2019                 Move(s, d, i+1, char);          /* include the NUL */
2020             }
2021             TAINT_IF(rxtainted & 1);
2022             SPAGAIN;
2023             PUSHs(sv_2mortal(newSViv((I32)iters)));
2024         }
2025         (void)SvPOK_only_UTF8(TARG);
2026         TAINT_IF(rxtainted);
2027         if (SvSMAGICAL(TARG)) {
2028             PUTBACK;
2029             mg_set(TARG);
2030             SPAGAIN;
2031         }
2032         SvTAINT(TARG);
2033         LEAVE_SCOPE(oldsave);
2034         RETURN;
2035     }
2036
2037     if (CALLREGEXEC(aTHX_ rx, s, strend, orig, 0, TARG, NULL,
2038                     r_flags | REXEC_CHECKED))
2039     {
2040         bool isutf8;
2041
2042         if (force_on_match) {
2043             force_on_match = 0;
2044             s = SvPV_force(TARG, len);
2045             goto force_it;
2046         }
2047         rxtainted |= RX_MATCH_TAINTED(rx);
2048         dstr = NEWSV(25, len);
2049         sv_setpvn(dstr, m, s-m);
2050         if (DO_UTF8(TARG))
2051             SvUTF8_on(dstr);
2052         PL_curpm = pm;
2053         if (!c) {
2054             register PERL_CONTEXT *cx;
2055             SPAGAIN;
2056             PUSHSUBST(cx);
2057             RETURNOP(cPMOP->op_pmreplroot);
2058         }
2059         r_flags |= REXEC_IGNOREPOS | REXEC_NOT_FIRST;
2060         do {
2061             if (iters++ > maxiters)
2062                 DIE(aTHX_ "Substitution loop");
2063             rxtainted |= RX_MATCH_TAINTED(rx);
2064             if (RX_MATCH_COPIED(rx) && rx->subbeg != orig) {
2065                 m = s;
2066                 s = orig;
2067                 orig = rx->subbeg;
2068                 s = orig + (m - s);
2069                 strend = s + (strend - m);
2070             }
2071             m = rx->startp[0] + orig;
2072             sv_catpvn(dstr, s, m-s);
2073             s = rx->endp[0] + orig;
2074             if (clen)
2075                 sv_catpvn(dstr, c, clen);
2076             if (once)
2077                 break;
2078         } while (CALLREGEXEC(aTHX_ rx, s, strend, orig, s == m,
2079                              TARG, NULL, r_flags));
2080         sv_catpvn(dstr, s, strend - s);
2081
2082         (void)SvOOK_off(TARG);
2083         Safefree(SvPVX(TARG));
2084         SvPVX(TARG) = SvPVX(dstr);
2085         SvCUR_set(TARG, SvCUR(dstr));
2086         SvLEN_set(TARG, SvLEN(dstr));
2087         isutf8 = DO_UTF8(dstr);
2088         SvPVX(dstr) = 0;
2089         sv_free(dstr);
2090
2091         TAINT_IF(rxtainted & 1);
2092         SPAGAIN;
2093         PUSHs(sv_2mortal(newSViv((I32)iters)));
2094
2095         (void)SvPOK_only(TARG);
2096         if (isutf8)
2097             SvUTF8_on(TARG);
2098         TAINT_IF(rxtainted);
2099         SvSETMAGIC(TARG);
2100         SvTAINT(TARG);
2101         LEAVE_SCOPE(oldsave);
2102         RETURN;
2103     }
2104     goto ret_no;
2105
2106 nope:
2107 ret_no:
2108     SPAGAIN;
2109     PUSHs(&PL_sv_no);
2110     LEAVE_SCOPE(oldsave);
2111     RETURN;
2112 }
2113
2114 PP(pp_grepwhile)
2115 {
2116     dSP;
2117
2118     if (SvTRUEx(POPs))
2119         PL_stack_base[PL_markstack_ptr[-1]++] = PL_stack_base[*PL_markstack_ptr];
2120     ++*PL_markstack_ptr;
2121     LEAVE;                                      /* exit inner scope */
2122
2123     /* All done yet? */
2124     if (PL_stack_base + *PL_markstack_ptr > SP) {
2125         I32 items;
2126         I32 gimme = GIMME_V;
2127
2128         LEAVE;                                  /* exit outer scope */
2129         (void)POPMARK;                          /* pop src */
2130         items = --*PL_markstack_ptr - PL_markstack_ptr[-1];
2131         (void)POPMARK;                          /* pop dst */
2132         SP = PL_stack_base + POPMARK;           /* pop original mark */
2133         if (gimme == G_SCALAR) {
2134             dTARGET;
2135             XPUSHi(items);
2136         }
2137         else if (gimme == G_ARRAY)
2138             SP += items;
2139         RETURN;
2140     }
2141     else {
2142         SV *src;
2143
2144         ENTER;                                  /* enter inner scope */
2145         SAVEVPTR(PL_curpm);
2146
2147         src = PL_stack_base[*PL_markstack_ptr];
2148         SvTEMP_off(src);
2149         DEFSV = src;
2150
2151         RETURNOP(cLOGOP->op_other);
2152     }
2153 }
2154
2155 PP(pp_leavesub)
2156 {
2157     dSP;
2158     SV **mark;
2159     SV **newsp;
2160     PMOP *newpm;
2161     I32 gimme;
2162     register PERL_CONTEXT *cx;
2163     SV *sv;
2164
2165     POPBLOCK(cx,newpm);
2166
2167     TAINT_NOT;
2168     if (gimme == G_SCALAR) {
2169         MARK = newsp + 1;
2170         if (MARK <= SP) {
2171             if (cx->blk_sub.cv && CvDEPTH(cx->blk_sub.cv) > 1) {
2172                 if (SvTEMP(TOPs)) {
2173                     *MARK = SvREFCNT_inc(TOPs);
2174                     FREETMPS;
2175                     sv_2mortal(*MARK);
2176                 }
2177                 else {
2178                     sv = SvREFCNT_inc(TOPs);    /* FREETMPS could clobber it */
2179                     FREETMPS;
2180                     *MARK = sv_mortalcopy(sv);
2181                     SvREFCNT_dec(sv);
2182                 }
2183             }
2184             else
2185                 *MARK = SvTEMP(TOPs) ? TOPs : sv_mortalcopy(TOPs);
2186         }
2187         else {
2188             MEXTEND(MARK, 0);
2189             *MARK = &PL_sv_undef;
2190         }
2191         SP = MARK;
2192     }
2193     else if (gimme == G_ARRAY) {
2194         for (MARK = newsp + 1; MARK <= SP; MARK++) {
2195             if (!SvTEMP(*MARK)) {
2196                 *MARK = sv_mortalcopy(*MARK);
2197                 TAINT_NOT;      /* Each item is independent */
2198             }
2199         }
2200     }
2201     PUTBACK;
2202
2203     POPSUB(cx,sv);      /* Stack values are safe: release CV and @_ ... */
2204     PL_curpm = newpm;   /* ... and pop $1 et al */
2205
2206     LEAVE;
2207     LEAVESUB(sv);
2208     return pop_return();
2209 }
2210
2211 /* This duplicates the above code because the above code must not
2212  * get any slower by more conditions */
2213 PP(pp_leavesublv)
2214 {
2215     dSP;
2216     SV **mark;
2217     SV **newsp;
2218     PMOP *newpm;
2219     I32 gimme;
2220     register PERL_CONTEXT *cx;
2221     SV *sv;
2222
2223     POPBLOCK(cx,newpm);
2224
2225     TAINT_NOT;
2226
2227     if (cx->blk_sub.lval & OPpENTERSUB_INARGS) {
2228         /* We are an argument to a function or grep().
2229          * This kind of lvalueness was legal before lvalue
2230          * subroutines too, so be backward compatible:
2231          * cannot report errors.  */
2232
2233         /* Scalar context *is* possible, on the LHS of -> only,
2234          * as in f()->meth().  But this is not an lvalue. */
2235         if (gimme == G_SCALAR)
2236             goto temporise;
2237         if (gimme == G_ARRAY) {
2238             if (!CvLVALUE(cx->blk_sub.cv))
2239                 goto temporise_array;
2240             EXTEND_MORTAL(SP - newsp);
2241             for (mark = newsp + 1; mark <= SP; mark++) {
2242                 if (SvTEMP(*mark))
2243                     /* empty */ ;
2244                 else if (SvFLAGS(*mark) & (SVs_PADTMP | SVf_READONLY))
2245                     *mark = sv_mortalcopy(*mark);
2246                 else {
2247                     /* Can be a localized value subject to deletion. */
2248                     PL_tmps_stack[++PL_tmps_ix] = *mark;
2249                     (void)SvREFCNT_inc(*mark);
2250                 }
2251             }
2252         }
2253     }
2254     else if (cx->blk_sub.lval) {     /* Leave it as it is if we can. */
2255         /* Here we go for robustness, not for speed, so we change all
2256          * the refcounts so the caller gets a live guy. Cannot set
2257          * TEMP, so sv_2mortal is out of question. */
2258         if (!CvLVALUE(cx->blk_sub.cv)) {
2259             POPSUB(cx,sv);
2260             PL_curpm = newpm;
2261             LEAVE;
2262             LEAVESUB(sv);
2263             DIE(aTHX_ "Can't modify non-lvalue subroutine call");
2264         }
2265         if (gimme == G_SCALAR) {
2266             MARK = newsp + 1;
2267             EXTEND_MORTAL(1);
2268             if (MARK == SP) {
2269                 if (SvFLAGS(TOPs) & (SVs_TEMP | SVs_PADTMP | SVf_READONLY)) {
2270                     POPSUB(cx,sv);
2271                     PL_curpm = newpm;
2272                     LEAVE;
2273                     LEAVESUB(sv);
2274                     DIE(aTHX_ "Can't return a %s from lvalue subroutine",
2275                         SvREADONLY(TOPs) ? "readonly value" : "temporary");
2276                 }
2277                 else {                  /* Can be a localized value
2278                                          * subject to deletion. */
2279                     PL_tmps_stack[++PL_tmps_ix] = *mark;
2280                     (void)SvREFCNT_inc(*mark);
2281                 }
2282             }
2283             else {                      /* Should not happen? */
2284                 POPSUB(cx,sv);
2285                 PL_curpm = newpm;
2286                 LEAVE;
2287                 LEAVESUB(sv);
2288                 DIE(aTHX_ "%s returned from lvalue subroutine in scalar context",
2289                     (MARK > SP ? "Empty array" : "Array"));
2290             }
2291             SP = MARK;
2292         }
2293         else if (gimme == G_ARRAY) {
2294             EXTEND_MORTAL(SP - newsp);
2295             for (mark = newsp + 1; mark <= SP; mark++) {
2296                 if (SvFLAGS(*mark) & (SVs_TEMP | SVs_PADTMP | SVf_READONLY)) {
2297                     /* Might be flattened array after $#array =  */
2298                     PUTBACK;
2299                     POPSUB(cx,sv);
2300                     PL_curpm = newpm;
2301                     LEAVE;
2302                     LEAVESUB(sv);
2303                     DIE(aTHX_ "Can't return %s from lvalue subroutine",
2304                         (*mark != &PL_sv_undef)
2305                         ? (SvREADONLY(TOPs)
2306                             ? "a readonly value" : "a temporary")
2307                         : "an uninitialized value");
2308                 }
2309                 else {
2310                     /* Can be a localized value subject to deletion. */
2311                     PL_tmps_stack[++PL_tmps_ix] = *mark;
2312                     (void)SvREFCNT_inc(*mark);
2313                 }
2314             }
2315         }
2316     }
2317     else {
2318         if (gimme == G_SCALAR) {
2319           temporise:
2320             MARK = newsp + 1;
2321             if (MARK <= SP) {
2322                 if (cx->blk_sub.cv && CvDEPTH(cx->blk_sub.cv) > 1) {
2323                     if (SvTEMP(TOPs)) {
2324                         *MARK = SvREFCNT_inc(TOPs);
2325                         FREETMPS;
2326                         sv_2mortal(*MARK);
2327                     }
2328                     else {
2329                         sv = SvREFCNT_inc(TOPs); /* FREETMPS could clobber it */
2330                         FREETMPS;
2331                         *MARK = sv_mortalcopy(sv);
2332                         SvREFCNT_dec(sv);
2333                     }
2334                 }
2335                 else
2336                     *MARK = SvTEMP(TOPs) ? TOPs : sv_mortalcopy(TOPs);
2337             }
2338             else {
2339                 MEXTEND(MARK, 0);
2340                 *MARK = &PL_sv_undef;
2341             }
2342             SP = MARK;
2343         }
2344         else if (gimme == G_ARRAY) {
2345           temporise_array:
2346             for (MARK = newsp + 1; MARK <= SP; MARK++) {
2347                 if (!SvTEMP(*MARK)) {
2348                     *MARK = sv_mortalcopy(*MARK);
2349                     TAINT_NOT;  /* Each item is independent */
2350                 }
2351             }
2352         }
2353     }
2354     PUTBACK;
2355
2356     POPSUB(cx,sv);      /* Stack values are safe: release CV and @_ ... */
2357     PL_curpm = newpm;   /* ... and pop $1 et al */
2358
2359     LEAVE;
2360     LEAVESUB(sv);
2361     return pop_return();
2362 }
2363
2364
2365 STATIC CV *
2366 S_get_db_sub(pTHX_ SV **svp, CV *cv)
2367 {
2368     SV *dbsv = GvSV(PL_DBsub);
2369
2370     if (!PERLDB_SUB_NN) {
2371         GV *gv = CvGV(cv);
2372
2373         save_item(dbsv);
2374         if ( (CvFLAGS(cv) & (CVf_ANON | CVf_CLONED))
2375              || strEQ(GvNAME(gv), "END")
2376              || ((GvCV(gv) != cv) && /* Could be imported, and old sub redefined. */
2377                  !( (SvTYPE(*svp) == SVt_PVGV) && (GvCV((GV*)*svp) == cv)
2378                     && (gv = (GV*)*svp) ))) {
2379             /* Use GV from the stack as a fallback. */
2380             /* GV is potentially non-unique, or contain different CV. */
2381             SV *tmp = newRV((SV*)cv);
2382             sv_setsv(dbsv, tmp);
2383             SvREFCNT_dec(tmp);
2384         }
2385         else {
2386             gv_efullname3(dbsv, gv, Nullch);
2387         }
2388     }
2389     else {
2390         (void)SvUPGRADE(dbsv, SVt_PVIV);
2391         (void)SvIOK_on(dbsv);
2392         SAVEIV(SvIVX(dbsv));
2393         SvIVX(dbsv) = PTR2IV(cv);       /* Do it the quickest way  */
2394     }
2395
2396     if (CvXSUB(cv))
2397         PL_curcopdb = PL_curcop;
2398     cv = GvCV(PL_DBsub);
2399     return cv;
2400 }
2401
2402 PP(pp_entersub)
2403 {
2404     dSP; dPOPss;
2405     GV *gv;
2406     HV *stash;
2407     register CV *cv;
2408     register PERL_CONTEXT *cx;
2409     I32 gimme;
2410     bool hasargs = (PL_op->op_flags & OPf_STACKED) != 0;
2411
2412     if (!sv)
2413         DIE(aTHX_ "Not a CODE reference");
2414     switch (SvTYPE(sv)) {
2415     default:
2416         if (!SvROK(sv)) {
2417             char *sym;
2418             STRLEN n_a;
2419
2420             if (sv == &PL_sv_yes) {             /* unfound import, ignore */
2421                 if (hasargs)
2422                     SP = PL_stack_base + POPMARK;
2423                 RETURN;
2424             }
2425             if (SvGMAGICAL(sv)) {
2426                 mg_get(sv);
2427                 sym = SvPOKp(sv) ? SvPVX(sv) : Nullch;
2428             }
2429             else
2430                 sym = SvPV(sv, n_a);
2431             if (!sym)
2432                 DIE(aTHX_ PL_no_usym, "a subroutine");
2433             if (PL_op->op_private & HINT_STRICT_REFS)
2434                 DIE(aTHX_ PL_no_symref, sym, "a subroutine");
2435             cv = get_cv(sym, TRUE);
2436             break;
2437         }
2438         {
2439             SV **sp = &sv;              /* Used in tryAMAGICunDEREF macro. */
2440             tryAMAGICunDEREF(to_cv);
2441         }
2442         cv = (CV*)SvRV(sv);
2443         if (SvTYPE(cv) == SVt_PVCV)
2444             break;
2445         /* FALL THROUGH */
2446     case SVt_PVHV:
2447     case SVt_PVAV:
2448         DIE(aTHX_ "Not a CODE reference");
2449     case SVt_PVCV:
2450         cv = (CV*)sv;
2451         break;
2452     case SVt_PVGV:
2453         if (!(cv = GvCVu((GV*)sv)))
2454             cv = sv_2cv(sv, &stash, &gv, FALSE);
2455         if (!cv) {
2456             ENTER;
2457             SAVETMPS;
2458             goto try_autoload;
2459         }
2460         break;
2461     }
2462
2463     ENTER;
2464     SAVETMPS;
2465
2466   retry:
2467     if (!CvROOT(cv) && !CvXSUB(cv)) {
2468         GV* autogv;
2469         SV* sub_name;
2470
2471         /* anonymous or undef'd function leaves us no recourse */
2472         if (CvANON(cv) || !(gv = CvGV(cv)))
2473             DIE(aTHX_ "Undefined subroutine called");
2474
2475         /* autoloaded stub? */
2476         if (cv != GvCV(gv)) {
2477             cv = GvCV(gv);
2478         }
2479         /* should call AUTOLOAD now? */
2480         else {
2481 try_autoload:
2482             if ((autogv = gv_autoload4(GvSTASH(gv), GvNAME(gv), GvNAMELEN(gv),
2483                                    FALSE)))
2484             {
2485                 cv = GvCV(autogv);
2486             }
2487             /* sorry */
2488             else {
2489                 sub_name = sv_newmortal();
2490                 gv_efullname3(sub_name, gv, Nullch);
2491                 DIE(aTHX_ "Undefined subroutine &%s called", SvPVX(sub_name));
2492             }
2493         }
2494         if (!cv)
2495             DIE(aTHX_ "Not a CODE reference");
2496         goto retry;
2497     }
2498
2499     gimme = GIMME_V;
2500     if ((PL_op->op_private & OPpENTERSUB_DB) && GvCV(PL_DBsub) && !CvNODEBUG(cv)) {
2501         cv = get_db_sub(&sv, cv);
2502         if (!cv)
2503             DIE(aTHX_ "No DBsub routine");
2504     }
2505
2506 #ifdef USE_THREADS
2507     /*
2508      * First we need to check if the sub or method requires locking.
2509      * If so, we gain a lock on the CV, the first argument or the
2510      * stash (for static methods), as appropriate. This has to be
2511      * inline because for FAKE_THREADS, COND_WAIT inlines code to
2512      * reschedule by returning a new op.
2513      */
2514     MUTEX_LOCK(CvMUTEXP(cv));
2515     if (CvFLAGS(cv) & CVf_LOCKED) {
2516         MAGIC *mg;
2517         if (CvFLAGS(cv) & CVf_METHOD) {
2518             if (SP > PL_stack_base + TOPMARK)
2519                 sv = *(PL_stack_base + TOPMARK + 1);
2520             else {
2521                 AV *av = (AV*)PL_curpad[0];
2522                 if (hasargs || !av || AvFILLp(av) < 0
2523                     || !(sv = AvARRAY(av)[0]))
2524                 {
2525                     MUTEX_UNLOCK(CvMUTEXP(cv));
2526                     DIE(aTHX_ "no argument for locked method call");
2527                 }
2528             }
2529             if (SvROK(sv))
2530                 sv = SvRV(sv);
2531             else {
2532                 STRLEN len;
2533                 char *stashname = SvPV(sv, len);
2534                 sv = (SV*)gv_stashpvn(stashname, len, TRUE);
2535             }
2536         }
2537         else {
2538             sv = (SV*)cv;
2539         }
2540         MUTEX_UNLOCK(CvMUTEXP(cv));
2541         mg = condpair_magic(sv);
2542         MUTEX_LOCK(MgMUTEXP(mg));
2543         if (MgOWNER(mg) == thr)
2544             MUTEX_UNLOCK(MgMUTEXP(mg));
2545         else {
2546             while (MgOWNER(mg))
2547                 COND_WAIT(MgOWNERCONDP(mg), MgMUTEXP(mg));
2548             MgOWNER(mg) = thr;
2549             DEBUG_S(PerlIO_printf(Perl_debug_log, "%p: pp_entersub lock %p\n",
2550                                   thr, sv);)
2551             MUTEX_UNLOCK(MgMUTEXP(mg));
2552             SAVEDESTRUCTOR_X(Perl_unlock_condpair, sv);
2553         }
2554         MUTEX_LOCK(CvMUTEXP(cv));
2555     }
2556     /*
2557      * Now we have permission to enter the sub, we must distinguish
2558      * four cases. (0) It's an XSUB (in which case we don't care
2559      * about ownership); (1) it's ours already (and we're recursing);
2560      * (2) it's free (but we may already be using a cached clone);
2561      * (3) another thread owns it. Case (1) is easy: we just use it.
2562      * Case (2) means we look for a clone--if we have one, use it
2563      * otherwise grab ownership of cv. Case (3) means we look for a
2564      * clone (for non-XSUBs) and have to create one if we don't
2565      * already have one.
2566      * Why look for a clone in case (2) when we could just grab
2567      * ownership of cv straight away? Well, we could be recursing,
2568      * i.e. we originally tried to enter cv while another thread
2569      * owned it (hence we used a clone) but it has been freed up
2570      * and we're now recursing into it. It may or may not be "better"
2571      * to use the clone but at least CvDEPTH can be trusted.
2572      */
2573     if (CvOWNER(cv) == thr || CvXSUB(cv))
2574         MUTEX_UNLOCK(CvMUTEXP(cv));
2575     else {
2576         /* Case (2) or (3) */
2577         SV **svp;
2578
2579         /*
2580          * XXX Might it be better to release CvMUTEXP(cv) while we
2581          * do the hv_fetch? We might find someone has pinched it
2582          * when we look again, in which case we would be in case
2583          * (3) instead of (2) so we'd have to clone. Would the fact
2584          * that we released the mutex more quickly make up for this?
2585          */
2586         if ((svp = hv_fetch(thr->cvcache, (char *)cv, sizeof(cv), FALSE)))
2587         {
2588             /* We already have a clone to use */
2589             MUTEX_UNLOCK(CvMUTEXP(cv));
2590             cv = *(CV**)svp;
2591             DEBUG_S(PerlIO_printf(Perl_debug_log,
2592                                   "entersub: %p already has clone %p:%s\n",
2593                                   thr, cv, SvPEEK((SV*)cv)));
2594             CvOWNER(cv) = thr;
2595             SvREFCNT_inc(cv);
2596             if (CvDEPTH(cv) == 0)
2597                 SAVEDESTRUCTOR_X(unset_cvowner, (void*) cv);
2598         }
2599         else {
2600             /* (2) => grab ownership of cv. (3) => make clone */
2601             if (!CvOWNER(cv)) {
2602                 CvOWNER(cv) = thr;
2603                 SvREFCNT_inc(cv);
2604                 MUTEX_UNLOCK(CvMUTEXP(cv));
2605                 DEBUG_S(PerlIO_printf(Perl_debug_log,
2606                             "entersub: %p grabbing %p:%s in stash %s\n",
2607                             thr, cv, SvPEEK((SV*)cv), CvSTASH(cv) ?
2608                                 HvNAME(CvSTASH(cv)) : "(none)"));
2609             }
2610             else {
2611                 /* Make a new clone. */
2612                 CV *clonecv;
2613                 SvREFCNT_inc(cv); /* don't let it vanish from under us */
2614                 MUTEX_UNLOCK(CvMUTEXP(cv));
2615                 DEBUG_S((PerlIO_printf(Perl_debug_log,
2616                                        "entersub: %p cloning %p:%s\n",
2617                                        thr, cv, SvPEEK((SV*)cv))));
2618                 /*
2619                  * We're creating a new clone so there's no race
2620                  * between the original MUTEX_UNLOCK and the
2621                  * SvREFCNT_inc since no one will be trying to undef
2622                  * it out from underneath us. At least, I don't think
2623                  * there's a race...
2624                  */
2625                 clonecv = cv_clone(cv);
2626                 SvREFCNT_dec(cv); /* finished with this */
2627                 hv_store(thr->cvcache, (char*)cv, sizeof(cv), (SV*)clonecv,0);
2628                 CvOWNER(clonecv) = thr;
2629                 cv = clonecv;
2630                 SvREFCNT_inc(cv);
2631             }
2632             DEBUG_S(if (CvDEPTH(cv) != 0)
2633                         PerlIO_printf(Perl_debug_log, "depth %ld != 0\n",
2634                                       CvDEPTH(cv)););
2635             SAVEDESTRUCTOR_X(unset_cvowner, (void*) cv);
2636         }
2637     }
2638 #endif /* USE_THREADS */
2639
2640     if (CvXSUB(cv)) {
2641 #ifdef PERL_XSUB_OLDSTYLE
2642         if (CvOLDSTYLE(cv)) {
2643             I32 (*fp3)(int,int,int);
2644             dMARK;
2645             register I32 items = SP - MARK;
2646                                         /* We dont worry to copy from @_. */
2647             while (SP > mark) {
2648                 SP[1] = SP[0];
2649                 SP--;
2650             }
2651             PL_stack_sp = mark + 1;
2652             fp3 = (I32(*)(int,int,int))CvXSUB(cv);
2653             items = (*fp3)(CvXSUBANY(cv).any_i32,
2654                            MARK - PL_stack_base + 1,
2655                            items);
2656             PL_stack_sp = PL_stack_base + items;
2657         }
2658         else
2659 #endif /* PERL_XSUB_OLDSTYLE */
2660         {
2661             I32 markix = TOPMARK;
2662
2663             PUTBACK;
2664
2665             if (!hasargs) {
2666                 /* Need to copy @_ to stack. Alternative may be to
2667                  * switch stack to @_, and copy return values
2668                  * back. This would allow popping @_ in XSUB, e.g.. XXXX */
2669                 AV* av;
2670                 I32 items;
2671 #ifdef USE_THREADS
2672                 av = (AV*)PL_curpad[0];
2673 #else
2674                 av = GvAV(PL_defgv);
2675 #endif /* USE_THREADS */
2676                 items = AvFILLp(av) + 1;   /* @_ is not tieable */
2677
2678                 if (items) {
2679                     /* Mark is at the end of the stack. */
2680                     EXTEND(SP, items);
2681                     Copy(AvARRAY(av), SP + 1, items, SV*);
2682                     SP += items;
2683                     PUTBACK ;
2684                 }
2685             }
2686             /* We assume first XSUB in &DB::sub is the called one. */
2687             if (PL_curcopdb) {
2688                 SAVEVPTR(PL_curcop);
2689                 PL_curcop = PL_curcopdb;
2690                 PL_curcopdb = NULL;
2691             }
2692             /* Do we need to open block here? XXXX */
2693             (void)(*CvXSUB(cv))(aTHXo_ cv);
2694
2695             /* Enforce some sanity in scalar context. */
2696             if (gimme == G_SCALAR && ++markix != PL_stack_sp - PL_stack_base ) {
2697                 if (markix > PL_stack_sp - PL_stack_base)
2698                     *(PL_stack_base + markix) = &PL_sv_undef;
2699                 else
2700                     *(PL_stack_base + markix) = *PL_stack_sp;
2701                 PL_stack_sp = PL_stack_base + markix;
2702             }
2703         }
2704         LEAVE;
2705         return NORMAL;
2706     }
2707     else {
2708         dMARK;
2709         register I32 items = SP - MARK;
2710         AV* padlist = CvPADLIST(cv);
2711         SV** svp = AvARRAY(padlist);
2712         push_return(PL_op->op_next);
2713         PUSHBLOCK(cx, CXt_SUB, MARK);
2714         PUSHSUB(cx);
2715         CvDEPTH(cv)++;
2716         /* XXX This would be a natural place to set C<PL_compcv = cv> so
2717          * that eval'' ops within this sub know the correct lexical space.
2718          * Owing the speed considerations, we choose to search for the cv
2719          * in doeval() instead.
2720          */
2721         if (CvDEPTH(cv) < 2)
2722             (void)SvREFCNT_inc(cv);
2723         else {  /* save temporaries on recursion? */
2724             PERL_STACK_OVERFLOW_CHECK();
2725             if (CvDEPTH(cv) > AvFILLp(padlist)) {
2726                 AV *av;
2727                 AV *newpad = newAV();
2728                 SV **oldpad = AvARRAY(svp[CvDEPTH(cv)-1]);
2729                 I32 ix = AvFILLp((AV*)svp[1]);
2730                 I32 names_fill = AvFILLp((AV*)svp[0]);
2731                 svp = AvARRAY(svp[0]);
2732                 for ( ;ix > 0; ix--) {
2733                     if (names_fill >= ix && svp[ix] != &PL_sv_undef) {
2734                         char *name = SvPVX(svp[ix]);
2735                         if ((SvFLAGS(svp[ix]) & SVf_FAKE) /* outer lexical? */
2736                             || *name == '&')              /* anonymous code? */
2737                         {
2738                             av_store(newpad, ix, SvREFCNT_inc(oldpad[ix]));
2739                         }
2740                         else {                          /* our own lexical */
2741                             if (*name == '@')
2742                                 av_store(newpad, ix, sv = (SV*)newAV());
2743                             else if (*name == '%')
2744                                 av_store(newpad, ix, sv = (SV*)newHV());
2745                             else
2746                                 av_store(newpad, ix, sv = NEWSV(0,0));
2747                             SvPADMY_on(sv);
2748                         }
2749                     }
2750                     else if (IS_PADGV(oldpad[ix]) || IS_PADCONST(oldpad[ix])) {
2751                         av_store(newpad, ix, sv = SvREFCNT_inc(oldpad[ix]));
2752                     }
2753                     else {
2754                         av_store(newpad, ix, sv = NEWSV(0,0));
2755                         SvPADTMP_on(sv);
2756                     }
2757                 }
2758                 av = newAV();           /* will be @_ */
2759                 av_extend(av, 0);
2760                 av_store(newpad, 0, (SV*)av);
2761                 AvFLAGS(av) = AVf_REIFY;
2762                 av_store(padlist, CvDEPTH(cv), (SV*)newpad);
2763                 AvFILLp(padlist) = CvDEPTH(cv);
2764                 svp = AvARRAY(padlist);
2765             }
2766         }
2767 #ifdef USE_THREADS
2768         if (!hasargs) {
2769             AV* av = (AV*)PL_curpad[0];
2770
2771             items = AvFILLp(av) + 1;
2772             if (items) {
2773                 /* Mark is at the end of the stack. */
2774                 EXTEND(SP, items);
2775                 Copy(AvARRAY(av), SP + 1, items, SV*);
2776                 SP += items;
2777                 PUTBACK ;
2778             }
2779         }
2780 #endif /* USE_THREADS */
2781         SAVEVPTR(PL_curpad);
2782         PL_curpad = AvARRAY((AV*)svp[CvDEPTH(cv)]);
2783 #ifndef USE_THREADS
2784         if (hasargs)
2785 #endif /* USE_THREADS */
2786         {
2787             AV* av;
2788             SV** ary;
2789
2790 #if 0
2791             DEBUG_S(PerlIO_printf(Perl_debug_log,
2792                                   "%p entersub preparing @_\n", thr));
2793 #endif
2794             av = (AV*)PL_curpad[0];
2795             if (AvREAL(av)) {
2796                 /* @_ is normally not REAL--this should only ever
2797                  * happen when DB::sub() calls things that modify @_ */
2798                 av_clear(av);
2799                 AvREAL_off(av);
2800                 AvREIFY_on(av);
2801             }
2802 #ifndef USE_THREADS
2803             cx->blk_sub.savearray = GvAV(PL_defgv);
2804             GvAV(PL_defgv) = (AV*)SvREFCNT_inc(av);
2805 #endif /* USE_THREADS */
2806             cx->blk_sub.oldcurpad = PL_curpad;
2807             cx->blk_sub.argarray = av;
2808             ++MARK;
2809
2810             if (items > AvMAX(av) + 1) {
2811                 ary = AvALLOC(av);
2812                 if (AvARRAY(av) != ary) {
2813                     AvMAX(av) += AvARRAY(av) - AvALLOC(av);
2814                     SvPVX(av) = (char*)ary;
2815                 }
2816                 if (items > AvMAX(av) + 1) {
2817                     AvMAX(av) = items - 1;
2818                     Renew(ary,items,SV*);
2819                     AvALLOC(av) = ary;
2820                     SvPVX(av) = (char*)ary;
2821                 }
2822             }
2823             Copy(MARK,AvARRAY(av),items,SV*);
2824             AvFILLp(av) = items - 1;
2825
2826             while (items--) {
2827                 if (*MARK)
2828                     SvTEMP_off(*MARK);
2829                 MARK++;
2830             }
2831         }
2832         /* warning must come *after* we fully set up the context
2833          * stuff so that __WARN__ handlers can safely dounwind()
2834          * if they want to
2835          */
2836         if (CvDEPTH(cv) == 100 && ckWARN(WARN_RECURSION)
2837             && !(PERLDB_SUB && cv == GvCV(PL_DBsub)))
2838             sub_crush_depth(cv);
2839 #if 0
2840         DEBUG_S(PerlIO_printf(Perl_debug_log,
2841                               "%p entersub returning %p\n", thr, CvSTART(cv)));
2842 #endif
2843         RETURNOP(CvSTART(cv));
2844     }
2845 }
2846
2847 void
2848 Perl_sub_crush_depth(pTHX_ CV *cv)
2849 {
2850     if (CvANON(cv))
2851         Perl_warner(aTHX_ WARN_RECURSION, "Deep recursion on anonymous subroutine");
2852     else {
2853         SV* tmpstr = sv_newmortal();
2854         gv_efullname3(tmpstr, CvGV(cv), Nullch);
2855         Perl_warner(aTHX_ WARN_RECURSION, "Deep recursion on subroutine \"%s\"",
2856                 SvPVX(tmpstr));
2857     }
2858 }
2859
2860 PP(pp_aelem)
2861 {
2862     dSP;
2863     SV** svp;
2864     SV* elemsv = POPs;
2865     IV elem = SvIV(elemsv);
2866     AV* av = (AV*)POPs;
2867     U32 lval = PL_op->op_flags & OPf_MOD || LVRET;
2868     U32 defer = (PL_op->op_private & OPpLVAL_DEFER) && (elem > AvFILL(av));
2869     SV *sv;
2870
2871     if (SvROK(elemsv) && !SvGAMAGIC(elemsv) && ckWARN(WARN_MISC))
2872         Perl_warner(aTHX_ WARN_MISC, "Use of reference \"%s\" as array index", SvPV_nolen(elemsv));
2873     if (elem > 0)
2874         elem -= PL_curcop->cop_arybase;
2875     if (SvTYPE(av) != SVt_PVAV)
2876         RETPUSHUNDEF;
2877     svp = av_fetch(av, elem, lval && !defer);
2878     if (lval) {
2879         if (!svp || *svp == &PL_sv_undef) {
2880             SV* lv;
2881             if (!defer)
2882                 DIE(aTHX_ PL_no_aelem, elem);
2883             lv = sv_newmortal();
2884             sv_upgrade(lv, SVt_PVLV);
2885             LvTYPE(lv) = 'y';
2886             sv_magic(lv, Nullsv, 'y', Nullch, 0);
2887             LvTARG(lv) = SvREFCNT_inc(av);
2888             LvTARGOFF(lv) = elem;
2889             LvTARGLEN(lv) = 1;
2890             PUSHs(lv);
2891             RETURN;
2892         }
2893         if (PL_op->op_private & OPpLVAL_INTRO)
2894             save_aelem(av, elem, svp);
2895         else if (PL_op->op_private & OPpDEREF)
2896             vivify_ref(*svp, PL_op->op_private & OPpDEREF);
2897     }
2898     sv = (svp ? *svp : &PL_sv_undef);
2899     if (!lval && SvGMAGICAL(sv))        /* see note in pp_helem() */
2900         sv = sv_mortalcopy(sv);
2901     PUSHs(sv);
2902     RETURN;
2903 }
2904
2905 void
2906 Perl_vivify_ref(pTHX_ SV *sv, U32 to_what)
2907 {
2908     if (SvGMAGICAL(sv))
2909         mg_get(sv);
2910     if (!SvOK(sv)) {
2911         if (SvREADONLY(sv))
2912             Perl_croak(aTHX_ PL_no_modify);
2913         if (SvTYPE(sv) < SVt_RV)
2914             sv_upgrade(sv, SVt_RV);
2915         else if (SvTYPE(sv) >= SVt_PV) {
2916             (void)SvOOK_off(sv);
2917             Safefree(SvPVX(sv));
2918             SvLEN(sv) = SvCUR(sv) = 0;
2919         }
2920         switch (to_what) {
2921         case OPpDEREF_SV:
2922             SvRV(sv) = NEWSV(355,0);
2923             break;
2924         case OPpDEREF_AV:
2925             SvRV(sv) = (SV*)newAV();
2926             break;
2927         case OPpDEREF_HV:
2928             SvRV(sv) = (SV*)newHV();
2929             break;
2930         }
2931         SvROK_on(sv);
2932         SvSETMAGIC(sv);
2933     }
2934 }
2935
2936 PP(pp_method)
2937 {
2938     dSP;
2939     SV* sv = TOPs;
2940
2941     if (SvROK(sv)) {
2942         SV* rsv = SvRV(sv);
2943         if (SvTYPE(rsv) == SVt_PVCV) {
2944             SETs(rsv);
2945             RETURN;
2946         }
2947     }
2948
2949     SETs(method_common(sv, Null(U32*)));
2950     RETURN;
2951 }
2952
2953 PP(pp_method_named)
2954 {
2955     dSP;
2956     SV* sv = cSVOP->op_sv;
2957     U32 hash = SvUVX(sv);
2958
2959     XPUSHs(method_common(sv, &hash));
2960     RETURN;
2961 }
2962
2963 STATIC SV *
2964 S_method_common(pTHX_ SV* meth, U32* hashp)
2965 {
2966     SV* sv;
2967     SV* ob;
2968     GV* gv;
2969     HV* stash;
2970     char* name;
2971     STRLEN namelen;
2972     char* packname;
2973     STRLEN packlen;
2974
2975     name = SvPV(meth, namelen);
2976     sv = *(PL_stack_base + TOPMARK + 1);
2977
2978     if (!sv)
2979         Perl_croak(aTHX_ "Can't call method \"%s\" on an undefined value", name);
2980
2981     if (SvGMAGICAL(sv))
2982         mg_get(sv);
2983     if (SvROK(sv))
2984         ob = (SV*)SvRV(sv);
2985     else {
2986         GV* iogv;
2987
2988         packname = Nullch;
2989         if (!SvOK(sv) ||
2990             !(packname = SvPV(sv, packlen)) ||
2991             !(iogv = gv_fetchpv(packname, FALSE, SVt_PVIO)) ||
2992             !(ob=(SV*)GvIO(iogv)))
2993         {
2994             if (!packname ||
2995                 ((UTF8_IS_START(*packname) && DO_UTF8(sv))
2996                     ? !isIDFIRST_utf8((U8*)packname)
2997                     : !isIDFIRST(*packname)
2998                 ))
2999             {
3000                 Perl_croak(aTHX_ "Can't call method \"%s\" %s", name,
3001                            SvOK(sv) ? "without a package or object reference"
3002                                     : "on an undefined value");
3003             }
3004             stash = gv_stashpvn(packname, packlen, TRUE);
3005             goto fetch;
3006         }
3007         *(PL_stack_base + TOPMARK + 1) = sv_2mortal(newRV((SV*)iogv));
3008     }
3009
3010     if (!ob || !(SvOBJECT(ob)
3011                  || (SvTYPE(ob) == SVt_PVGV && (ob = (SV*)GvIO((GV*)ob))
3012                      && SvOBJECT(ob))))
3013     {
3014         Perl_croak(aTHX_ "Can't call method \"%s\" on unblessed reference",
3015                    name);
3016     }
3017
3018     stash = SvSTASH(ob);
3019
3020   fetch:
3021     /* shortcut for simple names */
3022     if (hashp) {
3023         HE* he = hv_fetch_ent(stash, meth, 0, *hashp);
3024         if (he) {
3025             gv = (GV*)HeVAL(he);
3026             if (isGV(gv) && GvCV(gv) &&
3027                 (!GvCVGEN(gv) || GvCVGEN(gv) == PL_sub_generation))
3028                 return (SV*)GvCV(gv);
3029         }
3030     }
3031
3032     gv = gv_fetchmethod(stash, name);
3033     if (!gv) {
3034         char* leaf = name;
3035         char* sep = Nullch;
3036         char* p;
3037         GV* gv;
3038
3039         for (p = name; *p; p++) {
3040             if (*p == '\'')
3041                 sep = p, leaf = p + 1;
3042             else if (*p == ':' && *(p + 1) == ':')
3043                 sep = p, leaf = p + 2;
3044         }
3045         if (!sep || ((sep - name) == 5 && strnEQ(name, "SUPER", 5))) {
3046             packname = sep ? CopSTASHPV(PL_curcop) : HvNAME(stash);
3047             packlen = strlen(packname);
3048         }
3049         else {
3050             packname = name;
3051             packlen = sep - name;
3052         }
3053         gv = gv_fetchpv(packname, 0, SVt_PVHV);
3054         if (gv && isGV(gv)) {
3055             Perl_croak(aTHX_
3056                        "Can't locate object method \"%s\" via package \"%s\"",
3057                        leaf, packname);
3058         }
3059         else {
3060             Perl_croak(aTHX_
3061                        "Can't locate object method \"%s\" via package \"%s\""
3062                        " (perhaps you forgot to load \"%s\"?)",
3063                        leaf, packname, packname);
3064         }
3065     }
3066     return isGV(gv) ? (SV*)GvCV(gv) : (SV*)gv;
3067 }
3068
3069 #ifdef USE_THREADS
3070 static void
3071 unset_cvowner(pTHXo_ void *cvarg)
3072 {
3073     register CV* cv = (CV *) cvarg;
3074
3075     DEBUG_S((PerlIO_printf(Perl_debug_log, "%p unsetting CvOWNER of %p:%s\n",
3076                            thr, cv, SvPEEK((SV*)cv))));
3077     MUTEX_LOCK(CvMUTEXP(cv));
3078     DEBUG_S(if (CvDEPTH(cv) != 0)
3079                 PerlIO_printf(Perl_debug_log, "depth %ld != 0\n",
3080                               CvDEPTH(cv)););
3081     assert(thr == CvOWNER(cv));
3082     CvOWNER(cv) = 0;
3083     MUTEX_UNLOCK(CvMUTEXP(cv));
3084     SvREFCNT_dec(cv);
3085 }
3086 #endif /* USE_THREADS */