pp_hot.c

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