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