pp_hot.c

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