pp_hot.c

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