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