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