pp_hot.c

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