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