pp_hot.c

   1 /*    pp_hot.c
   2  *
   3  *    Copyright (c) 1991-1997, 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 #include "perl.h"
  20
  21 /* Hot code. */
  22
  23 #ifdef USE_THREADS
  24 static void
  25 unset_cvowner(cvarg)
  26 void *cvarg;
  27 {
  28     register CV* cv = (CV *) cvarg;
  29 #ifdef DEBUGGING
  30     dTHR;
  31 #endif /* DEBUGGING */
  32
  33     DEBUG_L((PerlIO_printf(PerlIO_stderr(), "0x%lx unsetting CvOWNER of 0x%lx:%s\n",
  34                      (unsigned long)thr, (unsigned long)cv, SvPEEK((SV*)cv))));
  35     MUTEX_LOCK(CvMUTEXP(cv));
  36     DEBUG_L(if (CvDEPTH(cv) != 0)
  37                 PerlIO_printf(PerlIO_stderr(), "depth %ld != 0\n",
  38                               CvDEPTH(cv)););
  39     assert(thr == CvOWNER(cv));
  40     CvOWNER(cv) = 0;
  41     MUTEX_UNLOCK(CvMUTEXP(cv));
  42     SvREFCNT_dec(cv);
  43 }
  44 #endif /* USE_THREADS */
  45
  46 PP(pp_const)
  47 {
  48     dSP;
  49     XPUSHs(cSVOP->op_sv);
  50     RETURN;
  51 }
  52
  53 PP(pp_nextstate)
  54 {
  55     curcop = (COP*)op;
  56     TAINT_NOT;          /* Each statement is presumed innocent */
  57     stack_sp = stack_base + cxstack[cxstack_ix].blk_oldsp;
  58     FREETMPS;
  59     return NORMAL;
  60 }
  61
  62 PP(pp_gvsv)
  63 {
  64     dSP;
  65     EXTEND(sp,1);
  66     if (op->op_private & OPpLVAL_INTRO)
  67         PUSHs(save_scalar(cGVOP->op_gv));
  68     else
  69         PUSHs(GvSV(cGVOP->op_gv));
  70     RETURN;
  71 }
  72
  73 PP(pp_null)
  74 {
  75     return NORMAL;
  76 }
  77
  78 PP(pp_pushmark)
  79 {
  80     PUSHMARK(stack_sp);
  81     return NORMAL;
  82 }
  83
  84 PP(pp_stringify)
  85 {
  86     dSP; dTARGET;
  87     STRLEN len;
  88     char *s;
  89     s = SvPV(TOPs,len);
  90     sv_setpvn(TARG,s,len);
  91     SETTARG;
  92     RETURN;
  93 }
  94
  95 PP(pp_gv)
  96 {
  97     dSP;
  98     XPUSHs((SV*)cGVOP->op_gv);
  99     RETURN;
 100 }
 101
 102 PP(pp_gelem)
 103 {
 104     GV *gv;
 105     SV *sv;
 106     SV *ref;
 107     char *elem;
 108     dSP;
 109
 110     sv = POPs;
 111     elem = SvPV(sv, na);
 112     gv = (GV*)POPs;
 113     ref = Nullsv;
 114     sv = Nullsv;
 115     switch (elem ? *elem : '\0')
 116     {
 117     case 'A':
 118         if (strEQ(elem, "ARRAY"))
 119             ref = (SV*)GvAV(gv);
 120         break;
 121     case 'C':
 122         if (strEQ(elem, "CODE"))
 123             ref = (SV*)GvCVu(gv);
 124         break;
 125     case 'F':
 126         if (strEQ(elem, "FILEHANDLE")) /* XXX deprecate in 5.005 */
 127             ref = (SV*)GvIOp(gv);
 128         break;
 129     case 'G':
 130         if (strEQ(elem, "GLOB"))
 131             ref = (SV*)gv;
 132         break;
 133     case 'H':
 134         if (strEQ(elem, "HASH"))
 135             ref = (SV*)GvHV(gv);
 136         break;
 137     case 'I':
 138         if (strEQ(elem, "IO"))
 139             ref = (SV*)GvIOp(gv);
 140         break;
 141     case 'N':
 142         if (strEQ(elem, "NAME"))
 143             sv = newSVpv(GvNAME(gv), GvNAMELEN(gv));
 144         break;
 145     case 'P':
 146         if (strEQ(elem, "PACKAGE"))
 147             sv = newSVpv(HvNAME(GvSTASH(gv)), 0);
 148         break;
 149     case 'S':
 150         if (strEQ(elem, "SCALAR"))
 151             ref = GvSV(gv);
 152         break;
 153     }
 154     if (ref)
 155         sv = newRV(ref);
 156     if (sv)
 157         sv_2mortal(sv);
 158     else
 159         sv = &sv_undef;
 160     XPUSHs(sv);
 161     RETURN;
 162 }
 163
 164 PP(pp_and)
 165 {
 166     dSP;
 167     if (!SvTRUE(TOPs))
 168         RETURN;
 169     else {
 170         --SP;
 171         RETURNOP(cLOGOP->op_other);
 172     }
 173 }
 174
 175 PP(pp_sassign)
 176 {
 177     dSP; dPOPTOPssrl;
 178     MAGIC *mg;
 179
 180     if (op->op_private & OPpASSIGN_BACKWARDS) {
 181         SV *temp;
 182         temp = left; left = right; right = temp;
 183     }
 184     if (tainting && tainted && !SvTAINTED(left))
 185         TAINT_NOT;
 186     SvSetMagicSV(right, left);
 187     SETs(right);
 188     RETURN;
 189 }
 190
 191 PP(pp_cond_expr)
 192 {
 193     dSP;
 194     if (SvTRUEx(POPs))
 195         RETURNOP(cCONDOP->op_true);
 196     else
 197         RETURNOP(cCONDOP->op_false);
 198 }
 199
 200 PP(pp_unstack)
 201 {
 202     I32 oldsave;
 203     TAINT_NOT;          /* Each statement is presumed innocent */
 204     stack_sp = stack_base + cxstack[cxstack_ix].blk_oldsp;
 205     FREETMPS;
 206     oldsave = scopestack[scopestack_ix - 1];
 207     LEAVE_SCOPE(oldsave);
 208     return NORMAL;
 209 }
 210
 211 PP(pp_concat)
 212 {
 213   dSP; dATARGET; tryAMAGICbin(concat,opASSIGN);
 214   {
 215     dPOPTOPssrl;
 216     STRLEN len;
 217     char *s;
 218     if (TARG != left) {
 219         s = SvPV(left,len);
 220         sv_setpvn(TARG,s,len);
 221     }
 222     else if (SvGMAGICAL(TARG))
 223         mg_get(TARG);
 224     else if (!SvOK(TARG) && SvTYPE(TARG) <= SVt_PVMG) {
 225         sv_setpv(TARG, "");     /* Suppress warning. */
 226         s = SvPV_force(TARG, len);
 227     }
 228     s = SvPV(right,len);
 229     if (SvOK(TARG))
 230         sv_catpvn(TARG,s,len);
 231     else
 232         sv_setpvn(TARG,s,len);  /* suppress warning */
 233     SETTARG;
 234     RETURN;
 235   }
 236 }
 237
 238 PP(pp_padsv)
 239 {
 240     dSP; dTARGET;
 241     XPUSHs(TARG);
 242     if (op->op_flags & OPf_MOD) {
 243         if (op->op_private & OPpLVAL_INTRO)
 244             SAVECLEARSV(curpad[op->op_targ]);
 245         else if (op->op_private & OPpDEREF)
 246             vivify_ref(curpad[op->op_targ], op->op_private & OPpDEREF);
 247     }
 248     RETURN;
 249 }
 250
 251 PP(pp_readline)
 252 {
 253     last_in_gv = (GV*)(*stack_sp--);
 254     return do_readline();
 255 }
 256
 257 PP(pp_eq)
 258 {
 259     dSP; tryAMAGICbinSET(eq,0);
 260     {
 261       dPOPnv;
 262       SETs(boolSV(TOPn == value));
 263       RETURN;
 264     }
 265 }
 266
 267 PP(pp_preinc)
 268 {
 269     dSP;
 270     if (SvREADONLY(TOPs) || SvTYPE(TOPs) > SVt_PVLV)
 271         croak(no_modify);
 272     if (SvIOK(TOPs) && !SvNOK(TOPs) && !SvPOK(TOPs) &&
 273         SvIVX(TOPs) != IV_MAX)
 274     {
 275         ++SvIVX(TOPs);
 276         SvFLAGS(TOPs) &= ~(SVp_NOK|SVp_POK);
 277     }
 278     else
 279         sv_inc(TOPs);
 280     SvSETMAGIC(TOPs);
 281     return NORMAL;
 282 }
 283
 284 PP(pp_or)
 285 {
 286     dSP;
 287     if (SvTRUE(TOPs))
 288         RETURN;
 289     else {
 290         --SP;
 291         RETURNOP(cLOGOP->op_other);
 292     }
 293 }
 294
 295 PP(pp_add)
 296 {
 297     dSP; dATARGET; tryAMAGICbin(add,opASSIGN);
 298     {
 299       dPOPTOPnnrl_ul;
 300       SETn( left + right );
 301       RETURN;
 302     }
 303 }
 304
 305 PP(pp_aelemfast)
 306 {
 307     dSP;
 308     AV *av = GvAV((GV*)cSVOP->op_sv);
 309     SV** svp = av_fetch(av, op->op_private, op->op_flags & OPf_MOD);
 310     PUSHs(svp ? *svp : &sv_undef);
 311     RETURN;
 312 }
 313
 314 PP(pp_join)
 315 {
 316     dSP; dMARK; dTARGET;
 317     MARK++;
 318     do_join(TARG, *MARK, MARK, SP);
 319     SP = MARK;
 320     SETs(TARG);
 321     RETURN;
 322 }
 323
 324 PP(pp_pushre)
 325 {
 326     dSP;
 327 #ifdef DEBUGGING
 328     /*
 329      * We ass_u_me that LvTARGOFF() comes first, and that two STRLENs
 330      * will be enough to hold an OP*.
 331      */
 332     SV* sv = sv_newmortal();
 333     sv_upgrade(sv, SVt_PVLV);
 334     LvTYPE(sv) = '/';
 335     Copy(&op, &LvTARGOFF(sv), 1, OP*);
 336     XPUSHs(sv);
 337 #else
 338     XPUSHs((SV*)op);
 339 #endif
 340     RETURN;
 341 }
 342
 343 /* Oversized hot code. */
 344
 345 PP(pp_print)
 346 {
 347     dSP; dMARK; dORIGMARK;
 348     GV *gv;
 349     IO *io;
 350     register PerlIO *fp;
 351     MAGIC *mg;
 352
 353     if (op->op_flags & OPf_STACKED)
 354         gv = (GV*)*++MARK;
 355     else
 356         gv = defoutgv;
 357     if (SvMAGICAL(gv) && (mg = mg_find((SV*)gv, 'q'))) {
 358         if (MARK == ORIGMARK) {
 359             EXTEND(SP, 1);
 360             ++MARK;
 361             Move(MARK, MARK + 1, (SP - MARK) + 1, SV*);
 362             ++SP;
 363         }
 364         PUSHMARK(MARK - 1);
 365         *MARK = mg->mg_obj;
 366         PUTBACK;
 367         ENTER;
 368         perl_call_method("PRINT", G_SCALAR);
 369         LEAVE;
 370         SPAGAIN;
 371         MARK = ORIGMARK + 1;
 372         *MARK = *SP;
 373         SP = MARK;
 374         RETURN;
 375     }
 376     if (!(io = GvIO(gv))) {
 377         if (dowarn) {
 378             SV* sv = sv_newmortal();
 379             gv_fullname3(sv, gv, Nullch);
 380             warn("Filehandle %s never opened", SvPV(sv,na));
 381         }
 382
 383         SETERRNO(EBADF,RMS$_IFI);
 384         goto just_say_no;
 385     }
 386     else if (!(fp = IoOFP(io))) {
 387         if (dowarn)  {
 388             SV* sv = sv_newmortal();
 389             gv_fullname3(sv, gv, Nullch);
 390             if (IoIFP(io))
 391                 warn("Filehandle %s opened only for input", SvPV(sv,na));
 392             else
 393                 warn("print on closed filehandle %s", SvPV(sv,na));
 394         }
 395         SETERRNO(EBADF,IoIFP(io)?RMS$_FAC:RMS$_IFI);
 396         goto just_say_no;
 397     }
 398     else {
 399         MARK++;
 400         if (ofslen) {
 401             while (MARK <= SP) {
 402                 if (!do_print(*MARK, fp))
 403                     break;
 404                 MARK++;
 405                 if (MARK <= SP) {
 406                     if (PerlIO_write(fp, ofs, ofslen) == 0 || PerlIO_error(fp)) {
 407                         MARK--;
 408                         break;
 409                     }
 410                 }
 411             }
 412         }
 413         else {
 414             while (MARK <= SP) {
 415                 if (!do_print(*MARK, fp))
 416                     break;
 417                 MARK++;
 418             }
 419         }
 420         if (MARK <= SP)
 421             goto just_say_no;
 422         else {
 423             if (orslen)
 424                 if (PerlIO_write(fp, ors, orslen) == 0 || PerlIO_error(fp))
 425                     goto just_say_no;
 426
 427             if (IoFLAGS(io) & IOf_FLUSH)
 428                 if (PerlIO_flush(fp) == EOF)
 429                     goto just_say_no;
 430         }
 431     }
 432     SP = ORIGMARK;
 433     PUSHs(&sv_yes);
 434     RETURN;
 435
 436   just_say_no:
 437     SP = ORIGMARK;
 438     PUSHs(&sv_undef);
 439     RETURN;
 440 }
 441
 442 PP(pp_rv2av)
 443 {
 444     dSP; dPOPss;
 445     AV *av;
 446
 447     if (SvROK(sv)) {
 448       wasref:
 449         av = (AV*)SvRV(sv);
 450         if (SvTYPE(av) != SVt_PVAV)
 451             DIE("Not an ARRAY reference");
 452         if (op->op_private & OPpLVAL_INTRO)
 453             av = (AV*)save_svref((SV**)sv);
 454         if (op->op_flags & OPf_REF) {
 455             PUSHs((SV*)av);
 456             RETURN;
 457         }
 458     }
 459     else {
 460         if (SvTYPE(sv) == SVt_PVAV) {
 461             av = (AV*)sv;
 462             if (op->op_flags & OPf_REF) {
 463                 PUSHs((SV*)av);
 464                 RETURN;
 465             }
 466         }
 467         else {
 468             GV *gv;
 469
 470             if (SvTYPE(sv) != SVt_PVGV) {
 471                 char *sym;
 472
 473                 if (SvGMAGICAL(sv)) {
 474                     mg_get(sv);
 475                     if (SvROK(sv))
 476                         goto wasref;
 477                 }
 478                 if (!SvOK(sv)) {
 479                     if (op->op_flags & OPf_REF ||
 480                       op->op_private & HINT_STRICT_REFS)
 481                         DIE(no_usym, "an ARRAY");
 482                     if (dowarn)
 483                         warn(warn_uninit);
 484                     if (GIMME == G_ARRAY)
 485                         RETURN;
 486                     RETPUSHUNDEF;
 487                 }
 488                 sym = SvPV(sv,na);
 489                 if (op->op_private & HINT_STRICT_REFS)
 490                     DIE(no_symref, sym, "an ARRAY");
 491                 gv = (GV*)gv_fetchpv(sym, TRUE, SVt_PVAV);
 492             } else {
 493                 gv = (GV*)sv;
 494             }
 495             av = GvAVn(gv);
 496             if (op->op_private & OPpLVAL_INTRO)
 497                 av = save_ary(gv);
 498             if (op->op_flags & OPf_REF) {
 499                 PUSHs((SV*)av);
 500                 RETURN;
 501             }
 502         }
 503     }
 504
 505     if (GIMME == G_ARRAY) {
 506         I32 maxarg = AvFILL(av) + 1;
 507         EXTEND(SP, maxarg);
 508         Copy(AvARRAY(av), SP+1, maxarg, SV*);
 509         SP += maxarg;
 510     }
 511     else {
 512         dTARGET;
 513         I32 maxarg = AvFILL(av) + 1;
 514         PUSHi(maxarg);
 515     }
 516     RETURN;
 517 }
 518
 519 PP(pp_rv2hv)
 520 {
 521     dSP; dTOPss;
 522     HV *hv;
 523
 524     if (SvROK(sv)) {
 525       wasref:
 526         hv = (HV*)SvRV(sv);
 527         if (SvTYPE(hv) != SVt_PVHV && SvTYPE(hv) != SVt_PVAV)
 528             DIE("Not a HASH reference");
 529         if (op->op_private & OPpLVAL_INTRO)
 530             hv = (HV*)save_svref((SV**)sv);
 531         if (op->op_flags & OPf_REF) {
 532             SETs((SV*)hv);
 533             RETURN;
 534         }
 535     }
 536     else {
 537         if (SvTYPE(sv) == SVt_PVHV || SvTYPE(sv) == SVt_PVAV) {
 538             hv = (HV*)sv;
 539             if (op->op_flags & OPf_REF) {
 540                 SETs((SV*)hv);
 541                 RETURN;
 542             }
 543         }
 544         else {
 545             GV *gv;
 546
 547             if (SvTYPE(sv) != SVt_PVGV) {
 548                 char *sym;
 549
 550                 if (SvGMAGICAL(sv)) {
 551                     mg_get(sv);
 552                     if (SvROK(sv))
 553                         goto wasref;
 554                 }
 555                 if (!SvOK(sv)) {
 556                     if (op->op_flags & OPf_REF ||
 557                       op->op_private & HINT_STRICT_REFS)
 558                         DIE(no_usym, "a HASH");
 559                     if (dowarn)
 560                         warn(warn_uninit);
 561                     if (GIMME == G_ARRAY) {
 562                         SP--;
 563                         RETURN;
 564                     }
 565                     RETSETUNDEF;
 566                 }
 567                 sym = SvPV(sv,na);
 568                 if (op->op_private & HINT_STRICT_REFS)
 569                     DIE(no_symref, sym, "a HASH");
 570                 gv = (GV*)gv_fetchpv(sym, TRUE, SVt_PVHV);
 571             } else {
 572                 gv = (GV*)sv;
 573             }
 574             hv = GvHVn(gv);
 575             if (op->op_private & OPpLVAL_INTRO)
 576                 hv = save_hash(gv);
 577             if (op->op_flags & OPf_REF) {
 578                 SETs((SV*)hv);
 579                 RETURN;
 580             }
 581         }
 582     }
 583
 584     if (GIMME == G_ARRAY) { /* array wanted */
 585         *stack_sp = (SV*)hv;
 586         return do_kv(ARGS);
 587     }
 588     else {
 589         dTARGET;
 590         /* This bit is OK even when hv is really an AV */
 591         if (HvFILL(hv))
 592             sv_setpvf(TARG, "%ld/%ld",
 593                       (long)HvFILL(hv), (long)HvMAX(hv) + 1);
 594         else
 595             sv_setiv(TARG, 0);
 596
 597         SETTARG;
 598         RETURN;
 599     }
 600 }
 601
 602 PP(pp_aassign)
 603 {
 604     dSP;
 605     SV **lastlelem = stack_sp;
 606     SV **lastrelem = stack_base + POPMARK;
 607     SV **firstrelem = stack_base + POPMARK + 1;
 608     SV **firstlelem = lastrelem + 1;
 609
 610     register SV **relem;
 611     register SV **lelem;
 612
 613     register SV *sv;
 614     register AV *ary;
 615
 616     I32 gimme;
 617     HV *hash;
 618     I32 i;
 619     int magic;
 620
 621     delaymagic = DM_DELAY;              /* catch simultaneous items */
 622
 623     /* If there's a common identifier on both sides we have to take
 624      * special care that assigning the identifier on the left doesn't
 625      * clobber a value on the right that's used later in the list.
 626      */
 627     if (op->op_private & OPpASSIGN_COMMON) {
 628         for (relem = firstrelem; relem <= lastrelem; relem++) {
 629             /*SUPPRESS 560*/
 630             if (sv = *relem) {
 631                 TAINT_NOT;      /* Each item is independent */
 632                 *relem = sv_mortalcopy(sv);
 633             }
 634         }
 635     }
 636
 637     relem = firstrelem;
 638     lelem = firstlelem;
 639     ary = Null(AV*);
 640     hash = Null(HV*);
 641     while (lelem <= lastlelem) {
 642         TAINT_NOT;              /* Each item stands on its own, taintwise. */
 643         sv = *lelem++;
 644         switch (SvTYPE(sv)) {
 645         case SVt_PVAV:
 646             ary = (AV*)sv;
 647             magic = SvMAGICAL(ary) != 0;
 648
 649             av_clear(ary);
 650             av_extend(ary, lastrelem - relem);
 651             i = 0;
 652             while (relem <= lastrelem) {        /* gobble up all the rest */
 653                 sv = NEWSV(28,0);
 654                 assert(*relem);
 655                 sv_setsv(sv,*relem);
 656                 *(relem++) = sv;
 657                 (void)av_store(ary,i++,sv);
 658                 if (magic)
 659                     mg_set(sv);
 660                 TAINT_NOT;
 661             }
 662             break;
 663         case SVt_PVHV: {
 664                 SV *tmpstr;
 665
 666                 hash = (HV*)sv;
 667                 magic = SvMAGICAL(hash) != 0;
 668                 hv_clear(hash);
 669
 670                 while (relem < lastrelem) {     /* gobble up all the rest */
 671                     STRLEN len;
 672                     if (*relem)
 673                         sv = *(relem++);
 674                     else
 675                         sv = &sv_no, relem++;
 676                     tmpstr = NEWSV(29,0);
 677                     if (*relem)
 678                         sv_setsv(tmpstr,*relem);        /* value */
 679                     *(relem++) = tmpstr;
 680                     (void)hv_store_ent(hash,sv,tmpstr,0);
 681                     if (magic)
 682                         mg_set(tmpstr);
 683                     TAINT_NOT;
 684                 }
 685                 if (relem == lastrelem)
 686                     warn("Odd number of elements in hash list");
 687             }
 688             break;
 689         default:
 690             if (SvTHINKFIRST(sv)) {
 691                 if (SvREADONLY(sv) && curcop != &compiling) {
 692                     if (sv != &sv_undef && sv != &sv_yes && sv != &sv_no)
 693                         DIE(no_modify);
 694                     if (relem <= lastrelem)
 695                         relem++;
 696                     break;
 697                 }
 698                 if (SvROK(sv))
 699                     sv_unref(sv);
 700             }
 701             if (relem <= lastrelem) {
 702                 sv_setsv(sv, *relem);
 703                 *(relem++) = sv;
 704             }
 705             else
 706                 sv_setsv(sv, &sv_undef);
 707             SvSETMAGIC(sv);
 708             break;
 709         }
 710     }
 711     if (delaymagic & ~DM_DELAY) {
 712         if (delaymagic & DM_UID) {
 713 #ifdef HAS_SETRESUID
 714             (void)setresuid(uid,euid,(Uid_t)-1);
 715 #else
 716 #  ifdef HAS_SETREUID
 717             (void)setreuid(uid,euid);
 718 #  else
 719 #    ifdef HAS_SETRUID
 720             if ((delaymagic & DM_UID) == DM_RUID) {
 721                 (void)setruid(uid);
 722                 delaymagic &= ~DM_RUID;
 723             }
 724 #    endif /* HAS_SETRUID */
 725 #    ifdef HAS_SETEUID
 726             if ((delaymagic & DM_UID) == DM_EUID) {
 727                 (void)seteuid(uid);
 728                 delaymagic &= ~DM_EUID;
 729             }
 730 #    endif /* HAS_SETEUID */
 731             if (delaymagic & DM_UID) {
 732                 if (uid != euid)
 733                     DIE("No setreuid available");
 734                 (void)setuid(uid);
 735             }
 736 #  endif /* HAS_SETREUID */
 737 #endif /* HAS_SETRESUID */
 738             uid = (int)getuid();
 739             euid = (int)geteuid();
 740         }
 741         if (delaymagic & DM_GID) {
 742 #ifdef HAS_SETRESGID
 743             (void)setresgid(gid,egid,(Gid_t)-1);
 744 #else
 745 #  ifdef HAS_SETREGID
 746             (void)setregid(gid,egid);
 747 #  else
 748 #    ifdef HAS_SETRGID
 749             if ((delaymagic & DM_GID) == DM_RGID) {
 750                 (void)setrgid(gid);
 751                 delaymagic &= ~DM_RGID;
 752             }
 753 #    endif /* HAS_SETRGID */
 754 #    ifdef HAS_SETEGID
 755             if ((delaymagic & DM_GID) == DM_EGID) {
 756                 (void)setegid(gid);
 757                 delaymagic &= ~DM_EGID;
 758             }
 759 #    endif /* HAS_SETEGID */
 760             if (delaymagic & DM_GID) {
 761                 if (gid != egid)
 762                     DIE("No setregid available");
 763                 (void)setgid(gid);
 764             }
 765 #  endif /* HAS_SETREGID */
 766 #endif /* HAS_SETRESGID */
 767             gid = (int)getgid();
 768             egid = (int)getegid();
 769         }
 770         tainting |= (uid && (euid != uid || egid != gid));
 771     }
 772     delaymagic = 0;
 773
 774     gimme = GIMME_V;
 775     if (gimme == G_VOID)
 776         SP = firstrelem - 1;
 777     else if (gimme == G_SCALAR) {
 778         dTARGET;
 779         SP = firstrelem;
 780         SETi(lastrelem - firstrelem + 1);
 781     }
 782     else {
 783         if (ary || hash)
 784             SP = lastrelem;
 785         else
 786             SP = firstrelem + (lastlelem - firstlelem);
 787         lelem = firstlelem + (relem - firstrelem);
 788         while (relem <= SP)
 789             *relem++ = (lelem <= lastlelem) ? *lelem++ : &sv_undef;
 790     }
 791     RETURN;
 792 }
 793
 794 PP(pp_match)
 795 {
 796     dSP; dTARG;
 797     register PMOP *pm = cPMOP;
 798     register char *t;
 799     register char *s;
 800     char *strend;
 801     I32 global;
 802     I32 safebase;
 803     char *truebase;
 804     register REGEXP *rx = pm->op_pmregexp;
 805     I32 gimme = GIMME;
 806     STRLEN len;
 807     I32 minmatch = 0;
 808     I32 oldsave = savestack_ix;
 809     I32 update_minmatch = 1;
 810
 811     if (op->op_flags & OPf_STACKED)
 812         TARG = POPs;
 813     else {
 814         TARG = GvSV(defgv);
 815         EXTEND(SP,1);
 816     }
 817     s = SvPV(TARG, len);
 818     strend = s + len;
 819     if (!s)
 820         DIE("panic: do_match");
 821     TAINT_NOT;
 822
 823     if (pm->op_pmflags & PMf_USED) {
 824         if (gimme == G_ARRAY)
 825             RETURN;
 826         RETPUSHNO;
 827     }
 828
 829     if (!rx->prelen && curpm) {
 830         pm = curpm;
 831         rx = pm->op_pmregexp;
 832     }
 833     truebase = t = s;
 834     if (global = pm->op_pmflags & PMf_GLOBAL) {
 835         rx->startp[0] = 0;
 836         if (SvTYPE(TARG) >= SVt_PVMG && SvMAGIC(TARG)) {
 837             MAGIC* mg = mg_find(TARG, 'g');
 838             if (mg && mg->mg_len >= 0) {
 839                 rx->endp[0] = rx->startp[0] = s + mg->mg_len;
 840                 minmatch = (mg->mg_flags & MGf_MINMATCH);
 841                 update_minmatch = 0;
 842             }
 843         }
 844     }
 845     if (!rx->nparens && !global)
 846         gimme = G_SCALAR;                       /* accidental array context? */
 847     safebase = (((gimme == G_ARRAY) || global || !rx->nparens)
 848                 && !sawampersand);
 849     if (pm->op_pmflags & (PMf_MULTILINE|PMf_SINGLELINE)) {
 850         SAVEINT(multiline);
 851         multiline = pm->op_pmflags & PMf_MULTILINE;
 852     }
 853
 854 play_it_again:
 855     if (global && rx->startp[0]) {
 856         t = s = rx->endp[0];
 857         if ((s + rx->minlen) > strend)
 858             goto nope;
 859         if (update_minmatch++)
 860             minmatch = (s == rx->startp[0]);
 861     }
 862     if (pm->op_pmshort) {
 863         if (pm->op_pmflags & PMf_SCANFIRST) {
 864             if (SvSCREAM(TARG)) {
 865                 if (screamfirst[BmRARE(pm->op_pmshort)] < 0)
 866                     goto nope;
 867                 else if (!(s = screaminstr(TARG, pm->op_pmshort)))
 868                     goto nope;
 869                 else if (pm->op_pmflags & PMf_ALL)
 870                     goto yup;
 871             }
 872             else if (!(s = fbm_instr((unsigned char*)s,
 873               (unsigned char*)strend, pm->op_pmshort)))
 874                 goto nope;
 875             else if (pm->op_pmflags & PMf_ALL)
 876                 goto yup;
 877             if (s && rx->regback >= 0) {
 878                 ++BmUSEFUL(pm->op_pmshort);
 879                 s -= rx->regback;
 880                 if (s < t)
 881                     s = t;
 882             }
 883             else
 884                 s = t;
 885         }
 886         else if (!multiline) {
 887             if (*SvPVX(pm->op_pmshort) != *s
 888                 || (pm->op_pmslen > 1
 889                     && memNE(SvPVX(pm->op_pmshort), s, pm->op_pmslen)))
 890                 goto nope;
 891         }
 892         if (!rx->naughty && --BmUSEFUL(pm->op_pmshort) < 0) {
 893             SvREFCNT_dec(pm->op_pmshort);
 894             pm->op_pmshort = Nullsv;    /* opt is being useless */
 895         }
 896     }
 897     if (pregexec(rx, s, strend, truebase, minmatch,
 898                  SvSCREAM(TARG) ? TARG : Nullsv, safebase))
 899     {
 900         curpm = pm;
 901         if (pm->op_pmflags & PMf_ONCE)
 902             pm->op_pmflags |= PMf_USED;
 903         goto gotcha;
 904     }
 905     else
 906         goto ret_no;
 907     /*NOTREACHED*/
 908
 909   gotcha:
 910     TAINT_IF(rx->exec_tainted);
 911     if (gimme == G_ARRAY) {
 912         I32 iters, i, len;
 913
 914         iters = rx->nparens;
 915         if (global && !iters)
 916             i = 1;
 917         else
 918             i = 0;
 919         EXTEND(SP, iters + i);
 920         EXTEND_MORTAL(iters + i);
 921         for (i = !i; i <= iters; i++) {
 922             PUSHs(sv_newmortal());
 923             /*SUPPRESS 560*/
 924             if ((s = rx->startp[i]) && rx->endp[i] ) {
 925                 len = rx->endp[i] - s;
 926                 sv_setpvn(*SP, s, len);
 927             }
 928         }
 929         if (global) {
 930             truebase = rx->subbeg;
 931             strend = rx->subend;
 932             if (rx->startp[0] && rx->startp[0] == rx->endp[0])
 933                 ++rx->endp[0];
 934             goto play_it_again;
 935         }
 936         LEAVE_SCOPE(oldsave);
 937         RETURN;
 938     }
 939     else {
 940         if (global) {
 941             MAGIC* mg = 0;
 942             if (SvTYPE(TARG) >= SVt_PVMG && SvMAGIC(TARG))
 943                 mg = mg_find(TARG, 'g');
 944             if (!mg) {
 945                 sv_magic(TARG, (SV*)0, 'g', Nullch, 0);
 946                 mg = mg_find(TARG, 'g');
 947             }
 948             if (rx->startp[0]) {
 949                 mg->mg_len = rx->endp[0] - rx->subbeg;
 950                 if (rx->startp[0] == rx->endp[0])
 951                     mg->mg_flags |= MGf_MINMATCH;
 952                 else
 953                     mg->mg_flags &= ~MGf_MINMATCH;
 954             }
 955         }
 956         LEAVE_SCOPE(oldsave);
 957         RETPUSHYES;
 958     }
 959
 960 yup:
 961     TAINT_IF(rx->exec_tainted);
 962     ++BmUSEFUL(pm->op_pmshort);
 963     curpm = pm;
 964     if (pm->op_pmflags & PMf_ONCE)
 965         pm->op_pmflags |= PMf_USED;
 966     Safefree(rx->subbase);
 967     rx->subbase = Nullch;
 968     if (global) {
 969         rx->subbeg = truebase;
 970         rx->subend = strend;
 971         rx->startp[0] = s;
 972         rx->endp[0] = s + SvCUR(pm->op_pmshort);
 973         goto gotcha;
 974     }
 975     if (sawampersand) {
 976         char *tmps;
 977
 978         tmps = rx->subbase = savepvn(t, strend-t);
 979         rx->subbeg = tmps;
 980         rx->subend = tmps + (strend-t);
 981         tmps = rx->startp[0] = tmps + (s - t);
 982         rx->endp[0] = tmps + SvCUR(pm->op_pmshort);
 983     }
 984     LEAVE_SCOPE(oldsave);
 985     RETPUSHYES;
 986
 987 nope:
 988     if (pm->op_pmshort)
 989         ++BmUSEFUL(pm->op_pmshort);
 990
 991 ret_no:
 992     if (global && !(pm->op_pmflags & PMf_CONTINUE)) {
 993         if (SvTYPE(TARG) >= SVt_PVMG && SvMAGIC(TARG)) {
 994             MAGIC* mg = mg_find(TARG, 'g');
 995             if (mg)
 996                 mg->mg_len = -1;
 997         }
 998     }
 999     LEAVE_SCOPE(oldsave);
1000     if (gimme == G_ARRAY)
1001         RETURN;
1002     RETPUSHNO;
1003 }
1004
1005 OP *
1006 do_readline()
1007 {
1008     dTHR;
1009     dSP; dTARGETSTACKED;
1010     register SV *sv;
1011     STRLEN tmplen = 0;
1012     STRLEN offset;
1013     PerlIO *fp;
1014     register IO *io = GvIO(last_in_gv);
1015     register I32 type = op->op_type;
1016     I32 gimme = GIMME_V;
1017     MAGIC *mg;
1018
1019     if (SvMAGICAL(last_in_gv) && (mg = mg_find((SV*)last_in_gv, 'q'))) {
1020         PUSHMARK(SP);
1021         XPUSHs(mg->mg_obj);
1022         PUTBACK;
1023         ENTER;
1024         perl_call_method("READLINE", gimme);
1025         LEAVE;
1026         SPAGAIN;
1027         if (gimme == G_SCALAR)
1028             SvSetMagicSV_nosteal(TARG, TOPs);
1029         RETURN;
1030     }
1031     fp = Nullfp;
1032     if (io) {
1033         fp = IoIFP(io);
1034         if (!fp) {
1035             if (IoFLAGS(io) & IOf_ARGV) {
1036                 if (IoFLAGS(io) & IOf_START) {
1037                     IoFLAGS(io) &= ~IOf_START;
1038                     IoLINES(io) = 0;
1039                     if (av_len(GvAVn(last_in_gv)) < 0) {
1040                         SV *tmpstr = newSVpv("-", 1); /* assume stdin */
1041                         av_push(GvAVn(last_in_gv), tmpstr);
1042                     }
1043                 }
1044                 fp = nextargv(last_in_gv);
1045                 if (!fp) { /* Note: fp != IoIFP(io) */
1046                     (void)do_close(last_in_gv, FALSE); /* now it does*/
1047                     IoFLAGS(io) |= IOf_START;
1048                 }
1049             }
1050             else if (type == OP_GLOB) {
1051                 SV *tmpcmd = NEWSV(55, 0);
1052                 SV *tmpglob = POPs;
1053                 ENTER;
1054                 SAVEFREESV(tmpcmd);
1055 #ifdef VMS /* expand the wildcards right here, rather than opening a pipe, */
1056            /* since spawning off a process is a real performance hit */
1057                 {
1058 #include <descrip.h>
1059 #include <lib$routines.h>
1060 #include <nam.h>
1061 #include <rmsdef.h>
1062                     char rslt[NAM$C_MAXRSS+1+sizeof(unsigned short int)] = {'\0','\0'};
1063                     char vmsspec[NAM$C_MAXRSS+1];
1064                     char *rstr = rslt + sizeof(unsigned short int), *begin, *end, *cp;
1065                     char tmpfnam[L_tmpnam] = "SYS$SCRATCH:";
1066                     $DESCRIPTOR(dfltdsc,"SYS$DISK:[]*.*;");
1067                     PerlIO *tmpfp;
1068                     STRLEN i;
1069                     struct dsc$descriptor_s wilddsc
1070                        = {0, DSC$K_DTYPE_T, DSC$K_CLASS_S, 0};
1071                     struct dsc$descriptor_vs rsdsc
1072                        = {sizeof rslt, DSC$K_DTYPE_VT, DSC$K_CLASS_VS, rslt};
1073                     unsigned long int cxt = 0, sts = 0, ok = 1, hasdir = 0, hasver = 0, isunix = 0;
1074
1075                     /* We could find out if there's an explicit dev/dir or version
1076                        by peeking into lib$find_file's internal context at
1077                        ((struct NAM *)((struct FAB *)cxt)->fab$l_nam)->nam$l_fnb
1078                        but that's unsupported, so I don't want to do it now and
1079                        have it bite someone in the future. */
1080                     strcat(tmpfnam,tmpnam(NULL));
1081                     cp = SvPV(tmpglob,i);
1082                     for (; i; i--) {
1083                        if (cp[i] == ';') hasver = 1;
1084                        if (cp[i] == '.') {
1085                            if (sts) hasver = 1;
1086                            else sts = 1;
1087                        }
1088                        if (cp[i] == '/') {
1089                           hasdir = isunix = 1;
1090                           break;
1091                        }
1092                        if (cp[i] == ']' || cp[i] == '>' || cp[i] == ':') {
1093                            hasdir = 1;
1094                            break;
1095                        }
1096                     }
1097                     if ((tmpfp = PerlIO_open(tmpfnam,"w+","fop=dlt")) != NULL) {
1098                         ok = ((wilddsc.dsc$a_pointer = tovmsspec(SvPVX(tmpglob),vmsspec)) != NULL);
1099                         if (ok) wilddsc.dsc$w_length = (unsigned short int) strlen(wilddsc.dsc$a_pointer);
1100                         while (ok && ((sts = lib$find_file(&wilddsc,&rsdsc,&cxt,
1101                                                     &dfltdsc,NULL,NULL,NULL))&1)) {
1102                             end = rstr + (unsigned long int) *rslt;
1103                             if (!hasver) while (*end != ';') end--;
1104                             *(end++) = '\n';  *end = '\0';
1105                             for (cp = rstr; *cp; cp++) *cp = _tolower(*cp);
1106                             if (hasdir) {
1107                               if (isunix) trim_unixpath(rstr,SvPVX(tmpglob),1);
1108                               begin = rstr;
1109                             }
1110                             else {
1111                                 begin = end;
1112                                 while (*(--begin) != ']' && *begin != '>') ;
1113                                 ++begin;
1114                             }
1115                             ok = (PerlIO_puts(tmpfp,begin) != EOF);
1116                         }
1117                         if (cxt) (void)lib$find_file_end(&cxt);
1118                         if (ok && sts != RMS$_NMF &&
1119                             sts != RMS$_DNF && sts != RMS$_FNF) ok = 0;
1120                         if (!ok) {
1121                             if (!(sts & 1)) {
1122                               SETERRNO((sts == RMS$_SYN ? EINVAL : EVMSERR),sts);
1123                             }
1124                             PerlIO_close(tmpfp);
1125                             fp = NULL;
1126                         }
1127                         else {
1128                            PerlIO_rewind(tmpfp);
1129                            IoTYPE(io) = '<';
1130                            IoIFP(io) = fp = tmpfp;
1131                            IoFLAGS(io) &= ~IOf_UNTAINT;  /* maybe redundant */
1132                         }
1133                     }
1134                 }
1135 #else /* !VMS */
1136 #ifdef DOSISH
1137 #ifdef OS2
1138                 sv_setpv(tmpcmd, "for a in ");
1139                 sv_catsv(tmpcmd, tmpglob);
1140                 sv_catpv(tmpcmd, "; do echo \"$a\\0\\c\"; done |");
1141 #else
1142                 sv_setpv(tmpcmd, "perlglob ");
1143                 sv_catsv(tmpcmd, tmpglob);
1144                 sv_catpv(tmpcmd, " |");
1145 #endif /* !OS2 */
1146 #else /* !DOSISH */
1147 #if defined(CSH)
1148                 sv_setpvn(tmpcmd, cshname, cshlen);
1149                 sv_catpv(tmpcmd, " -cf 'set nonomatch; glob ");
1150                 sv_catsv(tmpcmd, tmpglob);
1151                 sv_catpv(tmpcmd, "' 2>/dev/null |");
1152 #else
1153                 sv_setpv(tmpcmd, "echo ");
1154                 sv_catsv(tmpcmd, tmpglob);
1155 #if 'z' - 'a' == 25
1156                 sv_catpv(tmpcmd, "|tr -s ' \t\f\r' '\\012\\012\\012\\012'|");
1157 #else
1158                 sv_catpv(tmpcmd, "|tr -s ' \t\f\r' '\\n\\n\\n\\n'|");
1159 #endif
1160 #endif /* !CSH */
1161 #endif /* !DOSISH */
1162                 (void)do_open(last_in_gv, SvPVX(tmpcmd), SvCUR(tmpcmd),
1163                               FALSE, 0, 0, Nullfp);
1164                 fp = IoIFP(io);
1165 #endif /* !VMS */
1166                 LEAVE;
1167             }
1168         }
1169         else if (type == OP_GLOB)
1170             SP--;
1171     }
1172     if (!fp) {
1173         if (dowarn && io && !(IoFLAGS(io) & IOf_START))
1174             warn("Read on closed filehandle <%s>", GvENAME(last_in_gv));
1175         if (gimme == G_SCALAR) {
1176             (void)SvOK_off(TARG);
1177             PUSHTARG;
1178         }
1179         RETURN;
1180     }
1181     if (gimme == G_SCALAR) {
1182         sv = TARG;
1183         if (SvROK(sv))
1184             sv_unref(sv);
1185         (void)SvUPGRADE(sv, SVt_PV);
1186         tmplen = SvLEN(sv);     /* remember if already alloced */
1187         if (!tmplen)
1188             Sv_Grow(sv, 80);    /* try short-buffering it */
1189         if (type == OP_RCATLINE)
1190             offset = SvCUR(sv);
1191         else
1192             offset = 0;
1193     }
1194     else {
1195         sv = sv_2mortal(NEWSV(57, 80));
1196         offset = 0;
1197     }
1198     for (;;) {
1199         if (!sv_gets(sv, fp, offset)) {
1200             PerlIO_clearerr(fp);
1201             if (IoFLAGS(io) & IOf_ARGV) {
1202                 fp = nextargv(last_in_gv);
1203                 if (fp)
1204                     continue;
1205                 (void)do_close(last_in_gv, FALSE);
1206                 IoFLAGS(io) |= IOf_START;
1207             }
1208             else if (type == OP_GLOB) {
1209                 if (do_close(last_in_gv, FALSE) & ~0xFF)
1210                     warn("internal error: glob failed");
1211             }
1212             if (gimme == G_SCALAR) {
1213                 (void)SvOK_off(TARG);
1214                 PUSHTARG;
1215             }
1216             RETURN;
1217         }
1218         /* This should not be marked tainted if the fp is marked clean */
1219         if (!(IoFLAGS(io) & IOf_UNTAINT)) {
1220             TAINT;
1221             SvTAINTED_on(sv);
1222         }
1223         IoLINES(io)++;
1224         SvSETMAGIC(sv);
1225         XPUSHs(sv);
1226         if (type == OP_GLOB) {
1227             char *tmps;
1228
1229             if (SvCUR(sv) > 0 && SvCUR(rs) > 0) {
1230                 tmps = SvEND(sv) - 1;
1231                 if (*tmps == *SvPVX(rs)) {
1232                     *tmps = '\0';
1233                     SvCUR(sv)--;
1234                 }
1235             }
1236             for (tmps = SvPVX(sv); *tmps; tmps++)
1237                 if (!isALPHA(*tmps) && !isDIGIT(*tmps) &&
1238                     strchr("$&*(){}[]'\";\\|?<>~`", *tmps))
1239                         break;
1240             if (*tmps && Stat(SvPVX(sv), &statbuf) < 0) {
1241                 (void)POPs;             /* Unmatched wildcard?  Chuck it... */
1242                 continue;
1243             }
1244         }
1245         if (gimme == G_ARRAY) {
1246             if (SvLEN(sv) - SvCUR(sv) > 20) {
1247                 SvLEN_set(sv, SvCUR(sv)+1);
1248                 Renew(SvPVX(sv), SvLEN(sv), char);
1249             }
1250             sv = sv_2mortal(NEWSV(58, 80));
1251             continue;
1252         }
1253         else if (gimme == G_SCALAR && !tmplen && SvLEN(sv) - SvCUR(sv) > 80) {
1254             /* try to reclaim a bit of scalar space (only on 1st alloc) */
1255             if (SvCUR(sv) < 60)
1256                 SvLEN_set(sv, 80);
1257             else
1258                 SvLEN_set(sv, SvCUR(sv)+40);    /* allow some slop */
1259             Renew(SvPVX(sv), SvLEN(sv), char);
1260         }
1261         RETURN;
1262     }
1263 }
1264
1265 PP(pp_enter)
1266 {
1267     dSP;
1268     register CONTEXT *cx;
1269     I32 gimme = OP_GIMME(op, -1);
1270
1271     if (gimme == -1) {
1272         if (cxstack_ix >= 0)
1273             gimme = cxstack[cxstack_ix].blk_gimme;
1274         else
1275             gimme = G_SCALAR;
1276     }
1277
1278     ENTER;
1279
1280     SAVETMPS;
1281     PUSHBLOCK(cx, CXt_BLOCK, sp);
1282
1283     RETURN;
1284 }
1285
1286 PP(pp_helem)
1287 {
1288     dSP;
1289     HE* he;
1290     SV **svp;
1291     SV *keysv = POPs;
1292     HV *hv = (HV*)POPs;
1293     U32 lval = op->op_flags & OPf_MOD;
1294     U32 defer = op->op_private & OPpLVAL_DEFER;
1295
1296     if (SvTYPE(hv) == SVt_PVHV) {
1297         he = hv_fetch_ent(hv, keysv, lval && !defer, 0);
1298         svp = he ? &HeVAL(he) : 0;
1299     }
1300     else if (SvTYPE(hv) == SVt_PVAV) {
1301         svp = avhv_fetch_ent((AV*)hv, keysv, lval && !defer, 0);
1302     }
1303     else {
1304         RETPUSHUNDEF;
1305     }
1306     if (lval) {
1307         if (!svp || *svp == &sv_undef) {
1308             SV* lv;
1309             SV* key2;
1310             if (!defer)
1311                 DIE(no_helem, SvPV(keysv, na));
1312             lv = sv_newmortal();
1313             sv_upgrade(lv, SVt_PVLV);
1314             LvTYPE(lv) = 'y';
1315             sv_magic(lv, key2 = newSVsv(keysv), 'y', Nullch, 0);
1316             SvREFCNT_dec(key2); /* sv_magic() increments refcount */
1317             LvTARG(lv) = SvREFCNT_inc(hv);
1318             LvTARGLEN(lv) = 1;
1319             PUSHs(lv);
1320             RETURN;
1321         }
1322         if (op->op_private & OPpLVAL_INTRO) {
1323             if (HvNAME(hv) && isGV(*svp))
1324                 save_gp((GV*)*svp, !(op->op_flags & OPf_SPECIAL));
1325             else
1326                 save_svref(svp);
1327         }
1328         else if (op->op_private & OPpDEREF)
1329             vivify_ref(*svp, op->op_private & OPpDEREF);
1330     }
1331     PUSHs(svp ? *svp : &sv_undef);
1332     RETURN;
1333 }
1334
1335 PP(pp_leave)
1336 {
1337     dSP;
1338     register CONTEXT *cx;
1339     register SV **mark;
1340     SV **newsp;
1341     PMOP *newpm;
1342     I32 gimme;
1343
1344     if (op->op_flags & OPf_SPECIAL) {
1345         cx = &cxstack[cxstack_ix];
1346         cx->blk_oldpm = curpm;  /* fake block should preserve $1 et al */
1347     }
1348
1349     POPBLOCK(cx,newpm);
1350
1351     gimme = OP_GIMME(op, -1);
1352     if (gimme == -1) {
1353         if (cxstack_ix >= 0)
1354             gimme = cxstack[cxstack_ix].blk_gimme;
1355         else
1356             gimme = G_SCALAR;
1357     }
1358
1359     TAINT_NOT;
1360     if (gimme == G_VOID)
1361         SP = newsp;
1362     else if (gimme == G_SCALAR) {
1363         MARK = newsp + 1;
1364         if (MARK <= SP)
1365             if (SvFLAGS(TOPs) & (SVs_PADTMP|SVs_TEMP))
1366                 *MARK = TOPs;
1367             else
1368                 *MARK = sv_mortalcopy(TOPs);
1369         else {
1370             MEXTEND(mark,0);
1371             *MARK = &sv_undef;
1372         }
1373         SP = MARK;
1374     }
1375     else if (gimme == G_ARRAY) {
1376         /* in case LEAVE wipes old return values */
1377         for (mark = newsp + 1; mark <= SP; mark++) {
1378             if (!(SvFLAGS(*mark) & (SVs_PADTMP|SVs_TEMP))) {
1379                 *mark = sv_mortalcopy(*mark);
1380                 TAINT_NOT;      /* Each item is independent */
1381             }
1382         }
1383     }
1384     curpm = newpm;      /* Don't pop $1 et al till now */
1385
1386     LEAVE;
1387
1388     RETURN;
1389 }
1390
1391 PP(pp_iter)
1392 {
1393     dSP;
1394     register CONTEXT *cx;
1395     SV* sv;
1396     AV* av;
1397
1398     EXTEND(sp, 1);
1399     cx = &cxstack[cxstack_ix];
1400     if (cx->cx_type != CXt_LOOP)
1401         DIE("panic: pp_iter");
1402
1403     av = cx->blk_loop.iterary;
1404     if (cx->blk_loop.iterix >= (av == curstack ? cx->blk_oldsp : AvFILL(av)))
1405         RETPUSHNO;
1406
1407     SvREFCNT_dec(*cx->blk_loop.itervar);
1408
1409     if (sv = AvARRAY(av)[++cx->blk_loop.iterix])
1410         SvTEMP_off(sv);
1411     else
1412         sv = &sv_undef;
1413     if (av != curstack && SvIMMORTAL(sv)) {
1414         SV *lv = cx->blk_loop.iterlval;
1415         if (lv && SvREFCNT(lv) > 1) {
1416             SvREFCNT_dec(lv);
1417             lv = Nullsv;
1418         }
1419         if (lv)
1420             SvREFCNT_dec(LvTARG(lv));
1421         else {
1422             lv = cx->blk_loop.iterlval = NEWSV(26, 0);
1423             sv_upgrade(lv, SVt_PVLV);
1424             LvTYPE(lv) = 'y';
1425             sv_magic(lv, Nullsv, 'y', Nullch, 0);
1426         }
1427         LvTARG(lv) = SvREFCNT_inc(av);
1428         LvTARGOFF(lv) = cx->blk_loop.iterix;
1429         LvTARGLEN(lv) = -1;
1430         sv = (SV*)lv;
1431     }
1432
1433     *cx->blk_loop.itervar = SvREFCNT_inc(sv);
1434     RETPUSHYES;
1435 }
1436
1437 PP(pp_subst)
1438 {
1439     dSP; dTARG;
1440     register PMOP *pm = cPMOP;
1441     PMOP *rpm = pm;
1442     register SV *dstr;
1443     register char *s;
1444     char *strend;
1445     register char *m;
1446     char *c;
1447     register char *d;
1448     STRLEN clen;
1449     I32 iters = 0;
1450     I32 maxiters;
1451     register I32 i;
1452     bool once;
1453     bool rxtainted;
1454     char *orig;
1455     I32 safebase;
1456     register REGEXP *rx = pm->op_pmregexp;
1457     STRLEN len;
1458     int force_on_match = 0;
1459     I32 oldsave = savestack_ix;
1460
1461     /* known replacement string? */
1462     dstr = (pm->op_pmflags & PMf_CONST) ? POPs : Nullsv;
1463     if (op->op_flags & OPf_STACKED)
1464         TARG = POPs;
1465     else {
1466         TARG = GvSV(defgv);
1467         EXTEND(SP,1);
1468     }
1469     if (SvREADONLY(TARG)
1470         || (SvTYPE(TARG) > SVt_PVLV
1471             && !(SvTYPE(TARG) == SVt_PVGV && SvFAKE(TARG))))
1472         croak(no_modify);
1473     s = SvPV(TARG, len);
1474     if (!SvPOKp(TARG) || SvTYPE(TARG) == SVt_PVGV)
1475         force_on_match = 1;
1476     TAINT_NOT;
1477
1478   force_it:
1479     if (!pm || !s)
1480         DIE("panic: do_subst");
1481
1482     strend = s + len;
1483     maxiters = (strend - s) + 10;
1484
1485     if (!rx->prelen && curpm) {
1486         pm = curpm;
1487         rx = pm->op_pmregexp;
1488     }
1489     safebase = (!rx->nparens && !sawampersand);
1490     if (pm->op_pmflags & (PMf_MULTILINE|PMf_SINGLELINE)) {
1491         SAVEINT(multiline);
1492         multiline = pm->op_pmflags & PMf_MULTILINE;
1493     }
1494     orig = m = s;
1495     if (pm->op_pmshort) {
1496         if (pm->op_pmflags & PMf_SCANFIRST) {
1497             if (SvSCREAM(TARG)) {
1498                 if (screamfirst[BmRARE(pm->op_pmshort)] < 0)
1499                     goto nope;
1500                 else if (!(s = screaminstr(TARG, pm->op_pmshort)))
1501                     goto nope;
1502             }
1503             else if (!(s = fbm_instr((unsigned char*)s, (unsigned char*)strend,
1504               pm->op_pmshort)))
1505                 goto nope;
1506             if (s && rx->regback >= 0) {
1507                 ++BmUSEFUL(pm->op_pmshort);
1508                 s -= rx->regback;
1509                 if (s < m)
1510                     s = m;
1511             }
1512             else
1513                 s = m;
1514         }
1515         else if (!multiline) {
1516             if (*SvPVX(pm->op_pmshort) != *s
1517                 || (pm->op_pmslen > 1
1518                     && memNE(SvPVX(pm->op_pmshort), s, pm->op_pmslen)))
1519                 goto nope;
1520         }
1521         if (!rx->naughty && --BmUSEFUL(pm->op_pmshort) < 0) {
1522             SvREFCNT_dec(pm->op_pmshort);
1523             pm->op_pmshort = Nullsv;    /* opt is being useless */
1524         }
1525     }
1526
1527     /* only replace once? */
1528     once = !(rpm->op_pmflags & PMf_GLOBAL);
1529
1530     /* known replacement string? */
1531     c = dstr ? SvPV(dstr, clen) : Nullch;
1532
1533     /* can do inplace substitution? */
1534     if (c && clen <= rx->minlen && safebase) {
1535         if (! pregexec(rx, s, strend, orig, 0,
1536                        SvSCREAM(TARG) ? TARG : Nullsv, safebase)) {
1537             PUSHs(&sv_no);
1538             LEAVE_SCOPE(oldsave);
1539             RETURN;
1540         }
1541         if (force_on_match) {
1542             force_on_match = 0;
1543             s = SvPV_force(TARG, len);
1544             goto force_it;
1545         }
1546         d = s;
1547         curpm = pm;
1548         SvSCREAM_off(TARG);     /* disable possible screamer */
1549         if (once) {
1550             rxtainted = rx->exec_tainted;
1551             m = rx->startp[0];
1552             d = rx->endp[0];
1553             s = orig;
1554             if (m - s > strend - d) {  /* faster to shorten from end */
1555                 if (clen) {
1556                     Copy(c, m, clen, char);
1557                     m += clen;
1558                 }
1559                 i = strend - d;
1560                 if (i > 0) {
1561                     Move(d, m, i, char);
1562                     m += i;
1563                 }
1564                 *m = '\0';
1565                 SvCUR_set(TARG, m - s);
1566             }
1567             /*SUPPRESS 560*/
1568             else if (i = m - s) {       /* faster from front */
1569                 d -= clen;
1570                 m = d;
1571                 sv_chop(TARG, d-i);
1572                 s += i;
1573                 while (i--)
1574                     *--d = *--s;
1575                 if (clen)
1576                     Copy(c, m, clen, char);
1577             }
1578             else if (clen) {
1579                 d -= clen;
1580                 sv_chop(TARG, d);
1581                 Copy(c, d, clen, char);
1582             }
1583             else {
1584                 sv_chop(TARG, d);
1585             }
1586             TAINT_IF(rxtainted);
1587             PUSHs(&sv_yes);
1588         }
1589         else {
1590             rxtainted = 0;
1591             do {
1592                 if (iters++ > maxiters)
1593                     DIE("Substitution loop");
1594                 rxtainted |= rx->exec_tainted;
1595                 m = rx->startp[0];
1596                 /*SUPPRESS 560*/
1597                 if (i = m - s) {
1598                     if (s != d)
1599                         Move(s, d, i, char);
1600                     d += i;
1601                 }
1602                 if (clen) {
1603                     Copy(c, d, clen, char);
1604                     d += clen;
1605                 }
1606                 s = rx->endp[0];
1607             } while (pregexec(rx, s, strend, orig, s == m,
1608                               Nullsv, TRUE)); /* don't match same null twice */
1609             if (s != d) {
1610                 i = strend - s;
1611                 SvCUR_set(TARG, d - SvPVX(TARG) + i);
1612                 Move(s, d, i+1, char);          /* include the NUL */
1613             }
1614             TAINT_IF(rxtainted);
1615             PUSHs(sv_2mortal(newSViv((I32)iters)));
1616         }
1617         (void)SvPOK_only(TARG);
1618         SvSETMAGIC(TARG);
1619         SvTAINT(TARG);
1620         LEAVE_SCOPE(oldsave);
1621         RETURN;
1622     }
1623
1624     if (pregexec(rx, s, strend, orig, 0,
1625                  SvSCREAM(TARG) ? TARG : Nullsv, safebase)) {
1626         if (force_on_match) {
1627             force_on_match = 0;
1628             s = SvPV_force(TARG, len);
1629             goto force_it;
1630         }
1631         rxtainted = rx->exec_tainted;
1632         dstr = NEWSV(25, sv_len(TARG));
1633         sv_setpvn(dstr, m, s-m);
1634         curpm = pm;
1635         if (!c) {
1636             register CONTEXT *cx;
1637             PUSHSUBST(cx);
1638             RETURNOP(cPMOP->op_pmreplroot);
1639         }
1640         do {
1641             if (iters++ > maxiters)
1642                 DIE("Substitution loop");
1643             rxtainted |= rx->exec_tainted;
1644             if (rx->subbase && rx->subbase != orig) {
1645                 m = s;
1646                 s = orig;
1647                 orig = rx->subbase;
1648                 s = orig + (m - s);
1649                 strend = s + (strend - m);
1650             }
1651             m = rx->startp[0];
1652             sv_catpvn(dstr, s, m-s);
1653             s = rx->endp[0];
1654             if (clen)
1655                 sv_catpvn(dstr, c, clen);
1656             if (once)
1657                 break;
1658         } while (pregexec(rx, s, strend, orig, s == m, Nullsv, safebase));
1659         sv_catpvn(dstr, s, strend - s);
1660
1661         TAINT_IF(rxtainted);
1662
1663         (void)SvOOK_off(TARG);
1664         Safefree(SvPVX(TARG));
1665         SvPVX(TARG) = SvPVX(dstr);
1666         SvCUR_set(TARG, SvCUR(dstr));
1667         SvLEN_set(TARG, SvLEN(dstr));
1668         SvPVX(dstr) = 0;
1669         sv_free(dstr);
1670
1671         (void)SvPOK_only(TARG);
1672         SvSETMAGIC(TARG);
1673         SvTAINT(TARG);
1674         PUSHs(sv_2mortal(newSViv((I32)iters)));
1675         LEAVE_SCOPE(oldsave);
1676         RETURN;
1677     }
1678     goto ret_no;
1679
1680 nope:
1681     ++BmUSEFUL(pm->op_pmshort);
1682
1683 ret_no:
1684     PUSHs(&sv_no);
1685     LEAVE_SCOPE(oldsave);
1686     RETURN;
1687 }
1688
1689 PP(pp_grepwhile)
1690 {
1691     dSP;
1692
1693     if (SvTRUEx(POPs))
1694         stack_base[markstack_ptr[-1]++] = stack_base[*markstack_ptr];
1695     ++*markstack_ptr;
1696     LEAVE;                                      /* exit inner scope */
1697
1698     /* All done yet? */
1699     if (stack_base + *markstack_ptr > sp) {
1700         I32 items;
1701         I32 gimme = GIMME_V;
1702
1703         LEAVE;                                  /* exit outer scope */
1704         (void)POPMARK;                          /* pop src */
1705         items = --*markstack_ptr - markstack_ptr[-1];
1706         (void)POPMARK;                          /* pop dst */
1707         SP = stack_base + POPMARK;              /* pop original mark */
1708         if (gimme == G_SCALAR) {
1709             dTARGET;
1710             XPUSHi(items);
1711         }
1712         else if (gimme == G_ARRAY)
1713             SP += items;
1714         RETURN;
1715     }
1716     else {
1717         SV *src;
1718
1719         ENTER;                                  /* enter inner scope */
1720         SAVESPTR(curpm);
1721
1722         src = stack_base[*markstack_ptr];
1723         SvTEMP_off(src);
1724         GvSV(defgv) = src;
1725
1726         RETURNOP(cLOGOP->op_other);
1727     }
1728 }
1729
1730 PP(pp_leavesub)
1731 {
1732     dSP;
1733     SV **mark;
1734     SV **newsp;
1735     PMOP *newpm;
1736     I32 gimme;
1737     register CONTEXT *cx;
1738     struct block_sub cxsub;
1739
1740     POPBLOCK(cx,newpm);
1741     POPSUB1(cx);        /* Delay POPSUB2 until stack values are safe */
1742
1743     TAINT_NOT;
1744     if (gimme == G_SCALAR) {
1745         MARK = newsp + 1;
1746         if (MARK <= SP)
1747             *MARK = SvTEMP(TOPs) ? TOPs : sv_mortalcopy(TOPs);
1748         else {
1749             MEXTEND(MARK, 0);
1750             *MARK = &sv_undef;
1751         }
1752         SP = MARK;
1753     }
1754     else if (gimme == G_ARRAY) {
1755         for (MARK = newsp + 1; MARK <= SP; MARK++) {
1756             if (!SvTEMP(*MARK)) {
1757                 *MARK = sv_mortalcopy(*MARK);
1758                 TAINT_NOT;      /* Each item is independent */
1759             }
1760         }
1761     }
1762     PUTBACK;
1763
1764     POPSUB2();          /* Stack values are safe: release CV and @_ ... */
1765     curpm = newpm;      /* ... and pop $1 et al */
1766
1767     LEAVE;
1768     return pop_return();
1769 }
1770
1771 PP(pp_entersub)
1772 {
1773     dSP; dPOPss;
1774     GV *gv;
1775     HV *stash;
1776     register CV *cv;
1777     register CONTEXT *cx;
1778     I32 gimme;
1779     bool hasargs = (op->op_flags & OPf_STACKED) != 0;
1780
1781     if (!sv)
1782         DIE("Not a CODE reference");
1783     switch (SvTYPE(sv)) {
1784     default:
1785         if (!SvROK(sv)) {
1786             char *sym;
1787
1788             if (sv == &sv_yes)          /* unfound import, ignore */
1789                 RETURN;
1790             if (SvGMAGICAL(sv)) {
1791                 mg_get(sv);
1792                 sym = SvPOKp(sv) ? SvPVX(sv) : Nullch;
1793             }
1794             else
1795                 sym = SvPV(sv, na);
1796             if (!sym)
1797                 DIE(no_usym, "a subroutine");
1798             if (op->op_private & HINT_STRICT_REFS)
1799                 DIE(no_symref, sym, "a subroutine");
1800             cv = perl_get_cv(sym, TRUE);
1801             break;
1802         }
1803         cv = (CV*)SvRV(sv);
1804         if (SvTYPE(cv) == SVt_PVCV)
1805             break;
1806         /* FALL THROUGH */
1807     case SVt_PVHV:
1808     case SVt_PVAV:
1809         DIE("Not a CODE reference");
1810     case SVt_PVCV:
1811         cv = (CV*)sv;
1812         break;
1813     case SVt_PVGV:
1814         if (!(cv = GvCVu((GV*)sv)))
1815             cv = sv_2cv(sv, &stash, &gv, TRUE);
1816         break;
1817     }
1818
1819     ENTER;
1820     SAVETMPS;
1821
1822   retry:
1823     if (!cv)
1824         DIE("Not a CODE reference");
1825
1826     if (!CvROOT(cv) && !CvXSUB(cv)) {
1827         GV* autogv;
1828         SV* subname;
1829
1830         /* anonymous or undef'd function leaves us no recourse */
1831         if (CvANON(cv) || !(gv = CvGV(cv)))
1832             DIE("Undefined subroutine called");
1833         /* autoloaded stub? */
1834         if (cv != GvCV(gv)) {
1835             cv = GvCV(gv);
1836             goto retry;
1837         }
1838         /* should call AUTOLOAD now? */
1839         if ((autogv = gv_autoload4(GvSTASH(gv), GvNAME(gv), GvNAMELEN(gv),
1840                                    FALSE)))
1841         {
1842             cv = GvCV(autogv);
1843             goto retry;
1844         }
1845         /* sorry */
1846         subname = sv_newmortal();
1847         gv_efullname3(subname, gv, Nullch);
1848         DIE("Undefined subroutine &%s called", SvPVX(subname));
1849     }
1850
1851     gimme = GIMME_V;
1852     if ((op->op_private & OPpENTERSUB_DB) && GvCV(DBsub) && !CvNODEBUG(cv)) {
1853         SV *oldsv = sv;
1854         sv = GvSV(DBsub);
1855         save_item(sv);
1856         gv = CvGV(cv);
1857         if ( (CvFLAGS(cv) & (CVf_ANON | CVf_CLONED))
1858              || strEQ(GvNAME(gv), "END")
1859              || ((GvCV(gv) != cv) && /* Could be imported, and old sub redefined. */
1860                  !( (SvTYPE(oldsv) == SVt_PVGV) && (GvCV((GV*)oldsv) == cv)
1861                     && (gv = (GV*)oldsv) ))) { /* Use GV from the stack as a fallback. */
1862             /* GV is potentially non-unique, or contain different CV. */
1863             sv_setsv(sv, newRV((SV*)cv));
1864         }
1865         else {
1866             gv_efullname3(sv, gv, Nullch);
1867         }
1868         cv = GvCV(DBsub);
1869         if (CvXSUB(cv)) curcopdb = curcop;
1870         if (!cv)
1871             DIE("No DBsub routine");
1872     }
1873
1874 #ifdef USE_THREADS
1875     MUTEX_LOCK(CvMUTEXP(cv));
1876     if (CvFLAGS(cv) & CVf_LOCKED) {
1877         MAGIC *mg;
1878         if (CvFLAGS(cv) & CVf_METHOD) {
1879             if (SP > stack_base + TOPMARK)
1880                 sv = *(stack_base + TOPMARK + 1);
1881             else {
1882                 MUTEX_UNLOCK(CvMUTEXP(cv));
1883                 croak("no argument for locked method call");
1884             }
1885             if (SvROK(sv))
1886                 sv = SvRV(sv);
1887         }
1888         else {
1889             sv = (SV*)cv;
1890         }
1891         MUTEX_UNLOCK(CvMUTEXP(cv));
1892         mg = condpair_magic(sv);
1893         MUTEX_LOCK(MgMUTEXP(mg));
1894         if (MgOWNER(mg) == thr)
1895             MUTEX_UNLOCK(MgMUTEXP(mg));
1896         else {
1897             while (MgOWNER(mg))
1898                 COND_WAIT(MgOWNERCONDP(mg), MgMUTEXP(mg));
1899             MgOWNER(mg) = thr;
1900             DEBUG_L(PerlIO_printf(PerlIO_stderr(),
1901                                   "0x%lx: pp_entersub lock 0x%lx\n",
1902                                   (unsigned long)thr, (unsigned long)sv);)
1903             MUTEX_UNLOCK(MgMUTEXP(mg));
1904             save_destructor(unlock_condpair, sv);
1905         }
1906         MUTEX_LOCK(CvMUTEXP(cv));
1907         assert(CvOWNER(cv) == 0);
1908         CvOWNER(cv) = thr;      /* Assert ownership */
1909         SvREFCNT_inc(cv);
1910         MUTEX_UNLOCK(CvMUTEXP(cv));
1911         if (CvDEPTH(cv) == 0)
1912             SAVEDESTRUCTOR(unset_cvowner, (void*) cv);
1913     }
1914     else {
1915         /*
1916          * It's an ordinary unsynchronised CV so we must distinguish
1917          * three cases. (1) It's ours already (and we're recursing);
1918          * (2) it's free (but we may already be using a cached clone);
1919          * (3) another thread owns it. Case (1) is easy: we just use it.
1920          * Case (2) means we look for a clone--if we have one, use it
1921          * otherwise grab ownership of cv. Case (3) means look we for a
1922          * clone and have to create one if we don't already have one.
1923          * Why look for a clone in case (2) when we could just grab
1924          * ownership of cv straight away? Well, we could be recursing,
1925          * i.e. we originally tried to enter cv while another thread
1926          * owned it (hence we used a clone) but it has been freed up
1927          * and we're now recursing into it. It may or may not be "better"
1928          * to use the clone but at least CvDEPTH can be trusted.
1929          */
1930         if (CvOWNER(cv) == thr)
1931             MUTEX_UNLOCK(CvMUTEXP(cv));
1932         else {
1933             /* Case (2) or (3) */
1934             SV **svp;
1935
1936             /*
1937              * XXX Might it be better to release CvMUTEXP(cv) while we
1938              * do the hv_fetch? We might find someone has pinched it
1939              * when we look again, in which case we would be in case
1940              * (3) instead of (2) so we'd have to clone. Would the fact
1941              * that we released the mutex more quickly make up for this?
1942              */
1943             svp = hv_fetch(cvcache, (char *)cv, sizeof(cv), FALSE);
1944             if (svp) {
1945                 /* We already have a clone to use */
1946                 MUTEX_UNLOCK(CvMUTEXP(cv));
1947                 cv = *(CV**)svp;
1948                 DEBUG_L(PerlIO_printf(PerlIO_stderr(),
1949                                 "entersub: 0x%lx already has clone 0x%lx:%s\n",
1950                                 (unsigned long) thr, (unsigned long) cv,
1951                                 SvPEEK((SV*)cv)));
1952                 CvOWNER(cv) = thr;
1953                 SvREFCNT_inc(cv);
1954                 if (CvDEPTH(cv) == 0)
1955                     SAVEDESTRUCTOR(unset_cvowner, (void*) cv);
1956             }
1957             else {
1958                 /* (2) => grab ownership of cv. (3) => make clone */
1959                 if (!CvOWNER(cv)) {
1960                     CvOWNER(cv) = thr;
1961                     SvREFCNT_inc(cv);
1962                     MUTEX_UNLOCK(CvMUTEXP(cv));
1963                     DEBUG_L(PerlIO_printf(PerlIO_stderr(),
1964                                     "entersub: 0x%lx grabbing 0x%lx:%s in stash %s\n",
1965                                     (unsigned long) thr, (unsigned long) cv,
1966                                     SvPEEK((SV*)cv), CvSTASH(cv) ?
1967                                         HvNAME(CvSTASH(cv)) : "(none)"));
1968                 } else {
1969                     /* Make a new clone. */
1970                     CV *clonecv;
1971                     SvREFCNT_inc(cv); /* don't let it vanish from under us */
1972                     MUTEX_UNLOCK(CvMUTEXP(cv));
1973                     DEBUG_L((PerlIO_printf(PerlIO_stderr(),
1974                                      "entersub: 0x%lx cloning 0x%lx:%s\n",
1975                                      (unsigned long) thr, (unsigned long) cv,
1976                                      SvPEEK((SV*)cv))));
1977                     /*
1978                      * We're creating a new clone so there's no race
1979                      * between the original MUTEX_UNLOCK and the
1980                      * SvREFCNT_inc since no one will be trying to undef
1981                      * it out from underneath us. At least, I don't think
1982                      * there's a race...
1983                      */
1984                     clonecv = cv_clone(cv);
1985                     SvREFCNT_dec(cv); /* finished with this */
1986                     hv_store(cvcache, (char*)cv, sizeof(cv), (SV*)clonecv,0);
1987                     CvOWNER(clonecv) = thr;
1988                     cv = clonecv;
1989                     SvREFCNT_inc(cv);
1990                 }
1991                 DEBUG_L(if (CvDEPTH(cv) != 0)
1992                             PerlIO_printf(PerlIO_stderr(), "depth %ld != 0\n",
1993                                           CvDEPTH(cv)););
1994                 SAVEDESTRUCTOR(unset_cvowner, (void*) cv);
1995             }
1996         }
1997     }
1998 #endif /* USE_THREADS */
1999
2000     gimme = GIMME;
2001
2002     if (CvXSUB(cv)) {
2003         if (CvOLDSTYLE(cv)) {
2004             I32 (*fp3)_((int,int,int));
2005             dMARK;
2006             register I32 items = SP - MARK;
2007                                         /* We dont worry to copy from @_. */
2008             while (sp > mark) {
2009                 sp[1] = sp[0];
2010                 sp--;
2011             }
2012             stack_sp = mark + 1;
2013             fp3 = (I32(*)_((int,int,int)))CvXSUB(cv);
2014             items = (*fp3)(CvXSUBANY(cv).any_i32,
2015                            MARK - stack_base + 1,
2016                            items);
2017             stack_sp = stack_base + items;
2018         }
2019         else {
2020             I32 markix = TOPMARK;
2021
2022             PUTBACK;
2023
2024             if (!hasargs) {
2025                 /* Need to copy @_ to stack. Alternative may be to
2026                  * switch stack to @_, and copy return values
2027                  * back. This would allow popping @_ in XSUB, e.g.. XXXX */
2028                 AV* av;
2029                 I32 items;
2030 #ifdef USE_THREADS
2031                 av = (AV*)curpad[0];
2032 #else
2033                 av = GvAV(defgv);
2034 #endif /* USE_THREADS */
2035                 items = AvFILL(av) + 1;
2036
2037                 if (items) {
2038                     /* Mark is at the end of the stack. */
2039                     EXTEND(sp, items);
2040                     Copy(AvARRAY(av), sp + 1, items, SV*);
2041                     sp += items;
2042                     PUTBACK ;
2043                 }
2044             }
2045             if (curcopdb) {             /* We assume that the first
2046                                            XSUB in &DB::sub is the
2047                                            called one. */
2048                 SAVESPTR(curcop);
2049                 curcop = curcopdb;
2050                 curcopdb = NULL;
2051             }
2052             /* Do we need to open block here? XXXX */
2053             (void)(*CvXSUB(cv))(cv);
2054
2055             /* Enforce some sanity in scalar context. */
2056             if (gimme == G_SCALAR && ++markix != stack_sp - stack_base ) {
2057                 if (markix > stack_sp - stack_base)
2058                     *(stack_base + markix) = &sv_undef;
2059                 else
2060                     *(stack_base + markix) = *stack_sp;
2061                 stack_sp = stack_base + markix;
2062             }
2063         }
2064         LEAVE;
2065         return NORMAL;
2066     }
2067     else {
2068         dMARK;
2069         register I32 items = SP - MARK;
2070         AV* padlist = CvPADLIST(cv);
2071         SV** svp = AvARRAY(padlist);
2072         push_return(op->op_next);
2073         PUSHBLOCK(cx, CXt_SUB, MARK);
2074         PUSHSUB(cx);
2075         CvDEPTH(cv)++;
2076         if (CvDEPTH(cv) < 2)
2077             (void)SvREFCNT_inc(cv);
2078         else {  /* save temporaries on recursion? */
2079             if (CvDEPTH(cv) == 100 && dowarn
2080                   && !(perldb && cv == GvCV(DBsub)))
2081                 sub_crush_depth(cv);
2082             if (CvDEPTH(cv) > AvFILL(padlist)) {
2083                 AV *av;
2084                 AV *newpad = newAV();
2085                 SV **oldpad = AvARRAY(svp[CvDEPTH(cv)-1]);
2086                 I32 ix = AvFILL((AV*)svp[1]);
2087                 svp = AvARRAY(svp[0]);
2088                 for ( ;ix > 0; ix--) {
2089                     if (svp[ix] != &sv_undef) {
2090                         char *name = SvPVX(svp[ix]);
2091                         if ((SvFLAGS(svp[ix]) & SVf_FAKE) /* outer lexical? */
2092                             || *name == '&')              /* anonymous code? */
2093                         {
2094                             av_store(newpad, ix, SvREFCNT_inc(oldpad[ix]));
2095                         }
2096                         else {                          /* our own lexical */
2097                             if (*name == '@')
2098                                 av_store(newpad, ix, sv = (SV*)newAV());
2099                             else if (*name == '%')
2100                                 av_store(newpad, ix, sv = (SV*)newHV());
2101                             else
2102                                 av_store(newpad, ix, sv = NEWSV(0,0));
2103                             SvPADMY_on(sv);
2104                         }
2105                     }
2106                     else {
2107                         av_store(newpad, ix, sv = NEWSV(0,0));
2108                         SvPADTMP_on(sv);
2109                     }
2110                 }
2111                 av = newAV();           /* will be @_ */
2112                 av_extend(av, 0);
2113                 av_store(newpad, 0, (SV*)av);
2114                 AvFLAGS(av) = AVf_REIFY;
2115                 av_store(padlist, CvDEPTH(cv), (SV*)newpad);
2116                 AvFILL(padlist) = CvDEPTH(cv);
2117                 svp = AvARRAY(padlist);
2118             }
2119         }
2120 #ifdef USE_THREADS
2121         if (!hasargs) {
2122             AV* av = (AV*)curpad[0];
2123
2124             items = AvFILL(av) + 1;
2125             if (items) {
2126                 /* Mark is at the end of the stack. */
2127                 EXTEND(sp, items);
2128                 Copy(AvARRAY(av), sp + 1, items, SV*);
2129                 sp += items;
2130                 PUTBACK ;
2131             }
2132         }
2133 #endif /* USE_THREADS */
2134         SAVESPTR(curpad);
2135         curpad = AvARRAY((AV*)svp[CvDEPTH(cv)]);
2136 #ifndef USE_THREADS
2137         if (hasargs)
2138 #endif /* USE_THREADS */
2139         {
2140             AV* av;
2141             SV** ary;
2142
2143 #if 0
2144             DEBUG_L(PerlIO_printf(PerlIO_stderr(),
2145                                   "%p entersub preparing @_\n", thr));
2146 #endif
2147             av = (AV*)curpad[0];
2148             if (AvREAL(av)) {
2149                 av_clear(av);
2150                 AvREAL_off(av);
2151             }
2152 #ifndef USE_THREADS
2153             cx->blk_sub.savearray = GvAV(defgv);
2154             GvAV(defgv) = (AV*)SvREFCNT_inc(av);
2155 #endif /* USE_THREADS */
2156             cx->blk_sub.argarray = av;
2157             ++MARK;
2158
2159             if (items > AvMAX(av) + 1) {
2160                 ary = AvALLOC(av);
2161                 if (AvARRAY(av) != ary) {
2162                     AvMAX(av) += AvARRAY(av) - AvALLOC(av);
2163                     SvPVX(av) = (char*)ary;
2164                 }
2165                 if (items > AvMAX(av) + 1) {
2166                     AvMAX(av) = items - 1;
2167                     Renew(ary,items,SV*);
2168                     AvALLOC(av) = ary;
2169                     SvPVX(av) = (char*)ary;
2170                 }
2171             }
2172             Copy(MARK,AvARRAY(av),items,SV*);
2173             AvFILL(av) = items - 1;
2174
2175             while (items--) {
2176                 if (*MARK)
2177                     SvTEMP_off(*MARK);
2178                 MARK++;
2179             }
2180         }
2181 #if 0
2182         DEBUG_L(PerlIO_printf(PerlIO_stderr(),
2183                               "%p entersub returning %p\n", thr, CvSTART(cv)));
2184 #endif
2185         RETURNOP(CvSTART(cv));
2186     }
2187 }
2188
2189 void
2190 sub_crush_depth(cv)
2191 CV* cv;
2192 {
2193     if (CvANON(cv))
2194         warn("Deep recursion on anonymous subroutine");
2195     else {
2196         SV* tmpstr = sv_newmortal();
2197         gv_efullname3(tmpstr, CvGV(cv), Nullch);
2198         warn("Deep recursion on subroutine \"%s\"", SvPVX(tmpstr));
2199     }
2200 }
2201
2202 PP(pp_aelem)
2203 {
2204     dSP;
2205     SV** svp;
2206     I32 elem = POPi;
2207     AV* av = (AV*)POPs;
2208     U32 lval = op->op_flags & OPf_MOD;
2209     U32 defer = (op->op_private & OPpLVAL_DEFER) && (elem > AvFILL(av));
2210
2211     if (elem > 0)
2212         elem -= curcop->cop_arybase;
2213     if (SvTYPE(av) != SVt_PVAV)
2214         RETPUSHUNDEF;
2215     svp = av_fetch(av, elem, lval && !defer);
2216     if (lval) {
2217         if (!svp || *svp == &sv_undef) {
2218             SV* lv;
2219             if (!defer)
2220                 DIE(no_aelem, elem);
2221             lv = sv_newmortal();
2222             sv_upgrade(lv, SVt_PVLV);
2223             LvTYPE(lv) = 'y';
2224             sv_magic(lv, Nullsv, 'y', Nullch, 0);
2225             LvTARG(lv) = SvREFCNT_inc(av);
2226             LvTARGOFF(lv) = elem;
2227             LvTARGLEN(lv) = 1;
2228             PUSHs(lv);
2229             RETURN;
2230         }
2231         if (op->op_private & OPpLVAL_INTRO)
2232             save_svref(svp);
2233         else if (op->op_private & OPpDEREF)
2234             vivify_ref(*svp, op->op_private & OPpDEREF);
2235     }
2236     PUSHs(svp ? *svp : &sv_undef);
2237     RETURN;
2238 }
2239
2240 void
2241 vivify_ref(sv, to_what)
2242 SV* sv;
2243 U32 to_what;
2244 {
2245     if (SvGMAGICAL(sv))
2246         mg_get(sv);
2247     if (!SvOK(sv)) {
2248         if (SvREADONLY(sv))
2249             croak(no_modify);
2250         if (SvTYPE(sv) < SVt_RV)
2251             sv_upgrade(sv, SVt_RV);
2252         else if (SvTYPE(sv) >= SVt_PV) {
2253             (void)SvOOK_off(sv);
2254             Safefree(SvPVX(sv));
2255             SvLEN(sv) = SvCUR(sv) = 0;
2256         }
2257         switch (to_what) {
2258         case OPpDEREF_SV:
2259             SvRV(sv) = newSV(0);
2260             break;
2261         case OPpDEREF_AV:
2262             SvRV(sv) = (SV*)newAV();
2263             break;
2264         case OPpDEREF_HV:
2265             SvRV(sv) = (SV*)newHV();
2266             break;
2267         }
2268         SvROK_on(sv);
2269         SvSETMAGIC(sv);
2270     }
2271 }
2272
2273 PP(pp_method)
2274 {
2275     dSP;
2276     SV* sv;
2277     SV* ob;
2278     GV* gv;
2279     HV* stash;
2280     char* name;
2281     char* packname;
2282     STRLEN packlen;
2283
2284     name = SvPV(TOPs, na);
2285     sv = *(stack_base + TOPMARK + 1);
2286
2287     if (SvGMAGICAL(sv))
2288         mg_get(sv);
2289     if (SvROK(sv))
2290         ob = (SV*)SvRV(sv);
2291     else {
2292         GV* iogv;
2293
2294         packname = Nullch;
2295         if (!SvOK(sv) ||
2296             !(packname = SvPV(sv, packlen)) ||
2297             !(iogv = gv_fetchpv(packname, FALSE, SVt_PVIO)) ||
2298             !(ob=(SV*)GvIO(iogv)))
2299         {
2300             if (!packname || !isIDFIRST(*packname))
2301   DIE("Can't call method \"%s\" without a package or object reference", name);
2302             stash = gv_stashpvn(packname, packlen, TRUE);
2303             goto fetch;
2304         }
2305         *(stack_base + TOPMARK + 1) = sv_2mortal(newRV((SV*)iogv));
2306     }
2307
2308     if (!ob || !SvOBJECT(ob))
2309         DIE("Can't call method \"%s\" on unblessed reference", name);
2310
2311     stash = SvSTASH(ob);
2312
2313   fetch:
2314     gv = gv_fetchmethod(stash, name);
2315     if (!gv) {
2316         char* leaf = name;
2317         char* sep = Nullch;
2318         char* p;
2319
2320         for (p = name; *p; p++) {
2321             if (*p == '\'')
2322                 sep = p, leaf = p + 1;
2323             else if (*p == ':' && *(p + 1) == ':')
2324                 sep = p, leaf = p + 2;
2325         }
2326         if (!sep || ((sep - name) == 5 && strnEQ(name, "SUPER", 5))) {
2327             packname = HvNAME(sep ? curcop->cop_stash : stash);
2328             packlen = strlen(packname);
2329         }
2330         else {
2331             packname = name;
2332             packlen = sep - name;
2333         }
2334         DIE("Can't locate object method \"%s\" via package \"%.*s\"",
2335             leaf, (int)packlen, packname);
2336     }
2337     SETs(isGV(gv) ? (SV*)GvCV(gv) : (SV*)gv);
2338     RETURN;
2339 }