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